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