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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 279 - (download) (as text) (annotate)
Fri May 17 21:44:04 2002 UTC (17 years, 6 months ago) by gage
File size: 34016 byte(s)
Experimental xmlrpc WeBWorK webservices

    1 ###############################################################################
    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