home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _413c24e6cd4a76b72104cd521c797621 < prev    next >
Encoding:
Text File  |  2004-06-01  |  10.8 KB  |  421 lines
  1. # ======================================================================
  2. #
  3. # Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
  4. # SOAP::Lite is free software; you can redistribute it
  5. # and/or modify it under the same terms as Perl itself.
  6. #
  7. # $Id: Lite.pm,v 1.10 2001/10/14 18:11:27 paulk Exp $
  8. #
  9. # ======================================================================
  10.  
  11. package XMLRPC::Lite;
  12.  
  13. use SOAP::Lite;
  14. use strict;
  15. use vars qw($VERSION);
  16. $VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/);
  17.  
  18. # ======================================================================
  19.  
  20. package XMLRPC::Constants;
  21.  
  22. BEGIN {
  23.   no strict 'refs';
  24.   for (qw(
  25.     FAULT_CLIENT FAULT_SERVER 
  26.     HTTP_ON_SUCCESS_CODE HTTP_ON_FAULT_CODE
  27.     DO_NOT_USE_XML_PARSER DO_NOT_USE_CHARSET
  28.     DO_NOT_USE_LWP_LENGTH_HACK DO_NOT_CHECK_CONTENT_TYPE
  29.   )) {
  30.     *$_ = \${'SOAP::Constants::' . $_}
  31.   }
  32.   # XML-RPC spec requires content-type to be "text/xml"
  33.   $XMLRPC::Constants::DO_NOT_USE_CHARSET = 1; 
  34. }
  35.  
  36. # ======================================================================
  37.  
  38. package XMLRPC::Data;
  39.  
  40. @XMLRPC::Data::ISA = qw(SOAP::Data);
  41.  
  42. # ======================================================================
  43.  
  44. package XMLRPC::Serializer;
  45.  
  46. @XMLRPC::Serializer::ISA = qw(SOAP::Serializer);
  47.  
  48. sub new {
  49.   my $self = shift;
  50.  
  51.   unless (ref $self) {
  52.     my $class = ref($self) || $self;
  53.     $self = $class->SUPER::new(
  54.       typelookup => {
  55.         base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'],
  56.         int    => [20, sub {$_[0] =~ /^[+-]?\d+$/}, 'as_int'],
  57.         double => [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_double'],
  58.         dateTime => [35, sub {$_[0] =~ /^\d{8}T\d\d:\d\d:\d\d$/}, 'as_dateTime'],
  59.         string => [40, sub {1}, 'as_string'],
  60.       },
  61.       attr => {},
  62.       namespaces => {},
  63.       @_,
  64.     );
  65.   }
  66.   return $self;
  67. }
  68.  
  69. sub envelope {
  70.   my $self = shift->new;
  71.   my $type = shift;
  72.  
  73.   my($body);
  74.   if ($type eq 'method' || $type eq 'response') {
  75.     my $method = shift or die "Unspecified method for XMLRPC call\n";
  76.     if ($type eq 'response') {
  77.       $body = XMLRPC::Data->name(methodResponse => \XMLRPC::Data->value(
  78.         XMLRPC::Data->type(params => [@_])
  79.       ));
  80.     } else {
  81.       $body = XMLRPC::Data->name(methodCall => \XMLRPC::Data->value(
  82.         XMLRPC::Data->type(methodName => UNIVERSAL::isa($method => 'XMLRPC::Data') ? $method->name : $method),
  83.         XMLRPC::Data->type(params => [@_])
  84.       ));
  85.     }
  86.   } elsif ($type eq 'fault') {
  87.     $body = XMLRPC::Data->name(methodResponse => 
  88.       \XMLRPC::Data->type(fault => {faultCode => $_[0], faultString => $_[1]}),
  89.     );
  90.   } else {
  91.     die "Wrong type of envelope ($type) for XMLRPC call\n";
  92.   }
  93.  
  94.   $self->xmlize($self->encode_object($body));
  95. }
  96.  
  97. sub encode_object { 
  98.   my $self = shift;
  99.   my @encoded = $self->SUPER::encode_object(@_);
  100.   return $encoded[0]->[0] =~ /^(?:array|struct|i4|int|boolean|string|double|dateTime\.iso8601|base64)$/o 
  101.     ? ['value', {}, [@encoded]] : @encoded;
  102. }
  103.  
  104. sub encode_scalar {
  105.   my $self = shift;
  106.   return ['value', {}] unless defined $_[0];
  107.   return $self->SUPER::encode_scalar(@_);
  108. }
  109.  
  110. sub encode_array {
  111.   my($self, $array) = @_;
  112.  
  113.   return ['array', {}, [
  114.     ['data', {}, [map {$self->encode_object($_)} @$array]]
  115.   ]];
  116. }
  117.  
  118. sub encode_hash {
  119.   my($self, $hash) = @_;
  120.  
  121.   return ['struct', {}, [
  122.     map {
  123.       ['member', {}, [['name', {}, $_], $self->encode_object($hash->{$_})]]
  124.     } keys %$hash
  125.   ]];
  126. }
  127.  
  128. sub as_methodName {
  129.   my $self = shift;
  130.   my($value, $name, $type, $attr) = @_;
  131.   return ['methodName', $attr, $value];
  132. }
  133.  
  134. sub as_params {
  135.   my $self = shift;
  136.   my($params, $name, $type, $attr) = @_;
  137.  
  138.   return ['params', $attr, [
  139.     map {
  140.       ['param', {}, [$self->encode_object($_)]]
  141.     } @$params
  142.   ]];
  143. }
  144.  
  145. sub as_fault {
  146.   my($self, $fault) = @_;
  147.  
  148.   return ['fault', {}, [$self->encode_object($fault)]];
  149. }
  150.  
  151. sub BEGIN {
  152.   no strict 'refs';
  153.   for my $type (qw(double i4 int)) {
  154.     my $method = 'as_' . $type;
  155.     *$method = sub {
  156.       my($self, $value) = @_;
  157.       return [$type, {}, $value];
  158.     }
  159.   }
  160. }
  161.  
  162. sub as_base64 {
  163.   my $self = shift;
  164.   my $value = shift;
  165.   require MIME::Base64;
  166.   return ['base64', {}, MIME::Base64::encode_base64($value,'')];
  167. }
  168.  
  169. sub as_string {
  170.   my $self = shift;
  171.   my $value = shift;
  172.   return ['string', {}, SOAP::Utils::encode_data($value)];
  173. }
  174.  
  175. sub as_dateTime {
  176.   my $self = shift;
  177.   my $value = shift;
  178.   return ['dateTime.iso8601', {}, $value];
  179. }
  180.  
  181. sub as_boolean {
  182.   my $self = shift;
  183.   my $value = shift;
  184.   return ['boolean', {}, $value ? 1 : 0];
  185. }
  186.  
  187. sub typecast {
  188.   my $self = shift;
  189.   my($value, $name, $type, $attr) = @_;
  190.  
  191.   die "Wrong/unsupported datatype '$type' specified\n" if defined $type;
  192.  
  193.   $self->SUPER::typecast(@_);
  194. }
  195.  
  196. # ======================================================================
  197.  
  198. package XMLRPC::SOM;
  199.  
  200. @XMLRPC::SOM::ISA = qw(SOAP::SOM);
  201.  
  202. sub BEGIN {
  203.   no strict 'refs';
  204.   my %path = (
  205.     root  => '/',
  206.     envelope => '/[1]',
  207.     method => '/methodCall/methodName',
  208.     fault => '/methodResponse/fault',
  209.   );
  210.   for my $method (keys %path) {
  211.     *$method = sub { 
  212.       my $self = shift;
  213.       ref $self or return $path{$method};
  214.       Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
  215.       $self->valueof($path{$method});
  216.     };
  217.   }
  218.   my %fault = (
  219.     faultcode => 'faultCode',
  220.     faultstring => 'faultString',
  221.   );
  222.   for my $method (keys %fault) {
  223.     *$method = sub { 
  224.       my $self = shift;
  225.       ref $self or Carp::croak "Method '$method' doesn't have shortcut";
  226.       Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
  227.       defined $self->fault ? $self->fault->{$fault{$method}} : undef;
  228.     };
  229.   }
  230.   my %results = (
  231.     result    => '/methodResponse/params/[1]',
  232.     paramsin  => '/methodCall/params/param',
  233.     paramsall => '/methodResponse/params/param',
  234.   );
  235.   for my $method (keys %results) {
  236.     *$method = sub { 
  237.       my $self = shift;
  238.       ref $self or return $results{$method};
  239.       Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
  240.       defined $self->fault ? undef : $self->valueof($results{$method});
  241.     };
  242.   }
  243. }
  244.  
  245. # ======================================================================
  246.  
  247. package XMLRPC::Deserializer;
  248.  
  249. @XMLRPC::Deserializer::ISA = qw(SOAP::Deserializer);
  250.  
  251. BEGIN {
  252.   no strict 'refs';
  253.   for my $method (qw(o_child o_qname o_chars)) { # import from SOAP::Utils
  254.     *$method = \&{'SOAP::Utils::'.$method};
  255.   }
  256. }
  257.  
  258. sub deserialize {
  259.   bless shift->SUPER::deserialize(@_) => 'XMLRPC::SOM';
  260. }
  261.  
  262. sub decode_value {
  263.   my $self = shift;
  264.   my $ref = shift;
  265.   my($name, $attrs, $children, $value) = @$ref;
  266.  
  267.   if ($name eq 'value') {
  268.     $children ? scalar(($self->decode_object($children->[0]))[1]) : $value;
  269.   } elsif ($name eq 'array') {
  270.     return [map {scalar(($self->decode_object($_))[1])} @{o_child($children->[0]) || []}];
  271.   } elsif ($name eq 'struct') { 
  272.     return {map {
  273.       my %hash = map {o_qname($_) => $_} @{o_child($_) || []};
  274.                          # v----- scalar is required here, because 5.005 evaluates 'undef' in list context as empty array
  275.       (o_chars($hash{name}) => scalar(($self->decode_object($hash{value}))[1]));
  276.     } @{$children || []}};
  277.   } elsif ($name eq 'base64') {
  278.     require MIME::Base64; 
  279.     MIME::Base64::decode_base64($value);
  280.   } elsif ($name =~ /^(?:int|i4|boolean|string|double|dateTime\.iso8601|methodName)$/) {
  281.     return $value;
  282.   } elsif ($name =~ /^(?:params)$/) {
  283.     return [map {scalar(($self->decode_object($_))[1])} @{$children || []}];
  284.   } elsif ($name =~ /^(?:methodResponse|methodCall)$/) {
  285.     return +{map {$self->decode_object($_)} @{$children || []}};
  286.   } elsif ($name =~ /^(?:param|fault)$/) {
  287.     return scalar(($self->decode_object($children->[0]))[1]);
  288.   } else {
  289.     die "wrong element '$name'\n";
  290.   }
  291. }
  292.  
  293. # ======================================================================
  294.  
  295. package XMLRPC::Server;
  296.  
  297. @XMLRPC::Server::ISA = qw(SOAP::Server);
  298.  
  299. sub initialize {
  300.   return (
  301.     deserializer => XMLRPC::Deserializer->new,
  302.     serializer => XMLRPC::Serializer->new,
  303.     on_action => sub {},
  304.     on_dispatch => sub { return map {s!\.!/!g; $_} shift->method =~ /^(?:(.*)\.)?(\w+)$/ },
  305.   );
  306. }
  307.  
  308. # ======================================================================
  309.  
  310. package XMLRPC::Server::Parameters;
  311.  
  312. @XMLRPC::Server::Parameters::ISA = qw(SOAP::Server::Parameters);
  313.  
  314. # ======================================================================
  315.  
  316. package XMLRPC;
  317.  
  318. @XMLRPC::ISA = qw(SOAP);
  319.  
  320. # ======================================================================
  321.  
  322. package XMLRPC::Lite;
  323.  
  324. @XMLRPC::Lite::ISA = qw(SOAP::Lite);
  325.  
  326. sub new {
  327.   my $self = shift;
  328.  
  329.   unless (ref $self) {
  330.     my $class = ref($self) || $self;
  331.     $self = $class->SUPER::new(
  332.       serializer => XMLRPC::Serializer->new,
  333.       deserializer => XMLRPC::Deserializer->new,
  334.       on_action => sub {return},
  335.       uri => 'http://unspecified/',
  336.       @_
  337.     );
  338.   }
  339.   return $self;
  340. }
  341.  
  342. # ======================================================================
  343.  
  344. 1;
  345.  
  346. __END__
  347.  
  348. =head1 NAME
  349.  
  350. XMLRPC::Lite - client and server implementation of XML-RPC protocol 
  351.  
  352. =head1 SYNOPSIS
  353.  
  354. =over 4
  355.  
  356. =item Client
  357.  
  358.   use XMLRPC::Lite;
  359.   print XMLRPC::Lite
  360.       -> proxy('http://betty.userland.com/RPC2')
  361.       -> call('examples.getStateStruct', {state1 => 12, state2 => 28})
  362.       -> result;
  363.  
  364. =item CGI server
  365.  
  366.   use XMLRPC::Transport::HTTP;
  367.  
  368.   my $server = XMLRPC::Transport::HTTP::CGI
  369.     -> dispatch_to('methodName')
  370.     -> handle
  371.   ;
  372.  
  373. =item Daemon server
  374.  
  375.   use XMLRPC::Transport::HTTP;
  376.  
  377.   my $daemon = XMLRPC::Transport::HTTP::Daemon
  378.     -> new (LocalPort => 80)
  379.     -> dispatch_to('methodName')
  380.   ;
  381.   print "Contact to XMLRPC server at ", $daemon->url, "\n";
  382.   $daemon->handle;
  383.  
  384. =back
  385.  
  386. =head1 DESCRIPTION
  387.  
  388. XMLRPC::Lite is a Perl modules which provides a simple nterface to the
  389. XML-RPC protocol both on client and server side. Based on SOAP::Lite module,
  390. it gives you access to all features and transports available in that module.
  391.  
  392. See F<t/26-xmlrpc.t> for client examples and F<examples/XMLRPC/*> for server 
  393. implementations.
  394.  
  395. =head1 DEPENDENCIES
  396.  
  397.  SOAP::Lite
  398.  
  399. =head1 SEE ALSO
  400.  
  401.  SOAP::Lite
  402.  
  403. =head1 CREDITS
  404.  
  405. The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc.
  406. See <http://www.xmlrpc.com> for more information about the B<XML-RPC> 
  407. specification.
  408.  
  409. =head1 COPYRIGHT
  410.  
  411. Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
  412.  
  413. This library is free software; you can redistribute it and/or modify
  414. it under the same terms as Perl itself.
  415.  
  416. =head1 AUTHOR
  417.  
  418. Paul Kulchenko (paulclinger@yahoo.com)
  419.  
  420. =cut
  421.