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