[system] / trunk / xmlrpc / RPC / RPC-XML-0.25 / lib / RPC / XML.pm Repository:
ViewVC logotype

Annotation of /trunk/xmlrpc/RPC/RPC-XML-0.25/lib/RPC/XML.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 279 - (view) (download) (as text)

1 : gage 279 ###############################################################################
2 :     #
3 :     # This file copyright (c) 2001 by Randy J. Ray <rjray@blackperl.com>,
4 :     # all rights reserved
5 :     #
6 :     # Copying and distribution are permitted under the terms of the Artistic
7 :     # License as distributed with Perl versions 5.005 and later. See
8 :     # http://language.perl.com/misc/Artistic.html
9 :     #
10 :     ###############################################################################
11 :     #
12 :     # $Id$
13 :     #
14 :     # Description: This module provides the core XML <-> RPC conversion and
15 :     # structural management.
16 :     #
17 :     # Functions: This module contains many, many subclasses. Better to
18 :     # examine them individually.
19 :     #
20 :     # Libraries: RPC::XML::base64 uses MIME::Base64
21 :     #
22 :     # Global Consts: $VERSION
23 :     #
24 :     ###############################################################################
25 :    
26 :     package RPC::XML;
27 :    
28 :     use 5.005;
29 :     use strict;
30 :     use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA $VERSION $ERROR);
31 :     use subs qw(time2iso8601 smart_encode);
32 :    
33 :     require Exporter;
34 :    
35 :     @ISA = qw(Exporter);
36 :     @EXPORT_OK = qw(time2iso8601 smart_encode
37 :     RPC_BOOLEAN RPC_INT RPC_DOUBLE RPC_NIL RPC_DATETIME_ISO8601
38 :     RPC_DATETIME_INT RPC_BASE64 RPC_REFERENCE RPC_STRING);
39 :     %EXPORT_TAGS = (types => [ qw(RPC_BOOLEAN RPC_INT RPC_DOUBLE RPC_STRING
40 :     RPC_DATETIME_ISO8601 RPC_BASE64) ],
41 :     all => [ @EXPORT_OK ]);
42 :    
43 :     $VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
44 :    
45 :     # Global error string
46 :     $ERROR = '';
47 :    
48 :     1;
49 :    
50 :     # All of the RPC_* functions are convenience-encoders
51 :     sub RPC_STRING ( $ ) { RPC::XML::string->new($_[0]) }
52 :     sub RPC_BOOLEAN ( $ ) { RPC::XML::boolean->new($_[0]) }
53 :     sub RPC_INT ( $ ) { RPC::XML::int->new($_[0]) }
54 :     sub RPC_DOUBLE ( $ ) { RPC::XML::double->new($_[0]) }
55 :     sub RPC_DATETIME_ISO8601 ( $ ) { RPC::XML::datetime_iso8601->new($_[0]) }
56 :     sub RPC_BASE64 ( $ ) { RPC::XML::base64->new($_[0]) }
57 :    
58 :     # This is a dead-simple ISO8601-from-UNIX-time stringifier. Always expresses
59 :     # time in UTC.
60 :     sub time2iso8601
61 :     {
62 :     my $time = shift;
63 :     my $zone = shift || '';
64 :    
65 :     my @time = gmtime($time);
66 :     $time = sprintf("%4d%02d%02dT%02d:%02d:%02dZ",
67 :     $time[5] + 1900, $time[4] + 1, @time[3, 2, 1, 0]);
68 :     if ($zone)
69 :     {
70 :     my $char = $zone > 0 ? '+' : '-';
71 :     chop $time; # Lose the Z if we're specifying a zone
72 :     $time .= $char . sprintf('%02d:00', abs($zone));
73 :     }
74 :    
75 :     $time;
76 :     }
77 :    
78 :     # This is a (futile?) attempt to provide a "smart" encoding method that will
79 :     # take a Perl scalar and promote it to the appropriate RPC::XML::_type_.
80 :     sub smart_encode
81 :     {
82 :     my @values = @_;
83 :    
84 :     my $type;
85 :    
86 :     @values = map
87 :     {
88 :     if ($type = ref($_))
89 :     {
90 :     # Skip any that have already been encoded
91 :     if (UNIVERSAL::isa($_, 'RPC::XML::datatype'))
92 :     {
93 :     $type = $_;
94 :     }
95 :     elsif ($type eq 'HASH')
96 :     {
97 :     $type = new RPC::XML::struct $_;
98 :     }
99 :     elsif ($type eq 'ARRAY')
100 :     {
101 :     $type = new RPC::XML::array $_;
102 :     }
103 :     else
104 :     {
105 :     # ??? Don't know what else to do
106 :     next;
107 :     }
108 :     }
109 :     # You have to check ints first, because they match the next pattern too
110 :     elsif (/^[-+]?\d+$/)
111 :     {
112 :     $type = new RPC::XML::int $_;
113 :     }
114 :     # Pattern taken from perldata(1)
115 :     elsif (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/)
116 :     {
117 :     $type = new RPC::XML::double $_;
118 :     }
119 :     else
120 :     {
121 :     $type = new RPC::XML::string $_;
122 :     }
123 :    
124 :     $type;
125 :     } @values;
126 :    
127 :     return (wantarray ? @values : $values[0]);
128 :     }
129 :    
130 :     # This is a (mostly) empty class used as a common superclass for simple and
131 :     # complex types, so that their derivatives may be universally type-checked.
132 :     package RPC::XML::datatype;
133 :     use vars qw(@ISA);
134 :     @ISA = ();
135 :    
136 :     sub type { my $class = ref($_[0]) || $_[0]; $class =~ s/.*://; $class }
137 :    
138 :     ###############################################################################
139 :     #
140 :     # Package: RPC::XML::simple_type
141 :     #
142 :     # Description: A base class for the simpler type-classes to inherit from,
143 :     # for default constructor, stringification, etc.
144 :     #
145 :     # Globals: None.
146 :     #
147 :     # Environment: None.
148 :     #
149 :     ###############################################################################
150 :     package RPC::XML::simple_type;
151 :    
152 :     use strict;
153 :     use vars qw(@ISA);
154 :    
155 :     @ISA = qw(RPC::XML::datatype);
156 :    
157 :     # new - a generic constructor that presumes the value being stored is scalar
158 :     sub new
159 :     {
160 :     my $class = shift;
161 :     my $value = shift;
162 :    
163 :     $RPC::XML::ERROR = '';
164 :     $class = ref($class) || $class;
165 :     bless \$value, $class;
166 :     }
167 :    
168 :     # value - a generic accessor
169 :     sub value
170 :     {
171 :     my $self = shift;
172 :    
173 :     $$self;
174 :     }
175 :    
176 :     # as_string - return the value as an XML snippet
177 :     sub as_string
178 :     {
179 :     my $self = shift;
180 :     my $indent = shift || 0;
181 :    
182 :     my $class;
183 :     return unless ($class = ref($self));
184 :     $class =~ s/^.*\://;
185 :     $class =~ s/_/./g;
186 :     substr($class, 0, 8) = 'dateTime' if (substr($class, 0, 8) eq 'datetime');
187 :     my $padding = ' ' x $indent;
188 :    
189 :     "$padding<$class>$$self</$class>";
190 :     }
191 :    
192 :     ###############################################################################
193 :     #
194 :     # Package: RPC::XML::int
195 :     #
196 :     # Description: Data-type class for integers
197 :     #
198 :     # Globals: None.
199 :     #
200 :     # Environment: None.
201 :     #
202 :     ###############################################################################
203 :     package RPC::XML::int;
204 :    
205 :     use strict;
206 :     use vars qw(@ISA);
207 :    
208 :     @ISA = qw(RPC::XML::simple_type);
209 :    
210 :     ###############################################################################
211 :     #
212 :     # Package: RPC::XML::i4
213 :     #
214 :     # Description: Data-type class for i4. Forces data into an int object.
215 :     #
216 :     # Globals: None.
217 :     #
218 :     # Environment: None.
219 :     #
220 :     ###############################################################################
221 :     package RPC::XML::i4;
222 :    
223 :     use strict;
224 :     use vars qw(@ISA);
225 :    
226 :     @ISA = qw(RPC::XML::simple_type);
227 :    
228 :     ###############################################################################
229 :     #
230 :     # Package: RPC::XML::double
231 :     #
232 :     # Description: The "double" type-class
233 :     #
234 :     # Globals: None.
235 :     #
236 :     # Environment: None.
237 :     #
238 :     ###############################################################################
239 :     package RPC::XML::double;
240 :    
241 :     use strict;
242 :     use vars qw(@ISA);
243 :    
244 :     @ISA = qw(RPC::XML::simple_type);
245 :    
246 :     ###############################################################################
247 :     #
248 :     # Package: RPC::XML::string
249 :     #
250 :     # Description: The "string" type-class
251 :     #
252 :     # Globals: None.
253 :     #
254 :     # Environment: None.
255 :     #
256 :     ###############################################################################
257 :     package RPC::XML::string;
258 :    
259 :     use strict;
260 :     use vars qw(@ISA);
261 :    
262 :     @ISA = qw(RPC::XML::datatype);
263 :    
264 :     sub new
265 :     {
266 :     my $class = shift;
267 :     my $value = shift;
268 :    
269 :     $value =~ s/&/&amp;/g;
270 :     $value =~ s/</&lt;/g;
271 :     $value =~ s/>/&gt;/g;
272 :    
273 :     bless \$value, $class;
274 :     }
275 :    
276 :     # value - a generic accessor
277 :     sub value
278 :     {
279 :     my $self = shift;
280 :    
281 :     my $text = $$self;
282 :     $text =~ s/&lt;/</g;
283 :     $text =~ s/&gt;/>/g;
284 :     $text =~ s/&amp;/&/g;
285 :    
286 :     $text;
287 :     }
288 :    
289 :     # as_string - return the value as an XML snippet
290 :     sub as_string
291 :     {
292 :     my $self = shift;
293 :     my $indent = shift || 0;
294 :    
295 :     my ($class, $text);
296 :    
297 :     return unless ($class = ref($self));
298 :     $class =~ s/^.*\://;
299 :     $text = $self->value;
300 :     my $padding = ' ' x $indent;
301 :    
302 :     "$padding<$class>$text</$class>";
303 :     }
304 :    
305 :     ###############################################################################
306 :     #
307 :     # Package: RPC::XML::boolean
308 :     #
309 :     # Description: The type-class for boolean data. Handles some "extra" cases
310 :     #
311 :     # Globals: None.
312 :     #
313 :     # Environment: None.
314 :     #
315 :     ###############################################################################
316 :     package RPC::XML::boolean;
317 :    
318 :     use strict;
319 :     use vars qw(@ISA);
320 :    
321 :     @ISA = qw(RPC::XML::simple_type);
322 :    
323 :     # This constructor allows any of true, false, yes or no to be specified
324 :     sub new
325 :     {
326 :     my $class = shift;
327 :     my $value = shift || 0;
328 :    
329 :     $RPC::XML::ERROR = '';
330 :     if ($value =~ /true|yes/i)
331 :     {
332 :     $value = 1;
333 :     }
334 :     elsif ($value =~ /false|no/i)
335 :     {
336 :     $value = 0;
337 :     }
338 :    
339 :     unless ($value == 1 or $value == 0)
340 :     {
341 :     $class = ref($class) || $class;
342 :     $RPC::XML::ERROR = "${class}::new: Value must be one of yes, no, " .
343 :     'true, false, 1, 0 (case-insensitive)';
344 :     return undef;
345 :     }
346 :    
347 :     bless \$value, $class;
348 :     }
349 :    
350 :     ###############################################################################
351 :     #
352 :     # Package: RPC::XML::datetime_iso8601
353 :     #
354 :     # Description: This is the class to manage ISO8601-style date/time values
355 :     #
356 :     # Globals: None.
357 :     #
358 :     # Environment: None.
359 :     #
360 :     ###############################################################################
361 :     package RPC::XML::datetime_iso8601;
362 :    
363 :     use strict;
364 :     use vars qw(@ISA);
365 :    
366 :     @ISA = qw(RPC::XML::simple_type);
367 :    
368 :     sub type { 'dateTime.iso8601' };
369 :    
370 :     ###############################################################################
371 :     #
372 :     # Package: RPC::XML::array
373 :     #
374 :     # Description: This class encapsulates the array data type. Each element
375 :     # within the array should be one of the datatype classes.
376 :     #
377 :     # Globals: None.
378 :     #
379 :     # Environment: None.
380 :     #
381 :     ###############################################################################
382 :     package RPC::XML::array;
383 :    
384 :     use strict;
385 :     use vars qw(@ISA);
386 :    
387 :     @ISA = qw(RPC::XML::datatype);
388 :    
389 :     # The constructor for this class mainly needs to sanity-check the value data
390 :     sub new
391 :     {
392 :     my $class = shift;
393 :     my @args = (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
394 :    
395 :     # First ensure that each argument passed in is itself one of the data-type
396 :     # class instances.
397 :     for (@args)
398 :     {
399 :     $_ = RPC::XML::smart_encode($_)
400 :     unless (UNIVERSAL::isa($_, 'RPC::XML::datatype'));
401 :     }
402 :    
403 :     bless \@args, $class;
404 :     }
405 :    
406 :     # This became more complex once it was shown that there may be a need to fetch
407 :     # the value while preserving the underlying objects.
408 :     sub value
409 :     {
410 :     my $self = shift;
411 :     my $no_recurse = shift || 0;
412 :     my $ret;
413 :    
414 :     if ($no_recurse)
415 :     {
416 :     $ret = [ @$self ];
417 :     }
418 :     else
419 :     {
420 :     $ret = [ map { $_->value } @$self ];
421 :     }
422 :    
423 :     $ret;
424 :     }
425 :    
426 :     sub as_string
427 :     {
428 :     my $self = shift;
429 :     my $indent = shift || 0;
430 :     my @text;
431 :    
432 :     #
433 :     # Since this is a reference implementation, I want the output of an array
434 :     # when stringified to be somewhat readable. To help with this, I allow a
435 :     # second parameter here that will be used in recursive calls to set a base
436 :     # indent level. Also, the <data> tag will be used for compatibility.
437 :     #
438 :     my $padding = ' ' x $indent;
439 :    
440 :     push(@text,
441 :     "$padding<array>",
442 :     "$padding <data>",
443 :     (map {
444 :     ("$padding <value>",
445 :     $_->as_string($indent + 3),
446 :     "$padding </value>")
447 :     } (@$self)),
448 :     "$padding </data>",
449 :     "$padding</array>");
450 :    
451 :     join("\n", @text);
452 :     }
453 :    
454 :     ###############################################################################
455 :     #
456 :     # Package: RPC::XML::struct
457 :     #
458 :     # Description: This is the "struct" data class. The struct is like Perl's
459 :     # hash, with the constraint that all values are instances
460 :     # of the datatype classes.
461 :     #
462 :     # Globals: None.
463 :     #
464 :     # Environment: None.
465 :     #
466 :     ###############################################################################
467 :     package RPC::XML::struct;
468 :    
469 :     use strict;
470 :     use vars qw(@ISA);
471 :    
472 :     @ISA = qw(RPC::XML::datatype);
473 :    
474 :     # The constructor for this class mainly needs to sanity-check the value data
475 :     sub new
476 :     {
477 :     my $class = shift;
478 :     my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
479 :    
480 :     # First ensure that each argument passed in is itself one of the data-type
481 :     # class instances.
482 :     for (keys %args)
483 :     {
484 :     $args{$_} = RPC::XML::smart_encode($args{$_})
485 :     unless (UNIVERSAL::isa($args{$_}, 'RPC::XML::datatype'));
486 :     }
487 :    
488 :     bless \%args, $class;
489 :     }
490 :    
491 :     # This became more complex once it was shown that there may be a need to fetch
492 :     # the value while preserving the underlying objects.
493 :     sub value
494 :     {
495 :     my $self = shift;
496 :     my $no_recurse = shift || 0;
497 :     my %value;
498 :    
499 :     if ($no_recurse)
500 :     {
501 :     %value = map { $_, $self->{$_} } (keys %$self);
502 :     }
503 :     else
504 :     {
505 :     %value = map { $_, $self->{$_}->value } (keys %$self);
506 :     }
507 :    
508 :     \%value;
509 :     }
510 :    
511 :     sub as_string
512 :     {
513 :     my $self = shift;
514 :     my $indent = shift || 0;
515 :    
516 :     #
517 :     # Since this is a reference implementation, I want the output of a struct
518 :     # when stringified to be somewhat readable. To help with this, I allow a
519 :     # second parameter here that will be used in recursive calls to set a base
520 :     # indent level.
521 :     #
522 :     my $padding = ' ' x $indent;
523 :    
524 :     join("\n",
525 :     "$padding<struct>",
526 :     (map {
527 :     ("$padding <member>",
528 :     "$padding <name>$_</name>",
529 :     "$padding <value>",
530 :     $self->{$_}->as_string($indent + 3),
531 :     "$padding </value>",
532 :     "$padding </member>")
533 :     } (keys %$self)),
534 :     "$padding</struct>");
535 :     }
536 :    
537 :     ###############################################################################
538 :     #
539 :     # Package: RPC::XML::base64
540 :     #
541 :     # Description: This is the base64-encoding type. Plain data is passed in,
542 :     # plain data is returned. Plain is always returned. All the
543 :     # encoding/decoding is done behind the scenes.
544 :     #
545 :     # Globals: None.
546 :     #
547 :     # Environment: None.
548 :     #
549 :     ###############################################################################
550 :     package RPC::XML::base64;
551 :    
552 :     use strict;
553 :     use vars qw(@ISA);
554 :    
555 :     @ISA = qw(RPC::XML::simple_type);
556 :    
557 :     use MIME::Base64;
558 :    
559 :     sub new
560 :     {
561 :     my ($class, $value, $encoded) = @_;
562 :    
563 :     $RPC::XML::ERROR = '';
564 :     $value = $$value if (ref $value);
565 :     unless (defined $value and length $value)
566 :     {
567 :     $class = ref($class) || $class;
568 :     $RPC::XML::ERROR = "${class}::new: Must be called with non-null data";
569 :     return undef;
570 :     }
571 :     if ($encoded)
572 :     {
573 :     $value = MIME::Base64::decode_base64 $value;
574 :     }
575 :    
576 :     bless \$value, $class;
577 :     }
578 :    
579 :     # The value needs to be encoded before being output
580 :     sub as_string
581 :     {
582 :     my $self = shift;
583 :     my $indent = shift || 0;
584 :    
585 :     my $padding = $indent x ' ';
586 :    
587 :     "$padding<value>" . MIME::Base64::encode_base64($$self) . "</value>\n";
588 :     }
589 :    
590 :     ###############################################################################
591 :     #
592 :     # Package: RPC::XML::fault
593 :     #
594 :     # Description: This is the class that encapsulates the data for a RPC
595 :     # fault-response. Like the others, it takes the relevant
596 :     # information and maintains it internally. This is put
597 :     # at the end of the datum types, though it isn't really a
598 :     # data type in the sense that it cannot be passed in to a
599 :     # request. But it is separated so as to better generalize
600 :     # responses.
601 :     #
602 :     # Globals: None.
603 :     #
604 :     # Environment: None.
605 :     #
606 :     ###############################################################################
607 :     package RPC::XML::fault;
608 :    
609 :     use strict;
610 :     use vars qw(@ISA);
611 :    
612 :     @ISA = qw(RPC::XML::struct);
613 :    
614 :     # For our new(), we only need to ensure that we have the two required members
615 :     sub new
616 :     {
617 :     my $class = shift;
618 :     my @args = @_;
619 :    
620 :     my ($self, %args);
621 :    
622 :     $RPC::XML::ERROR = '';
623 :     if (ref($args[0]) and UNIVERSAL::isa($args[0], 'RPC::XML::struct'))
624 :     {
625 :     # Take the keys and values from the struct object as our own
626 :     %args = %{$args[0]->value('shallow')};
627 :     }
628 :     elsif (@args == 2)
629 :     {
630 :     # This is a special convenience-case to make simple new() calls clearer
631 :     %args = (faultCode => RPC::XML::int->new($args[0]),
632 :     faultString => RPC::XML::string->new($args[1]));
633 :     }
634 :     else
635 :     {
636 :     %args = @args;
637 :     }
638 :    
639 :     unless ($args{faultCode} and $args{faultString})
640 :     {
641 :     $class = ref($class) || $class;
642 :     $RPC::XML::ERROR = "${class}::new: Missing required struct fields";
643 :     return undef;
644 :     }
645 :     if (scalar(keys %args) > 2)
646 :     {
647 :     $class = ref($class) || $class;
648 :     $RPC::XML::ERROR = "${class}::new: Extra struct fields not allowed";
649 :     return undef;
650 :     }
651 :    
652 :     $self = $class->SUPER::new(%args);
653 :     }
654 :    
655 :     # This only differs from the display of a struct in that it has some extra
656 :     # wrapped around it. Let the superclass as_string method do most of the work.
657 :     sub as_string
658 :     {
659 :     my $self = shift;
660 :     my $indent = shift || 0;
661 :    
662 :     my $padding = ' ' x $indent;
663 :    
664 :     join("\n",
665 :     "$padding<fault>",
666 :     "$padding <value>",
667 :     $self->SUPER::as_string($indent + 2),
668 :     "$padding </value>",
669 :     "$padding</fault>");
670 :     }
671 :    
672 :     ###############################################################################
673 :     #
674 :     # Package: RPC::XML::request
675 :     #
676 :     # Description: This is the class that encapsulates the data for a RPC
677 :     # request. It takes the relevant information and maintains
678 :     # it internally until asked to stringify. Only then is the
679 :     # XML generated, encoding checked, etc. This allows for
680 :     # late-selection of <methodCall> or <methodCallSet> as a
681 :     # containing tag.
682 :     #
683 :     # This class really only needs a constructor and a method
684 :     # to stringify.
685 :     #
686 :     # Globals: None.
687 :     #
688 :     # Environment: None.
689 :     #
690 :     ###############################################################################
691 :     package RPC::XML::request;
692 :    
693 :     use strict;
694 :     use vars qw(@ISA);
695 :    
696 :     ###############################################################################
697 :     #
698 :     # Sub Name: new
699 :     #
700 :     # Description: Creating a new request object, in this (reference) case,
701 :     # means checking the list of arguments for sanity and
702 :     # packaging it up for later use.
703 :     #
704 :     # Arguments: NAME IN/OUT TYPE DESCRIPTION
705 :     # $class in scalar Class/ref to bless into
706 :     # @argz in list The exact disposition of the
707 :     # arguments is based on the
708 :     # type of the various elements
709 :     #
710 :     # Globals: None.
711 :     #
712 :     # Environment: None.
713 :     #
714 :     # Returns: Success: object ref
715 :     # Failure: undef, error in $RPC::XML::ERROR
716 :     #
717 :     ###############################################################################
718 :     sub new
719 :     {
720 :     my $class = shift;
721 :     my @argz = @_;
722 :    
723 :     my ($self, $name);
724 :    
725 :     $class = ref($class) || $class;
726 :    
727 :     if (! ref($argz[0]))
728 :     {
729 :     # Assume that this is the method name to be called
730 :     $name = shift(@argz);
731 :     }
732 :    
733 :     $RPC::XML::ERROR = '';
734 :     if (UNIVERSAL::isa($argz[0], 'RPC::XML::request'))
735 :     {
736 :     # Maybe this will be a clone operation
737 :     }
738 :     elsif (! $name)
739 :     {
740 :     $RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' .
741 :     'must be specified';
742 :     }
743 :     else
744 :     {
745 :     # All the remaining args must be datatypes.
746 :     @argz = RPC::XML::smart_encode(@argz);
747 :     $self = { args => [ @argz ], name => $name };
748 :     bless $self, $class;
749 :     }
750 :    
751 :     $self;
752 :     }
753 :    
754 :     # Accessor methods
755 :     sub name { shift->{name} }
756 :     sub args { shift->{args} || [] }
757 :    
758 :     ###############################################################################
759 :     #
760 :     # Sub Name: as_string
761 :     #
762 :     # Description: This is a fair bit more complex than the simple as_string
763 :     # methods for the datatypes. Express the invoking object as
764 :     # a well-formed XML document.
765 :     #
766 :     # Arguments: NAME IN/OUT TYPE DESCRIPTION
767 :     # $self in ref Invoking object
768 :     # $indent in scalar Indention level for output
769 :     #
770 :     # Globals: None.
771 :     #
772 :     # Environment: None.
773 :     #
774 :     # Returns: Success: text
775 :     # Failure: undef
776 :     #
777 :     ###############################################################################
778 :     sub as_string
779 :     {
780 :     my $self = shift;
781 :     my $indent = shift || 0;
782 :    
783 :     my ($text, $padding, $container);
784 :    
785 :     $RPC::XML::ERROR = '';
786 :    
787 :     $text = qq(<?xml version="1.0"?>\n);
788 :     $padding = ' ' x $indent;
789 :    
790 :     $text .= "$padding<methodCall>\n";
791 :     $text .= "$padding <methodName>$self->{name}</methodName>\n";
792 :     $text .= "$padding <params>\n";
793 :     for (@{$self->{args}})
794 :     {
795 :     $text .= "$padding <param>\n";
796 :     $text .= "$padding <value>\n";
797 :     $text .= $_->as_string($indent + 4) . "\n";
798 :     $text .= "$padding </value>\n";
799 :     $text .= "$padding </param>\n";
800 :     }
801 :     $text .= "$padding </params>\n";
802 :     $text .= "$padding</methodCall>\n";
803 :    
804 :     $text;
805 :     }
806 :    
807 :     ###############################################################################
808 :     #
809 :     # Package: RPC::XML::response
810 :     #
811 :     # Description: This is the class that encapsulates the data for a RPC
812 :     # response. As above, it takes the information and maintains
813 :     # it internally until asked to stringify. Only then is the
814 :     # XML generated, encoding checked, etc. This allows for
815 :     # late-selection of <methodResponse> or <methodResponseSet>
816 :     # as above.
817 :     #
818 :     # Globals: None.
819 :     #
820 :     # Environment: None.
821 :     #
822 :     ###############################################################################
823 :     package RPC::XML::response;
824 :    
825 :     use strict;
826 :     use vars qw(@ISA);
827 :    
828 :     ###############################################################################
829 :     #
830 :     # Sub Name: new
831 :     #
832 :     # Description: Creating a new response object, in this (reference) case,
833 :     # means checking the outgoing parameter(s) for sanity.
834 :     #
835 :     # Arguments: NAME IN/OUT TYPE DESCRIPTION
836 :     # $class in scalar Class/ref to bless into
837 :     # @argz in list The exact disposition of the
838 :     # arguments is based on the
839 :     # type of the various elements
840 :     #
841 :     # Globals: None.
842 :     #
843 :     # Environment: None.
844 :     #
845 :     # Returns: Success: object ref
846 :     # Failure: undef, error in $RPC::XML::ERROR
847 :     #
848 :     ###############################################################################
849 :     sub new
850 :     {
851 :     my $class = shift;
852 :     my @argz = @_;
853 :    
854 :     my ($self, %extra, %attr);
855 :    
856 :     $class = ref($class) || $class;
857 :    
858 :     $RPC::XML::ERROR = '';
859 :     if (! @argz)
860 :     {
861 :     $RPC::XML::ERROR = 'RPC::XML::response::new: One of a datatype ' .
862 :     'value or a fault object must be specified';
863 :     }
864 :     elsif (UNIVERSAL::isa($argz[0], 'RPC::XML::response'))
865 :     {
866 :     # This will be a clone-op
867 :     }
868 :     elsif (@argz > 1)
869 :     {
870 :     $RPC::XML::ERROR = 'RPC::XML::response::new: Responses may take ' .
871 :     'only one argument';
872 :     }
873 :     else
874 :     {
875 :     $argz[0] = RPC::XML::smart_encode($argz[0]);
876 :    
877 :     $self = { value => $argz[0] };
878 :     bless $self, $class;
879 :     }
880 :    
881 :     $self;
882 :     }
883 :    
884 :     # Accessor/status methods
885 :     sub value { shift->{value} }
886 :     sub is_fault { ($_[0]->{value}->isa('RPC::XML::fault')) ? 1 : 0 }
887 :    
888 :     ###############################################################################
889 :     #
890 :     # Sub Name: as_string
891 :     #
892 :     # Description: This is a fair bit more complex than the simple as_string
893 :     # methods for the datatypes. Express the invoking object as
894 :     # a well-formed XML document.
895 :     #
896 :     # Arguments: NAME IN/OUT TYPE DESCRIPTION
897 :     # $self in ref Invoking object
898 :     # $indent in scalar Indention level for output
899 :     #
900 :     # Globals: None.
901 :     #
902 :     # Environment: None.
903 :     #
904 :     # Returns: Success: text
905 :     # Failure: undef
906 :     #
907 :     ###############################################################################
908 :     sub as_string
909 :     {
910 :     my $self = shift;
911 :     my $indent = shift || 0;
912 :    
913 :     my ($text, $padding);
914 :    
915 :     $RPC::XML::ERROR = '';
916 :    
917 :     $text = qq(<?xml version="1.0"?>\n);
918 :     $padding = ' ' x $indent;
919 :    
920 :     $text .= "$padding<methodResponse>\n";
921 :     if ($self->{value}->isa('RPC::XML::fault'))
922 :     {
923 :     $text .= $self->{value}->as_string($indent + 1) . "\n";
924 :     }
925 :     else
926 :     {
927 :     $text .= "$padding <params>\n";
928 :     $text .= "$padding <param>\n";
929 :     $text .= "$padding <value>\n";
930 :     $text .= $self->{value}->as_string($indent + 4) . "\n";
931 :     $text .= "$padding </value>\n";
932 :     $text .= "$padding </param>\n";
933 :     $text .= "$padding </params>\n";
934 :     }
935 :     $text .= "$padding</methodResponse>\n";
936 :    
937 :     $text;
938 :     }
939 :    
940 :    
941 :     __END__
942 :    
943 :     =head1 NAME
944 :    
945 :     RPC::XML - A set of classes for core data, message and XML handling
946 :    
947 :     =head1 SYNOPSIS
948 :    
949 :     use RPC::XML;
950 :    
951 :     $req = new RPC::XML::request ('fetch_prime_factors',
952 :     RPC::XML::int->new(985120528));
953 :     ...
954 :     $resp = RPC::XML::Parser->new()->parse(STREAM);
955 :     if (ref($resp))
956 :     {
957 :     return $resp->value->value;
958 :     }
959 :     else
960 :     {
961 :     die $resp;
962 :     }
963 :    
964 :     =head1 DESCRIPTION
965 :    
966 :     The B<RPC::XML> package is a reference implementation of the XML-RPC
967 :     standard. As a reference implementation, it is geared more towards clarity and
968 :     readability than efficiency.
969 :    
970 :     The package provides a set of classes for creating values to pass to the
971 :     constructors for requests and responses. These are lightweight objects, most
972 :     of which are implemented as tied scalars so as to associate specific type
973 :     information with the value. Classes are also provided for requests, responses,
974 :     faults (errors) and a parser based on the L<XML::Parser> package from CPAN.
975 :    
976 :     This module does not actually provide any transport implementation or
977 :     server basis. For these, see L<RPC::XML::Client> and L<RPC::XML::Server>,
978 :     respectively.
979 :    
980 :     =head1 EXPORTABLE FUNCTIONS
981 :    
982 :     At present, only two functions are available for import. They must be
983 :     explicitly imported as part of the C<use> statement, or with a direct call to
984 :     C<import>:
985 :    
986 :     =over 4
987 :    
988 :     =item time2iso8601($time)
989 :    
990 :     Convert the integer time value in C<$time> to a ISO 8601 string in the UTC
991 :     time zone. This is a convenience function for occassions when the return value
992 :     needs to be of the B<dateTime.iso8601> type, but the value on hand is the
993 :     return from the C<time> built-in.
994 :    
995 :     =item smart_encode(@args)
996 :    
997 :     Converts the passed-in arguments to datatype objects. Any that are already
998 :     encoded as such are passed through unchanged. The routine is called recursively
999 :     on hash and array references. Note that this routine can only deduce a certain
1000 :     degree of detail about the values passed. Boolean values will be wrongly
1001 :     encoded as integers. Pretty much anything not specifically recognizable will
1002 :     get encoded as a string object. Thus, for types such as C<fault>, the ISO
1003 :     time value, base-64 data, etc., the program must still explicitly encode it.
1004 :     However, this routine will hopefully simplify things a little bit for a
1005 :     majority of the usage cases.
1006 :    
1007 :     =back
1008 :    
1009 :     =head1 CLASSES
1010 :    
1011 :     The classes provided by this module are broken into two groups: I<datatype>
1012 :     classes and I<message> classes.
1013 :    
1014 :     =head2 Data Classes
1015 :    
1016 :     The following data classes are provided by this library. Each of these provide
1017 :     at least C<new>, C<value> and C<as_string> methods. Note that these classes
1018 :     are designed to create throw-away objects. There is currently no mechanism for
1019 :     changing the value stored within one of these object after the constructor
1020 :     returns. It is assumed that a new object would be created, instead.
1021 :    
1022 :     The C<new> methods are constructors, C<value> returns the value stored within
1023 :     the object (processed recursively for arrays and structs), and C<as_string>
1024 :     stringifies the object as a chunk of XML with relative indention for
1025 :     clarity. The C<as_string> method takes as its first argument a numeric
1026 :     indention level, which is applied as a base indention for output. Other
1027 :     arguments are specified with the classes.
1028 :    
1029 :     =over 4
1030 :    
1031 :     =item RPC::XML::int
1032 :    
1033 :     Creates an integer value. Constructor expects the integer value as an
1034 :     argument.
1035 :    
1036 :     =item RPC::XML::i4
1037 :    
1038 :     This is like the C<int> class.
1039 :    
1040 :     =item RPC::XML::double
1041 :    
1042 :     Creates a floating-point value.
1043 :    
1044 :     =item RPC::XML::string
1045 :    
1046 :     Creates an arbitrary string. No special encoding is done to the string (aside
1047 :     from XML document encoding, covered later) with the exception of the C<E<lt>>,
1048 :     C<E<gt>> and C<&> characters, which are XML-escaped during object creation,
1049 :     and then reverted when the C<value> method is called.
1050 :    
1051 :     =item RPC::XML::boolean
1052 :    
1053 :     Creates a boolean value. The value returned will always be either of B<1>
1054 :     or B<0>, for true or false, respectively. When calling the constructor, the
1055 :     program may specify any of: C<0>, C<no>, C<false>, C<1>, C<yes>, C<true>.
1056 :    
1057 :     =item RPC::XML::datetime_iso8601
1058 :    
1059 :     Creates an instance of the XML-RPC C<dateTime.iso8601> type. The specification
1060 :     for ISO 8601 may be found elsewhere. No processing is done to the data.
1061 :    
1062 :     =item RPC::XML::base64
1063 :    
1064 :     Creates an object that encapsulates a chunk of data that will be treated as
1065 :     base-64 for transport purposes. The value may be passed in as either a string
1066 :     or as a scalar reference. Additionally, a second (optional) parameter may be
1067 :     passed, that if true identifies the data as already base-64 encoded. If so,
1068 :     the data is decoded before storage. The C<value> method returns decoded data,
1069 :     and the C<as_string> method encodes it before stringification.
1070 :    
1071 :     =item RPC::XML::array
1072 :    
1073 :     Creates an array object. The constructor takes zero or more data-type
1074 :     instances as arguments, which are inserted into the array in the order
1075 :     specified. C<value> returns an array reference of native Perl types. If a
1076 :     non-null value is passed as an argument to C<value()>, then the array
1077 :     reference will contain the datatype objects (a shallow copy rather than a deep
1078 :     one).
1079 :    
1080 :     =item RPC::XML::struct
1081 :    
1082 :     Creates a struct object, the analogy of a hash table in Perl. The keys are
1083 :     ordinary strings, and the values must all be data-type objects. The C<value>
1084 :     method returns a hash table reference, with native Perl types in the values.
1085 :     Key order is not preserved. Key strings are not encoded for special XML
1086 :     characters, so the use of such (C<E<lt>>, C<E<gt>>, etc.) is discouraged. If a
1087 :     non-null value is passed as an argument to C<value()>, then the hash
1088 :     reference will contain the datatype objects (a shallow copy rather than a deep
1089 :     one).
1090 :    
1091 :     =item RPC::XML::fault
1092 :    
1093 :     A fault object is a special case of the struct object that checks to ensure
1094 :     that there are two keys, C<faultCode> and C<faultString>.
1095 :    
1096 :     As a matter of convenience, since the contents of a B<RPC::XML::fault>
1097 :     structure are specifically defined, the constructor may be called with exactly
1098 :     two arguments, the first of which will be taken as the code, and the second
1099 :     as the string. They will be converted to RPC::XML types automatically and
1100 :     stored by the pre-defined key names.
1101 :    
1102 :     =back
1103 :    
1104 :     =head2 Message Classes
1105 :    
1106 :     The message classes are used both for constructing messages for outgoing
1107 :     communication as well as representing the parsed contents of a received
1108 :     message. Both implement the following methods:
1109 :    
1110 :     =over 4
1111 :    
1112 :     =item new
1113 :    
1114 :     This is the constructor method for the two message classes. The response class
1115 :     may have only a single value (as a response is currently limited to a single
1116 :     return value), and requests may have as many arguments as appropriate. In both
1117 :     cases, the arguments are passed to the exported C<smart_encode> routine
1118 :     described earlier.
1119 :    
1120 :     =item as_string([INDENT])
1121 :    
1122 :     Returns the message object expressed as an XML document. The optional indent
1123 :     parameter causes the body to be indented that many steps (each step is two
1124 :     spaces).
1125 :    
1126 :     =back
1127 :    
1128 :     The two message-object classes are:
1129 :    
1130 :     =over 4
1131 :    
1132 :     =item RPC::XML::request
1133 :    
1134 :     This creates a request object. A request object expects the first argument to
1135 :     be the name of the remote routine being called, and all remaining arguments
1136 :     are the arguments to that routine. Request objects have the following methods
1137 :     (besides C<new> and C<as_string>):
1138 :    
1139 :     =over 4
1140 :    
1141 :     =item name
1142 :    
1143 :     The name of the remote routine that the request will call.
1144 :    
1145 :     =item args
1146 :    
1147 :     Returns a list reference with the arguments that will be passed. No arguments
1148 :     will result in a reference to an empty list.
1149 :    
1150 :     =back
1151 :    
1152 :     =item RPC::XML::response
1153 :    
1154 :     The response object is much like the request object in most ways. They may
1155 :     take only one argument, as that is all the specification allows for in a
1156 :     response. Responses have the following methods (in addition to C<new> and
1157 :     C<as_string>):
1158 :    
1159 :     =over 4
1160 :    
1161 :     =item name
1162 :    
1163 :     The name of the remote method that was called. This will not be set in
1164 :     compatibility mode.
1165 :    
1166 :     =item value
1167 :    
1168 :     The value the response is returning. It will be a RPC::XML data-type.
1169 :    
1170 :     =item is_fault
1171 :    
1172 :     A boolean test whether or not the response is signalling a fault. This is
1173 :     the same as taking the C<value> method return value and testing it, but is
1174 :     provided for clarity and simplicity.
1175 :    
1176 :     =back
1177 :    
1178 :     =back
1179 :    
1180 :     =head1 DIAGNOSTICS
1181 :    
1182 :     All constructors return C<undef> upon failure, with the error message available
1183 :     in the package-global variable B<C<$RPC::XML::ERROR>>.
1184 :    
1185 :     =head1 CAVEATS
1186 :    
1187 :     As was stated at the beginning, this is a reference implementation in which
1188 :     clarity of process and readability of the code took precedence over general
1189 :     efficiency. Much, if not all, of this can be written more compactly and/or
1190 :     efficiently. However, if done that will be done in a separate module so that
1191 :     this remains legible to the casual programmer.
1192 :    
1193 :     =head1 CREDITS
1194 :    
1195 :     The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc.
1196 :     See <http://www.xmlrpc.com> for more information about the B<XML-RPC>
1197 :     specification.
1198 :    
1199 :     =head1 LICENSE
1200 :    
1201 :     This module is licensed under the terms of the Artistic License that covers
1202 :     Perl itself. See <http://language.perl.com/misc/Artistic.html> for the
1203 :     license itself.
1204 :    
1205 :     =head1 SEE ALSO
1206 :    
1207 :     L<RPC::XML::Client>, L<RPC::XML::Server>, L<RPC::XML::Parser>, L<XML::Parser>
1208 :    
1209 :     =head1 AUTHOR
1210 :    
1211 :     Randy J. Ray <rjray@blackperl.com>
1212 :    
1213 :     =cut

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9