1# ====================================================================== 2# 3# Copyright (C) 2000-2005 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 416 2012-07-15 09:35:17Z kutterma $ 8# 9# ====================================================================== 10 11# Formatting hint: 12# Target is the source code format laid out in Perl Best Practices (4 spaces 13# indent, opening brace on condition line, no cuddled else). 14# 15# October 2007, Martin Kutter 16 17package SOAP::Lite; 18 19use 5.006; #weak references require perl 5.6 20use strict; 21our $VERSION = 0.715; 22# ====================================================================== 23 24package SOAP::XMLSchemaApacheSOAP::Deserializer; 25 26sub as_map { 27 my $self = shift; 28 return { 29 map { 30 my $hash = ($self->decode_object($_))[1]; 31 ($hash->{key} => $hash->{value}) 32 } @{$_[3] || []} 33 }; 34} 35sub as_Map; *as_Map = \&as_map; 36 37# Thank to Kenneth Draper for this contribution 38sub as_vector { 39 my $self = shift; 40 return [ map { scalar(($self->decode_object($_))[1]) } @{$_[3] || []} ]; 41} 42sub as_Vector; *as_Vector = \&as_vector; 43 44# ---------------------------------------------------------------------- 45 46package SOAP::XMLSchema::Serializer; 47 48use vars qw(@ISA); 49 50sub xmlschemaclass { 51 my $self = shift; 52 return $ISA[0] unless @_; 53 @ISA = (shift); 54 return $self; 55} 56 57# ---------------------------------------------------------------------- 58 59package SOAP::XMLSchema1999::Serializer; 60 61use vars qw(@EXPORT $AUTOLOAD); 62 63sub AUTOLOAD { 64 local($1,$2); 65 my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/; 66 return if $method eq 'DESTROY'; 67 no strict 'refs'; 68 69 my $export_var = $package . '::EXPORT'; 70 my @export = @$export_var; 71 72# Removed in 0.69 - this is a total hack. For some reason this is failing 73# despite not being a fatal error condition. 74# die "Type '$method' can't be found in a schema class '$package'\n" 75# unless $method =~ s/^as_// && grep {$_ eq $method} @{$export_var}; 76 77# This was added in its place - it is still a hack, but it performs the 78# necessary substitution. It just does not die. 79 if ($method =~ s/^as_// && grep {$_ eq $method} @{$export_var}) { 80# print STDERR "method is now '$method'\n"; 81 } else { 82 return; 83 } 84 85 $method =~ s/_/-/; # fix ur-type 86 87 *$AUTOLOAD = sub { 88 my $self = shift; 89 my($value, $name, $type, $attr) = @_; 90 return [$name, {'xsi:type' => "xsd:$method", %$attr}, $value]; 91 }; 92 goto &$AUTOLOAD; 93} 94 95BEGIN { 96 @EXPORT = qw(ur_type 97 float double decimal timeDuration recurringDuration uriReference 98 integer nonPositiveInteger negativeInteger long int short byte 99 nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte 100 positiveInteger timeInstant time timePeriod date month year century 101 recurringDate recurringDay language 102 base64 hex string boolean 103 ); 104 # TODO: replace by symbol table operations... 105 # predeclare subs, so ->can check will be positive 106 foreach (@EXPORT) { eval "sub as_$_" } 107} 108 109sub nilValue { 'null' } 110 111sub anyTypeValue { 'ur-type' } 112 113sub as_base64 { 114 my ($self, $value, $name, $type, $attr) = @_; 115 116 # Fixes #30271 for 5.8 and above. 117 # Won't fix for 5.6 and below - perl can't handle unicode before 118 # 5.8, and applying pack() to everything is just a slowdown. 119 if (eval "require Encode; 1") { 120 if (Encode::is_utf8($value)) { 121 if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions. 122 Encode::_utf8_off($value); 123 } 124 else { 125 $value = pack('C*',unpack('C*',$value)); # the slow but safe way, 126 # but this fallback works always. 127 } 128 } 129 } 130 131 require MIME::Base64; 132 return [ 133 $name, 134 { 135 'xsi:type' => SOAP::Utils::qualify($self->encprefix => 'base64'), 136 %$attr 137 }, 138 MIME::Base64::encode_base64($value,'') 139 ]; 140} 141 142sub as_hex { 143 my ($self, $value, $name, $type, $attr) = @_; 144 return [ 145 $name, 146 { 147 'xsi:type' => 'xsd:hex', %$attr 148 }, 149 join '', map { 150 uc sprintf "%02x", ord 151 } split '', $value 152 ]; 153} 154 155sub as_long { 156 my($self, $value, $name, $type, $attr) = @_; 157 return [ 158 $name, 159 {'xsi:type' => 'xsd:long', %$attr}, 160 $value 161 ]; 162} 163 164sub as_dateTime { 165 my ($self, $value, $name, $type, $attr) = @_; 166 return [$name, {'xsi:type' => 'xsd:dateTime', %$attr}, $value]; 167} 168 169sub as_string { 170 my ($self, $value, $name, $type, $attr) = @_; 171 die "String value expected instead of @{[ref $value]} reference\n" 172 if ref $value; 173 return [ 174 $name, 175 {'xsi:type' => 'xsd:string', %$attr}, 176 SOAP::Utils::encode_data($value) 177 ]; 178} 179 180sub as_anyURI { 181 my($self, $value, $name, $type, $attr) = @_; 182 die "String value expected instead of @{[ref $value]} reference\n" if ref $value; 183 return [ 184 $name, 185 {'xsi:type' => 'xsd:anyURI', %$attr}, 186 SOAP::Utils::encode_data($value) 187 ]; 188} 189 190sub as_undef { $_[1] ? '1' : '0' } 191 192sub as_boolean { 193 my $self = shift; 194 my($value, $name, $type, $attr) = @_; 195 # fix [ 1204279 ] Boolean serialization error 196 return [ 197 $name, 198 {'xsi:type' => 'xsd:boolean', %$attr}, 199 ( $value && $value ne 'false' ) ? 'true' : 'false' 200 ]; 201} 202 203sub as_float { 204 my($self, $value, $name, $type, $attr) = @_; 205 return [ 206 $name, 207 {'xsi:type' => 'xsd:float', %$attr}, 208 $value 209 ]; 210} 211 212# ---------------------------------------------------------------------- 213 214package SOAP::XMLSchema2001::Serializer; 215 216use vars qw(@EXPORT); 217 218# no more warnings about "used only once" 219*AUTOLOAD if 0; 220 221*AUTOLOAD = \&SOAP::XMLSchema1999::Serializer::AUTOLOAD; 222 223BEGIN { 224 @EXPORT = qw(anyType anySimpleType float double decimal dateTime 225 timePeriod gMonth gYearMonth gYear century 226 gMonthDay gDay duration recurringDuration anyURI 227 language integer nonPositiveInteger negativeInteger 228 long int short byte nonNegativeInteger unsignedLong 229 unsignedInt unsignedShort unsignedByte positiveInteger 230 date time string hex base64 boolean 231 QName 232 ); 233 # Add QName to @EXPORT 234 # predeclare subs, so ->can check will be positive 235 foreach (@EXPORT) { eval "sub as_$_" } 236} 237 238sub nilValue { 'nil' } 239 240sub anyTypeValue { 'anyType' } 241 242sub as_long; *as_long = \&SOAP::XMLSchema1999::Serializer::as_long; 243sub as_float; *as_float = \&SOAP::XMLSchema1999::Serializer::as_float; 244sub as_string; *as_string = \&SOAP::XMLSchema1999::Serializer::as_string; 245sub as_anyURI; *as_anyURI = \&SOAP::XMLSchema1999::Serializer::as_anyURI; 246 247# TODO - QNames still don't work for 2001 schema! 248sub as_QName; *as_QName = \&SOAP::XMLSchema1999::Serializer::as_string; 249sub as_hex; *as_hex = \&as_hexBinary; 250sub as_base64; *as_base64 = \&as_base64Binary; 251sub as_timeInstant; *as_timeInstant = \&as_dateTime; 252 253# only 0 and 1 allowed - that's easy... 254sub as_undef { 255 $_[1] 256 ? 'true' 257 : 'false' 258} 259 260sub as_hexBinary { 261 my ($self, $value, $name, $type, $attr) = @_; 262 return [ 263 $name, 264 {'xsi:type' => 'xsd:hexBinary', %$attr}, 265 join '', map { 266 uc sprintf "%02x", ord 267 } split '', $value 268 ]; 269} 270 271sub as_base64Binary { 272 my ($self, $value, $name, $type, $attr) = @_; 273 274 # Fixes #30271 for 5.8 and above. 275 # Won't fix for 5.6 and below - perl can't handle unicode before 276 # 5.8, and applying pack() to everything is just a slowdown. 277 if (eval "require Encode; 1") { 278 if (Encode::is_utf8($value)) { 279 if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions. 280 Encode::_utf8_off($value); 281 } 282 else { 283 $value = pack('C*',unpack('C*',$value)); # the slow but safe way, 284 # but this fallback works always. 285 } 286 } 287 } 288 289 require MIME::Base64; 290 return [ 291 $name, 292 { 293 'xsi:type' => 'xsd:base64Binary', %$attr 294 }, 295 MIME::Base64::encode_base64($value,'') 296 ]; 297} 298 299sub as_boolean { 300 my ($self, $value, $name, $type, $attr) = @_; 301 # fix [ 1204279 ] Boolean serialization error 302 return [ 303 $name, 304 { 305 'xsi:type' => 'xsd:boolean', %$attr 306 }, 307 ( $value && ($value ne 'false') ) 308 ? 'true' 309 : 'false' 310 ]; 311} 312 313 314# ====================================================================== 315 316package SOAP::Utils; 317 318sub qualify { 319 $_[1] 320 ? $_[1] =~ /:/ 321 ? $_[1] 322 : join(':', $_[0] || (), $_[1]) 323 : defined $_[1] 324 ? $_[0] 325 : '' 326 } 327 328sub overqualify (&$) { 329 for ($_[1]) { 330 &{$_[0]}; 331 s/^:|:$//g 332 } 333} 334 335sub disqualify { 336 (my $qname = shift) =~ s/^($SOAP::Constants::NSMASK?)://; 337 return $qname; 338} 339 340sub splitqname { 341 local($1,$2); 342 $_[0] =~ /^(?:([^:]+):)?(.+)$/; 343 return ($1,$2) 344} 345 346sub longname { 347 defined $_[0] 348 ? sprintf('{%s}%s', $_[0], $_[1]) 349 : $_[1] 350} 351 352sub splitlongname { 353 local($1,$2); 354 $_[0] =~ /^(?:\{(.*)\})?(.+)$/; 355 return ($1,$2) 356} 357 358# Q: why only '&' and '<' are encoded, but not '>'? 359# A: because it is not required according to XML spec. 360# 361# [http://www.w3.org/TR/REC-xml#syntax] 362# The ampersand character (&) and the left angle bracket (<) may appear in 363# their literal form only when used as markup delimiters, or within a comment, 364# a processing instruction, or a CDATA section. If they are needed elsewhere, 365# they must be escaped using either numeric character references or the 366# strings "&" and "<" respectively. The right angle bracket (>) may be 367# represented using the string ">", and must, for compatibility, be 368# escaped using ">" or a character reference when it appears in the 369# string "]]>" in content, when that string is not marking the end of a 370# CDATA section. 371 372my %encode_attribute = ('&' => '&', '>' => '>', '<' => '<', '"' => '"'); 373sub encode_attribute { (my $e = $_[0]) =~ s/([&<>\"])/$encode_attribute{$1}/g; $e } 374 375my %encode_data = ('&' => '&', '>' => '>', '<' => '<', "\xd" => '
'); 376sub encode_data { 377 my $e = $_[0]; 378 if ($e) { 379 $e =~ s/([&<>\015])/$encode_data{$1}/g; 380 $e =~ s/\]\]>/\]\]>/g; 381 } 382 $e 383} 384 385# methods for internal tree (SOAP::Deserializer, SOAP::SOM and SOAP::Serializer) 386 387sub o_qname { $_[0]->[0] } 388sub o_attr { $_[0]->[1] } 389sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef } 390sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] } 391 # $_[0]->[3] is not used. Serializer stores object ID there 392sub o_value { $_[0]->[4] } 393sub o_lname { $_[0]->[5] } 394sub o_lattr { $_[0]->[6] } 395 396sub format_datetime { 397 my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5]; 398 my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s); 399 return $time; 400} 401 402# make bytelength that calculates length in bytes regardless of utf/byte settings 403# either we can do 'use bytes' or length will count bytes already 404BEGIN { 405 sub bytelength; 406 *bytelength = eval('use bytes; 1') # 5.6.0 and later? 407 ? sub { use bytes; length(@_ ? $_[0] : $_) } 408 : sub { length(@_ ? $_[0] : $_) }; 409} 410 411# ====================================================================== 412 413package SOAP::Cloneable; 414 415sub clone { 416 my $self = shift; 417 418 return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__); 419 420 my $clone = bless {} => ref($self) || $self; 421 for (keys %$self) { 422 my $value = $self->{$_}; 423 $clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value; 424 } 425 return $clone; 426} 427 428# ====================================================================== 429 430package SOAP::Transport; 431 432use vars qw($AUTOLOAD @ISA); 433@ISA = qw(SOAP::Cloneable); 434 435use Class::Inspector; 436 437 438sub DESTROY { SOAP::Trace::objects('()') } 439 440sub new { 441 my $self = shift; 442 return $self if ref $self; 443 my $class = ref($self) || $self; 444 445 SOAP::Trace::objects('()'); 446 return bless {} => $class; 447} 448 449sub proxy { 450 my $self = shift; 451 $self = $self->new() if not ref $self; 452 453 my $class = ref $self; 454 455 return $self->{_proxy} unless @_; 456 457 $_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n"; 458 my $protocol = uc "$1"; # untainted now 459 460 # HTTPS is handled by HTTP class 461 $protocol =~s/^HTTPS$/HTTP/; 462 463 (my $protocol_class = "${class}::$protocol") =~ s/-/_/g; 464 465 no strict 'refs'; 466 unless (Class::Inspector->loaded("$protocol_class\::Client") 467 && UNIVERSAL::can("$protocol_class\::Client" => 'new') 468 ) { 469 eval "require $protocol_class"; 470 die "Unsupported protocol '$protocol'\n" 471 if $@ =~ m!^Can\'t locate SOAP/Transport/!; 472 die if $@; 473 } 474 475 $protocol_class .= "::Client"; 476 return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_); 477} 478 479sub AUTOLOAD { 480 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); 481 return if $method eq 'DESTROY'; 482 483 no strict 'refs'; 484 *$AUTOLOAD = sub { shift->proxy->$method(@_) }; 485 goto &$AUTOLOAD; 486} 487 488# ====================================================================== 489 490package SOAP::Fault; 491 492use Carp (); 493 494use overload fallback => 1, '""' => "stringify"; 495 496sub DESTROY { SOAP::Trace::objects('()') } 497 498sub new { 499 my $self = shift; 500 501 unless (ref $self) { 502 my $class = $self; 503 $self = bless {} => $class; 504 SOAP::Trace::objects('()'); 505 } 506 507 Carp::carp "Odd (wrong?) number of parameters in new()" 508 if $^W && (@_ & 1); 509 510 no strict qw(refs); 511 while (@_) { 512 my $method = shift; 513 $self->$method(shift) 514 if $self->can($method) 515 } 516 517 return $self; 518} 519 520sub stringify { 521 my $self = shift; 522 return join ': ', $self->faultcode, $self->faultstring; 523} 524 525sub BEGIN { 526 no strict 'refs'; 527 for my $method (qw(faultcode faultstring faultactor faultdetail)) { 528 my $field = '_' . $method; 529 *$method = sub { 530 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) 531 ? shift->new 532 : __PACKAGE__->new; 533 if (@_) { 534 $self->{$field} = shift; 535 return $self 536 } 537 return $self->{$field}; 538 } 539 } 540 *detail = \&faultdetail; 541} 542 543# ====================================================================== 544 545package SOAP::Data; 546 547use vars qw(@ISA @EXPORT_OK); 548use Exporter; 549use Carp (); 550use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2; 551 552@ISA = qw(Exporter); 553@EXPORT_OK = qw(name type attr value uri); 554 555sub DESTROY { SOAP::Trace::objects('()') } 556 557sub new { 558 my $self = shift; 559 560 unless (ref $self) { 561 my $class = $self; 562 $self = bless {_attr => {}, _value => [], _signature => []} => $class; 563 SOAP::Trace::objects('()'); 564 } 565 no strict qw(refs); 566 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 567 while (@_) { 568 my $method = shift; 569 $self->$method(shift) if $self->can($method) 570 } 571 572 return $self; 573} 574 575sub name { 576 my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new; 577 if (@_) { 578 my $name = shift; 579 my ($uri, $prefix); # predeclare, because can't declare in assign 580 if ($name) { 581 ($uri, $name) = SOAP::Utils::splitlongname($name); 582 unless (defined $uri) { 583 ($prefix, $name) = SOAP::Utils::splitqname($name); 584 $self->prefix($prefix) if defined $prefix; 585 } else { 586 $self->uri($uri); 587 } 588 } 589 $self->{_name} = $name; 590 591 $self->value(@_) if @_; 592 return $self; 593 } 594 return $self->{_name}; 595} 596 597sub attr { 598 my $self = ref $_[0] 599 ? shift 600 : UNIVERSAL::isa($_[0] => __PACKAGE__) 601 ? shift->new() 602 : __PACKAGE__->new(); 603 if (@_) { 604 $self->{_attr} = shift; 605 return $self->value(@_) if @_; 606 return $self 607 } 608 return $self->{_attr}; 609} 610 611sub type { 612 my $self = ref $_[0] 613 ? shift 614 : UNIVERSAL::isa($_[0] => __PACKAGE__) 615 ? shift->new() 616 : __PACKAGE__->new(); 617 if (@_) { 618 $self->{_type} = shift; 619 $self->value(@_) if @_; 620 return $self; 621 } 622 if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) { 623 $self->{_type} = (SOAP::Utils::splitlongname(delete $self->{_attr}->{shift(@types)}))[1]; 624 } 625 return $self->{_type}; 626} 627 628BEGIN { 629 no strict 'refs'; 630 for my $method (qw(root mustUnderstand)) { 631 my $field = '_' . $method; 632 *$method = sub { 633 my $attr = $method eq 'root' 634 ? "{$SOAP::Constants::NS_ENC}$method" 635 : "{$SOAP::Constants::NS_ENV}$method"; 636 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) 637 ? shift->new 638 : __PACKAGE__->new; 639 if (@_) { 640 $self->{_attr}->{$attr} = $self->{$field} = shift() ? 1 : 0; 641 $self->value(@_) if @_; 642 return $self; 643 } 644 $self->{$field} = SOAP::Lite::Deserializer::XMLSchemaSOAP1_2->as_boolean($self->{_attr}->{$attr}) 645 if !defined $self->{$field} && defined $self->{_attr}->{$attr}; 646 return $self->{$field}; 647 } 648 } 649 650 for my $method (qw(actor encodingStyle)) { 651 my $field = '_' . $method; 652 *$method = sub { 653 my $attr = "{$SOAP::Constants::NS_ENV}$method"; 654 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) 655 ? shift->new() 656 : __PACKAGE__->new(); 657 if (@_) { 658 $self->{_attr}->{$attr} = $self->{$field} = shift; 659 $self->value(@_) if @_; 660 return $self; 661 } 662 $self->{$field} = $self->{_attr}->{$attr} 663 if !defined $self->{$field} && defined $self->{_attr}->{$attr}; 664 return $self->{$field}; 665 } 666 } 667} 668 669sub prefix { 670 my $self = ref $_[0] 671 ? shift 672 : UNIVERSAL::isa($_[0] => __PACKAGE__) 673 ? shift->new() 674 : __PACKAGE__->new(); 675 return $self->{_prefix} unless @_; 676 $self->{_prefix} = shift; 677 if (scalar @_) { 678 return $self->value(@_); 679 } 680 return $self; 681} 682 683sub uri { 684 my $self = ref $_[0] 685 ? shift 686 : UNIVERSAL::isa($_[0] => __PACKAGE__) 687 ? shift->new() 688 : __PACKAGE__->new(); 689 return $self->{_uri} unless @_; 690 my $uri = $self->{_uri} = shift; 691 warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n" 692 if defined $uri && $^W && $uri =~ /::/; 693 if (scalar @_) { 694 return $self->value(@_); 695 } 696 return $self; 697} 698 699sub set_value { 700 my $self = ref $_[0] 701 ? shift 702 : UNIVERSAL::isa($_[0] => __PACKAGE__) 703 ? shift->new() 704 : __PACKAGE__->new(); 705 $self->{_value} = [@_]; 706 return $self; 707} 708 709sub value { 710 my $self = ref $_[0] ? shift 711 : UNIVERSAL::isa($_[0] => __PACKAGE__) 712 ? shift->new() 713 : __PACKAGE__->new; 714 if (@_) { 715 return $self->set_value(@_); 716 } 717 else { 718 return wantarray 719 ? @{$self->{_value}} 720 : $self->{_value}->[0]; 721 } 722} 723 724sub signature { 725 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) 726 ? shift->new() 727 : __PACKAGE__->new(); 728 (@_) 729 ? ($self->{_signature} = shift, return $self) 730 : (return $self->{_signature}); 731} 732 733# ====================================================================== 734 735package SOAP::Header; 736 737use vars qw(@ISA); 738@ISA = qw(SOAP::Data); 739 740# ====================================================================== 741 742package SOAP::Serializer; 743use SOAP::Lite::Utils; 744use Carp (); 745use vars qw(@ISA); 746 747@ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer); 748 749BEGIN { 750 # namespaces and anonymous data structures 751 my $ns = 0; 752 my $name = 0; 753 my $prefix = 'c-'; 754 sub gen_ns { 'namesp' . ++$ns } 755 sub gen_name { join '', $prefix, 'gensym', ++$name } 756 sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; } 757} 758 759sub BEGIN { 760 no strict 'refs'; 761 762 __PACKAGE__->__mk_accessors(qw(readable level seen autotype attr maptype 763 namespaces multirefinplace encoding signature on_nonserialized context 764 ns_uri ns_prefix use_default_ns)); 765 766 for my $method (qw(method fault freeform)) { # aliases for envelope 767 *$method = sub { shift->envelope($method => @_) } 768 } 769 770 # Is this necessary? Seems like work for nothing when a user could just use 771 # SOAP::Utils directly. 772 # for my $method (qw(qualify overqualify disqualify)) { # import from SOAP::Utils 773 # *$method = \&{'SOAP::Utils::'.$method}; 774 # } 775} 776 777sub DESTROY { SOAP::Trace::objects('()') } 778 779sub new { 780 my $self = shift; 781 return $self if ref $self; 782 783 my $class = $self; 784 $self = bless { 785 _level => 0, 786 _autotype => 1, 787 _readable => 0, 788 _ns_uri => '', 789 _ns_prefix => '', 790 _use_default_ns => 1, 791 _multirefinplace => 0, 792 _seen => {}, 793 _encoding => 'UTF-8', 794 _objectstack => {}, 795 _signature => [], 796 _maptype => {}, 797 _on_nonserialized => sub {Carp::carp "Cannot marshall @{[ref shift]} reference" if $^W; return}, 798 _encodingStyle => $SOAP::Constants::NS_ENC, 799 _attr => { 800 "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC, 801 }, 802 _namespaces => {}, 803 _soapversion => SOAP::Lite->soapversion, 804 } => $class; 805 $self->typelookup({ 806 'base64Binary' => 807 [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/ }, 'as_base64Binary'], 808 'zerostring' => 809 [12, sub { $_[0] =~ /^0\d+$/ }, 'as_string'], 810 # int (and actually long too) are subtle: the negative range is one greater... 811 'int' => 812 [20, sub {$_[0] =~ /^([+-]?\d+)$/ && ($1 <= 2147483647) && ($1 >= -2147483648); }, 'as_int'], 813 'long' => 814 [25, sub {$_[0] =~ /^([+-]?\d+)$/ && $1 <= 9223372036854775807;}, 'as_long'], 815 'float' => 816 [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+|NaN|INF)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_float'], 817 'gMonth' => 818 [35, sub { $_[0] =~ /^--\d\d--(-\d\d:\d\d)?$/; }, 'as_gMonth'], 819 'gDay' => 820 [40, sub { $_[0] =~ /^---\d\d(-\d\d:\d\d)?$/; }, 'as_gDay'], 821 'gYear' => 822 [45, sub { $_[0] =~ /^-?\d\d\d\d(-\d\d:\d\d)?$/; }, 'as_gYear'], 823 'gMonthDay' => 824 [50, sub { $_[0] =~ /^-\d\d-\d\d(-\d\d:\d\d)?$/; }, 'as_gMonthDay'], 825 'gYearMonth' => 826 [55, sub { $_[0] =~ /^-?\d\d\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_gYearMonth'], 827 'date' => 828 [60, sub { $_[0] =~ /^-?\d\d\d\d-\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_date'], 829 'time' => 830 [70, sub { $_[0] =~ /^\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_time'], 831 'dateTime' => 832 [75, sub { $_[0] =~ /^\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_dateTime'], 833 'duration' => 834 [80, sub { $_[0] !~m{^-?PT?$} && $_[0] =~ m{^ 835 -? # a optional - sign 836 P 837 (:? \d+Y )? 838 (:? \d+M )? 839 (:? \d+D )? 840 (:? 841 T(:?\d+H)? 842 (:?\d+M)? 843 (:?\d+S)? 844 )? 845 $ 846 }x; 847 }, 'as_duration'], 848 'boolean' => 849 [90, sub { $_[0] =~ /^(true|false)$/i; }, 'as_boolean'], 850 'anyURI' => 851 [95, sub { $_[0] =~ /^(urn:|http:\/\/)/i; }, 'as_anyURI'], 852 'string' => 853 [100, sub {1}, 'as_string'], 854 }); 855 $self->register_ns($SOAP::Constants::NS_ENC,$SOAP::Constants::PREFIX_ENC); 856 $self->register_ns($SOAP::Constants::NS_ENV,$SOAP::Constants::PREFIX_ENV) 857 if $SOAP::Constants::PREFIX_ENV; 858 $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA); 859 SOAP::Trace::objects('()'); 860 861 no strict qw(refs); 862 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 863 while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) } 864 865 return $self; 866} 867 868sub typelookup { 869 my ($self, $lookup) = @_; 870 if (defined $lookup) { 871 $self->{ _typelookup } = $lookup; 872 $self->{ _typelookup_order } = [ sort { $lookup->{$a}->[0] <=> $lookup->{$b}->[0] } keys %{ $lookup } ]; 873 return $self; 874 } 875 return $self->{ _typelookup }; 876} 877 878sub ns { 879 my $self = shift; 880 $self = $self->new() if not ref $self; 881 if (@_) { 882 my ($u,$p) = @_; 883 my $prefix; 884 885 if ($p) { 886 $prefix = $p; 887 } 888 elsif (!$p && !($prefix = $self->find_prefix($u))) { 889 $prefix = gen_ns; 890 } 891 892 $self->{'_ns_uri'} = $u; 893 $self->{'_ns_prefix'} = $prefix; 894 $self->{'_use_default_ns'} = 0; 895 # $self->register_ns($u,$prefix); 896 $self->{'_namespaces'}->{$u} = $prefix; 897 return $self; 898 } 899 return $self->{'_ns_uri'}; 900} 901 902sub default_ns { 903 my $self = shift; 904 $self = $self->new() if not ref $self; 905 if (@_) { 906 my ($u) = @_; 907 $self->{'_ns_uri'} = $u; 908 $self->{'_ns_prefix'} = ''; 909 $self->{'_use_default_ns'} = 1; 910 return $self; 911 } 912 return $self->{'_ns_uri'}; 913} 914 915sub use_prefix { 916 my $self = shift; 917 $self = $self->new() if not ref $self; 918 warn 'use_prefix has been deprecated. if you wish to turn off or on the ' 919 . 'use of a default namespace, then please use either ns(uri) or default_ns(uri)'; 920 if (@_) { 921 my $use = shift; 922 $self->{'_use_default_ns'} = !$use || 0; 923 return $self; 924 } else { 925 return $self->{'_use_default_ns'}; 926 } 927} 928sub uri { 929 my $self = shift; 930 $self = $self->new() if not ref $self; 931# warn 'uri has been deprecated. if you wish to set the namespace for the request, then please use either ns(uri) or default_ns(uri)'; 932 if (@_) { 933 my $ns = shift; 934 if ($self->{_use_default_ns}) { 935 $self->default_ns($ns); 936 } 937 else { 938 $self->ns($ns); 939 } 940# $self->{'_ns_uri'} = $ns; 941# $self->register_ns($self->{'_ns_uri'}) if (!$self->{_use_default_ns}); 942 return $self; 943 } 944 return $self->{'_ns_uri'}; 945} 946 947sub encodingStyle { 948 my $self = shift; 949 $self = $self->new() if not ref $self; 950 return $self->{'_encodingStyle'} unless @_; 951 952 my $cur_style = $self->{'_encodingStyle'}; 953 delete($self->{'_namespaces'}->{$cur_style}); 954 955 my $new_style = shift; 956 if ($new_style eq "") { 957 delete($self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"}); 958 } 959 else { 960 $self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"} = $new_style; 961 $self->{'_namespaces'}->{$new_style} = $SOAP::Constants::PREFIX_ENC; 962 } 963} 964 965# TODO - changing SOAP version can affect previously set encodingStyle 966sub soapversion { 967 my $self = shift; 968 return $self->{_soapversion} unless @_; 969 return $self if $self->{_soapversion} eq SOAP::Lite->soapversion; 970 $self->{_soapversion} = shift; 971 972 $self->attr({ 973 "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC, 974 }); 975 $self->namespaces({ 976 $SOAP::Constants::NS_ENC => $SOAP::Constants::PREFIX_ENC, 977 $SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (), 978 }); 979 $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA); 980 981 return $self; 982} 983 984sub xmlschema { 985 my $self = shift->new; 986 return $self->{_xmlschema} unless @_; 987 988 my @schema; 989 if ($_[0]) { 990 @schema = grep {/XMLSchema/ && /$_[0]/} keys %SOAP::Constants::XML_SCHEMAS; 991 Carp::croak "More than one schema match parameter '$_[0]': @{[join ', ', @schema]}" if @schema > 1; 992 Carp::croak "No schema match parameter '$_[0]'" if @schema != 1; 993 } 994 995 # do nothing if current schema is the same as new 996 # return $self if $self->{_xmlschema} && $self->{_xmlschema} eq $schema[0]; 997 998 my $ns = $self->namespaces; 999 # delete current schema from namespaces 1000 if (my $schema = $self->{_xmlschema}) { 1001 delete $ns->{$schema}; 1002 delete $ns->{"$schema-instance"}; 1003 } 1004 1005 # add new schema into namespaces 1006 if (my $schema = $self->{_xmlschema} = shift @schema) { 1007 $ns->{$schema} = 'xsd'; 1008 $ns->{"$schema-instance"} = 'xsi'; 1009 } 1010 1011 # and here is the class serializer should work with 1012 my $class = exists $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} 1013 ? $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} . '::Serializer' 1014 : $self; 1015 1016 $self->xmlschemaclass($class); 1017 1018 return $self; 1019} 1020 1021sub envprefix { 1022 my $self = shift->new(); 1023 return $self->namespaces->{$SOAP::Constants::NS_ENV} unless @_; 1024 $self->namespaces->{$SOAP::Constants::NS_ENV} = shift; 1025 return $self; 1026} 1027 1028sub encprefix { 1029 my $self = shift->new(); 1030 return $self->namespaces->{$SOAP::Constants::NS_ENC} unless @_; 1031 $self->namespaces->{$SOAP::Constants::NS_ENC} = shift; 1032 return $self; 1033} 1034 1035sub gen_id { sprintf "%U", $_[1] } 1036 1037sub multiref_object { 1038 my ($self, $object) = @_; 1039 my $id = $self->gen_id($object); 1040 if (! exists $self->{ _seen }->{ $id }) { 1041 $self->{ _seen }->{ $id } = { 1042 count => 1, 1043 multiref => 0, 1044 value => $object, 1045 recursive => 0 1046 }; 1047 } 1048 else { 1049 my $id_seen = $self->{ _seen }->{ $id }; 1050 $id_seen->{count}++; 1051 $id_seen->{multiref} = 1; 1052 $id_seen->{value} = $object; 1053 $id_seen->{recursive} ||= 0; 1054 } 1055 return $id; 1056} 1057 1058sub recursive_object { 1059 my $self = shift; 1060 $self->seen->{$self->gen_id(shift)}->{recursive} = 1; 1061} 1062 1063sub is_href { 1064 my $self = shift; 1065 my $seen = $self->seen->{shift || return} or return; 1066 return 1 if $seen->{id}; 1067 return $seen->{multiref} 1068 && !($seen->{id} = (shift 1069 || $seen->{recursive} 1070 || $seen->{multiref} && $self->multirefinplace)); 1071} 1072 1073sub multiref_anchor { 1074 my ($self, $id) = @_; 1075 no warnings qw(uninitialized); 1076 if ($self->{ _seen }->{ $id }->{multiref}) { 1077 return "ref-$id" 1078 } 1079 else { 1080 return undef; 1081 } 1082} 1083 1084sub encode_multirefs { 1085 my $self = shift; 1086 return if $self->multirefinplace(); 1087 1088 my $seen = $self->{ _seen }; 1089 map { $_->[1]->{_id} = 1; $_ } 1090 map { $self->encode_object($seen->{$_}->{value}) } 1091 grep { $seen->{$_}->{multiref} && !$seen->{$_}->{recursive} } 1092 keys %$seen; 1093} 1094 1095sub maptypetouri { 1096 my($self, $type, $simple) = @_; 1097 1098 return $type unless defined $type; 1099 my($prefix, $name) = SOAP::Utils::splitqname($type); 1100 1101 unless (defined $prefix) { 1102 $name =~ s/__|\./::/g; 1103 $self->maptype->{$name} = $simple 1104 ? die "Schema/namespace for type '$type' is not specified\n" 1105 : $SOAP::Constants::NS_SL_PERLTYPE 1106 unless exists $self->maptype->{$name}; 1107 $type = $self->maptype->{$name} 1108 ? SOAP::Utils::qualify($self->namespaces->{$self->maptype->{$name}} ||= gen_ns, $type) 1109 : undef; 1110 } 1111 return $type; 1112} 1113 1114sub encode_object { 1115 my($self, $object, $name, $type, $attr) = @_; 1116 1117 $attr ||= {}; 1118 return $self->encode_scalar($object, $name, $type, $attr) 1119 unless ref $object; 1120 1121 my $id = $self->multiref_object($object); 1122 1123 use vars '%objectstack'; # we'll play with symbol table 1124 local %objectstack = %objectstack; # want to see objects ONLY in the current tree 1125 1126 # did we see this object in current tree? Seems to be recursive refs 1127 # same as call to $self->recursive_object($object) - but 1128 # recursive_object($object) has to re-compute the object's id 1129 if (++$objectstack{ $id } > 1) { 1130 $self->{ _seen }->{ $id }->{recursive} = 1 1131 } 1132 1133 # return if we already saw it twice. It should be already properly serialized 1134 return if $objectstack{$id} > 2; 1135 1136 if (UNIVERSAL::isa($object => 'SOAP::Data')) { 1137 # use $object->SOAP::Data:: to enable overriding name() and others in inherited classes 1138 $object->SOAP::Data::name($name) 1139 unless defined $object->SOAP::Data::name; 1140 1141 # apply ->uri() and ->prefix() which can modify name and attributes of 1142 # element, but do not modify SOAP::Data itself 1143 my($name, $attr) = $self->fixattrs($object); 1144 $attr = $self->attrstoqname($attr); 1145 1146 my @realvalues = $object->SOAP::Data::value; 1147 return [$name || gen_name, $attr] unless @realvalues; 1148 1149 my $method = "as_" . ($object->SOAP::Data::type || '-'); # dummy type if not defined 1150 # try to call method specified for this type 1151 no strict qw(refs); 1152 my @values = map { 1153 # store null/nil attribute if value is undef 1154 local $attr->{SOAP::Utils::qualify(xsi => $self->xmlschemaclass->nilValue)} = $self->xmlschemaclass->as_undef(1) 1155 unless defined; 1156 $self->can($method) && $self->$method($_, $name || gen_name, $object->SOAP::Data::type, $attr) 1157 || $self->typecast($_, $name || gen_name, $object->SOAP::Data::type, $attr) 1158 || $self->encode_object($_, $name, $object->SOAP::Data::type, $attr) 1159 } @realvalues; 1160 $object->SOAP::Data::signature([map {join $;, $_->[0], SOAP::Utils::disqualify($_->[1]->{'xsi:type'} || '')} @values]) if @values; 1161 return wantarray ? @values : $values[0]; 1162 } 1163 1164 my $class = ref $object; 1165 1166 if ($class !~ /^(?:SCALAR|ARRAY|HASH|REF)$/o) { 1167 # we could also check for CODE|GLOB|LVALUE, but we cannot serialize 1168 # them anyway, so they'll be cought by check below 1169 $class =~ s/::/__/g; 1170 1171 $name = $class if !defined $name; 1172 $type = $class if !defined $type && $self->autotype; 1173 1174 my $method = 'as_' . $class; 1175 if ($self->can($method)) { 1176 no strict qw(refs); 1177 my $encoded = $self->$method($object, $name, $type, $attr); 1178 return $encoded if ref $encoded; 1179 # return only if handled, otherwise handle with default handlers 1180 } 1181 } 1182 1183 if (UNIVERSAL::isa($object => 'REF') || UNIVERSAL::isa($object => 'SCALAR')) { 1184 return $self->encode_scalar($object, $name, $type, $attr); 1185 } 1186 elsif (UNIVERSAL::isa($object => 'ARRAY')) { 1187 # Added in SOAP::Lite 0.65_6 to fix an XMLRPC bug 1188 return $self->encodingStyle eq "" 1189 || $self->isa('XMLRPC::Serializer') 1190 ? $self->encode_array($object, $name, $type, $attr) 1191 : $self->encode_literal_array($object, $name, $type, $attr); 1192 } 1193 elsif (UNIVERSAL::isa($object => 'HASH')) { 1194 return $self->encode_hash($object, $name, $type, $attr); 1195 } 1196 else { 1197 return $self->on_nonserialized->($object); 1198 } 1199} 1200 1201sub encode_scalar { 1202 my($self, $value, $name, $type, $attr) = @_; 1203 $name ||= gen_name; 1204 1205 my $schemaclass = $self->xmlschemaclass; 1206 1207 # null reference 1208 return [$name, {%$attr, SOAP::Utils::qualify(xsi => $schemaclass->nilValue) => $schemaclass->as_undef(1)}] unless defined $value; 1209 1210 # object reference 1211 return [$name, {'xsi:type' => $self->maptypetouri($type), %$attr}, [$self->encode_object($$value)], $self->gen_id($value)] if ref $value; 1212 1213 # autodefined type 1214 if ($self->{ _autotype}) { 1215 my $lookup = $self->{_typelookup}; 1216 no strict qw(refs); 1217 #for (sort {$lookup->{$a}->[0] <=> $lookup->{$b}->[0]} keys %$lookup) { 1218 for (@{ $self->{ _typelookup_order } }) { 1219 my $method = $lookup->{$_}->[2]; 1220 return $self->can($method) && $self->$method($value, $name, $type, $attr) 1221 || $method->($value, $name, $type, $attr) 1222 if $lookup->{$_}->[1]->($value); 1223 } 1224 } 1225 1226 # invariant 1227 return [$name, $attr, $value]; 1228} 1229 1230sub encode_array { 1231 my ($self, $array, $name, $type, $attr) = @_; 1232 my $items = 'item'; 1233 1234 # If typing is disabled, just serialize each of the array items 1235 # with no type information, each using the specified name, 1236 # and do not crete a wrapper array tag. 1237 if (!$self->autotype) { 1238 $name ||= gen_name; 1239 return map {$self->encode_object($_, $name)} @$array; 1240 } 1241 1242 # TODO: add support for multidimensional, partially transmitted and sparse arrays 1243 my @items = map {$self->encode_object($_, $items)} @$array; 1244 my $num = @items; 1245 my($arraytype, %types) = '-'; 1246 for (@items) { $arraytype = $_->[1]->{'xsi:type'} || '-'; $types{$arraytype}++ } 1247 $arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue) : $arraytype; 1248 1249 # $type = SOAP::Utils::qualify($self->encprefix => 'Array') if $self->autotype && !defined $type; 1250 $type = qualify($self->encprefix => 'Array') if !defined $type; 1251 return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'), 1252 { 1253 SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype, 1254 'xsi:type' => $self->maptypetouri($type), %$attr 1255 }, 1256 [@items], 1257 $self->gen_id($array) 1258 ]; 1259} 1260 1261# Will encode arrays using doc-literal style 1262sub encode_literal_array { 1263 my($self, $array, $name, $type, $attr) = @_; 1264 1265 if ($self->autotype) { 1266 my $items = 'item'; 1267 1268 # TODO: add support for multidimensional, partially transmitted and sparse arrays 1269 my @items = map {$self->encode_object($_, $items)} @$array; 1270 1271 1272 my $num = @items; 1273 my($arraytype, %types) = '-'; 1274 for (@items) { 1275 $arraytype = $_->[1]->{'xsi:type'} || '-'; 1276 $types{$arraytype}++ 1277 } 1278 $arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' 1279 ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue) 1280 : $arraytype; 1281 1282 $type = SOAP::Utils::qualify($self->encprefix => 'Array') 1283 if !defined $type; 1284 1285 return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'), 1286 { 1287 SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype, 1288 'xsi:type' => $self->maptypetouri($type), %$attr 1289 }, 1290 [ @items ], 1291 $self->gen_id($array) 1292 ]; 1293 } 1294 else { 1295 # 1296 # literal arrays are different - { array => [ 5,6 ] } 1297 # results in <array>5</array><array>6</array> 1298 # This means that if there's a literal inside the array (not a 1299 # reference), we have to encode it this way. If there's only 1300 # nested tags, encode as 1301 # <array><foo>1</foo><foo>2</foo></array> 1302 # 1303 1304 my $literal = undef; 1305 my @items = map { 1306 ref $_ 1307 ? $self->encode_object($_) 1308 : do { 1309 $literal++; 1310 $_ 1311 } 1312 1313 } @$array; 1314 1315 if ($literal) { 1316 return map { [ $name , $attr , $_, $self->gen_id($array) ] } @items; 1317 } 1318 else { 1319 return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'), 1320 $attr, 1321 [ @items ], 1322 $self->gen_id($array) 1323 ]; 1324 } 1325 } 1326} 1327 1328sub encode_hash { 1329 my($self, $hash, $name, $type, $attr) = @_; 1330 1331 if ($self->autotype && grep {!/$SOAP::Constants::ELMASK/o} keys %$hash) { 1332 warn qq!Cannot encode @{[$name ? "'$name'" : 'unnamed']} element as 'hash'. Will be encoded as 'map' instead\n! if $^W; 1333 return $self->as_map($hash, $name || gen_name, $type, $attr); 1334 } 1335 1336 $type = 'SOAPStruct' 1337 if $self->autotype && !defined($type) && exists $self->maptype->{SOAPStruct}; 1338 return [$name || gen_name, 1339 $self->autotype ? {'xsi:type' => $self->maptypetouri($type), %$attr} : { %$attr }, 1340 [map {$self->encode_object($hash->{$_}, $_)} keys %$hash], 1341 $self->gen_id($hash) 1342 ]; 1343} 1344 1345sub as_ordered_hash { 1346 my ($self, $value, $name, $type, $attr) = @_; 1347 die "Not an ARRAY reference for 'ordered_hash' type" unless UNIVERSAL::isa($value => 'ARRAY'); 1348 return [ $name, $attr, 1349 [map{$self->encode_object(@{$value}[2*$_+1,2*$_])} 0..$#$value/2 ], 1350 $self->gen_id($value) 1351 ]; 1352} 1353 1354sub as_map { 1355 my ($self, $value, $name, $type, $attr) = @_; 1356 die "Not a HASH reference for 'map' type" unless UNIVERSAL::isa($value => 'HASH'); 1357 my $prefix = ($self->namespaces->{$SOAP::Constants::NS_APS} ||= 'apachens'); 1358 my @items = map { 1359 $self->encode_object( 1360 SOAP::Data->type( 1361 ordered_hash => [ 1362 key => $_, 1363 value => $value->{$_} 1364 ] 1365 ), 1366 'item', 1367 '' 1368 )} keys %$value; 1369 return [ 1370 $name, 1371 {'xsi:type' => "$prefix:Map", %$attr}, 1372 [@items], 1373 $self->gen_id($value) 1374 ]; 1375} 1376 1377sub as_xml { 1378 my $self = shift; 1379 my($value, $name, $type, $attr) = @_; 1380 return [$name, {'_xml' => 1}, $value]; 1381} 1382 1383sub typecast { 1384 my $self = shift; 1385 my($value, $name, $type, $attr) = @_; 1386 return if ref $value; # skip complex object, caller knows how to deal with it 1387 return if $self->autotype && !defined $type; # we don't know, autotype knows 1388 return [$name, 1389 {(defined $type && $type gt '' ? ('xsi:type' => $self->maptypetouri($type, 'simple type')) : ()), %$attr}, 1390 $value 1391 ]; 1392} 1393 1394sub register_ns { 1395 my $self = shift->new(); 1396 my ($ns,$prefix) = @_; 1397 $prefix = gen_ns if !$prefix; 1398 $self->{'_namespaces'}->{$ns} = $prefix if $ns; 1399} 1400 1401sub find_prefix { 1402 my ($self, $ns) = @_; 1403 return (exists $self->{'_namespaces'}->{$ns}) 1404 ? $self->{'_namespaces'}->{$ns} 1405 : (); 1406} 1407 1408sub fixattrs { 1409 my ($self, $data) = @_; 1410 my ($name, $attr) = ($data->SOAP::Data::name, {%{$data->SOAP::Data::attr}}); 1411 my ($xmlns, $prefix) = ($data->uri, $data->prefix); 1412 unless (defined($xmlns) || defined($prefix)) { 1413 $self->register_ns($xmlns,$prefix) unless ($self->use_default_ns); 1414 return ($name, $attr); 1415 } 1416 $name ||= gen_name(); # local name 1417 $prefix = gen_ns() if !defined $prefix && $xmlns gt ''; 1418 $prefix = '' 1419 if defined $xmlns && $xmlns eq '' 1420 || defined $prefix && $prefix eq ''; 1421 1422 $attr->{join ':', xmlns => $prefix || ()} = $xmlns if defined $xmlns; 1423 $name = join ':', $prefix, $name if $prefix; 1424 1425 $self->register_ns($xmlns,$prefix) unless ($self->use_default_ns); 1426 1427 return ($name, $attr); 1428 1429} 1430 1431sub toqname { 1432 my $self = shift; 1433 my $long = shift; 1434 1435 return $long unless $long =~ /^\{(.*)\}(.+)$/; 1436 return SOAP::Utils::qualify $self->namespaces->{$1} ||= gen_ns, $2; 1437} 1438 1439sub attrstoqname { 1440 my $self = shift; 1441 my $attrs = shift; 1442 1443 return { 1444 map { /^\{(.*)\}(.+)$/ 1445 ? ($self->toqname($_) => $2 eq 'type' 1446 || $2 eq 'arrayType' 1447 ? $self->toqname($attrs->{$_}) 1448 : $attrs->{$_}) 1449 : ($_ => $attrs->{$_}) 1450 } keys %$attrs 1451 }; 1452} 1453 1454sub tag { 1455 my ($self, $tag, $attrs, @values) = @_; 1456 1457 my $readable = $self->{ _readable }; 1458 1459 my $value = join '', @values; 1460 my $indent = $readable ? ' ' x (($self->{ _level }-1)*2) : ''; 1461 1462 # check for special attribute 1463 return "$indent$value" if exists $attrs->{_xml} && delete $attrs->{_xml}; 1464 1465 die "Element '$tag' can't be allowed in valid XML message. Died." 1466 if $tag !~ /^$SOAP::Constants::NSMASK$/o; 1467 1468 warn "Element '$tag' uses the reserved prefix 'XML' (in any case)" 1469 if $tag !~ /^(?![Xx][Mm][Ll])/; 1470 1471 my $prolog = $readable ? "\n" : ""; 1472 my $epilog = $readable ? "\n" : ""; 1473 my $tagjoiner = " "; 1474 if ($self->{ _level } == 1) { 1475 my $namespaces = $self->namespaces; 1476 foreach (keys %$namespaces) { 1477 $attrs->{SOAP::Utils::qualify(xmlns => $namespaces->{$_})} = $_ 1478 } 1479 $prolog = qq!<?xml version="1.0" encoding="@{[$self->encoding]}"?>! 1480 if defined $self->encoding; 1481 $prolog .= "\n" if $readable; 1482 $tagjoiner = " \n".(' ' x 4 ) if $readable; 1483 } 1484 my $tagattrs = join($tagjoiner, '', 1485 map { sprintf '%s="%s"', $_, SOAP::Utils::encode_attribute($attrs->{$_}) } 1486 grep { $_ && defined $attrs->{$_} && ($_ ne 'xsi:type' || $attrs->{$_} ne '') } 1487 keys %$attrs); 1488 1489 if ($value gt '') { 1490 return sprintf("$prolog$indent<%s%s>%s%s</%s>$epilog",$tag,$tagattrs,$value,($value =~ /^\s*</ ? $indent : ""),$tag); 1491 } 1492 else { 1493 return sprintf("$prolog$indent<%s%s />$epilog$indent",$tag,$tagattrs); 1494 } 1495} 1496 1497sub xmlize { 1498 my $self = shift; 1499 my($name, $attrs, $values, $id) = @{$_[0]}; 1500 $attrs ||= {}; 1501 1502 local $self->{_level} = $self->{_level} + 1; 1503 1504 return $self->tag($name, $attrs) 1505 unless defined $values; 1506 1507 return $self->tag($name, $attrs, $values) 1508 unless ref $values eq "ARRAY"; 1509 1510 return $self->tag($name, {%$attrs, href => '#'.$self->multiref_anchor($id)}) 1511 if $self->is_href($id, delete($attrs->{_id})); 1512 1513 # we have seen this element as a reference 1514 if (defined $id && $self->{ _seen }->{ $id }->{ multiref}) { 1515 return $self->tag($name, 1516 { 1517 %$attrs, id => $self->multiref_anchor($id) 1518 }, 1519 map {$self->xmlize($_)} @$values 1520 ); 1521 } 1522 else { 1523 return $self->tag($name, $attrs, map {$self->xmlize($_)} @$values); 1524 } 1525} 1526 1527sub uriformethod { 1528 my $self = shift; 1529 1530 my $method_is_data = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Data'); 1531 1532 # drop prefix from method that could be string or SOAP::Data object 1533 my($prefix, $method) = $method_is_data 1534 ? ($_[0]->prefix, $_[0]->name) 1535 : SOAP::Utils::splitqname($_[0]); 1536 1537 my $attr = {reverse %{$self->namespaces}}; 1538 # try to define namespace that could be stored as 1539 # a) method is SOAP::Data 1540 # ? attribute in method's element as xmlns= or xmlns:${prefix}= 1541 # : uri 1542 # b) attribute in Envelope element as xmlns= or xmlns:${prefix}= 1543 # c) no prefix or prefix equal serializer->envprefix 1544 # ? '', but see coment below 1545 # : die with error message 1546 my $uri = $method_is_data 1547 ? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri) 1548 : $self->uri; 1549 1550 defined $uri or $uri = $attr->{$prefix || ''}; 1551 1552 defined $uri or $uri = !$prefix || $prefix eq $self->envprefix 1553 # still in doubts what should namespace be in this case 1554 # but will keep it like this for now and be compatible with our server 1555 ? ( $method_is_data 1556 && $^W 1557 && warn("URI is not provided as an attribute for method ($method)\n"), 1558 '' 1559 ) 1560 : die "Can't find namespace for method ($prefix:$method)\n"; 1561 1562 return ($uri, $method); 1563} 1564 1565sub serialize { SOAP::Trace::trace('()'); 1566 my $self = shift->new; 1567 @_ == 1 or Carp::croak "serialize() method accepts one parameter"; 1568 1569 $self->seen({}); # reinitialize multiref table 1570 my($encoded) = $self->encode_object($_[0]); 1571 1572 # now encode multirefs if any 1573 # v -------------- subelements of Envelope 1574 push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2]; 1575 return $self->xmlize($encoded); 1576} 1577 1578sub envelope { 1579 SOAP::Trace::trace('()'); 1580 my $self = shift->new; 1581 my $type = shift; 1582 my(@parameters, @header); 1583 for (@_) { 1584 # Find all the SOAP Headers 1585 if (defined($_) && ref($_) && UNIVERSAL::isa($_ => 'SOAP::Header')) { 1586 push(@header, $_); 1587 } 1588 # Find all the SOAP Message Parts (attachments) 1589 elsif (defined($_) && ref($_) && $self->context 1590 && $self->context->packager->is_supported_part($_) 1591 ) { 1592 $self->context->packager->push_part($_); 1593 } 1594 # Find all the SOAP Body elements 1595 else { 1596 # proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope 1597 push(@parameters, $_); 1598 # push (@parameters, SOAP::Utils::encode_data($_)); 1599 } 1600 } 1601 my $header = @header ? SOAP::Data->set_value(@header) : undef; 1602 my($body,$parameters); 1603 if ($type eq 'method' || $type eq 'response') { 1604 SOAP::Trace::method(@parameters); 1605 1606 my $method = shift(@parameters); 1607 # or die "Unspecified method for SOAP call\n"; 1608 1609 $parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef; 1610 if (!defined($method)) {} 1611 elsif (UNIVERSAL::isa($method => 'SOAP::Data')) { 1612 $body = $method; 1613 } 1614 elsif ($self->use_default_ns) { 1615 if ($self->{'_ns_uri'}) { 1616 $body = SOAP::Data->name($method) 1617 ->attr({'xmlns' => $self->{'_ns_uri'} } ); 1618 } 1619 else { 1620 $body = SOAP::Data->name($method); 1621 } 1622 } 1623 else { 1624 # Commented out by Byrne on 1/4/2006 - to address default namespace problems 1625 # $body = SOAP::Data->name($method)->uri($self->{'_ns_uri'}); 1626 # $body = $body->prefix($self->{'_ns_prefix'}) if ($self->{'_ns_prefix'}); 1627 1628 # Added by Byrne on 1/4/2006 - to avoid the unnecessary creation of a new 1629 # namespace 1630 # Begin New Code (replaces code commented out above) 1631 $body = SOAP::Data->name($method); 1632 my $pre = $self->find_prefix($self->{'_ns_uri'}); 1633 $body = $body->prefix($pre) if ($self->{'_ns_prefix'}); 1634 # End new code 1635 } 1636 1637 # This is breaking a unit test right now... 1638 # proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope 1639 # $body->set_value(SOAP::Utils::encode_data($parameters ? \$parameters : ())) 1640 # if $body; 1641 # must call encode_data on nothing to enforce xsi:nil="true" to be set. 1642 $body->set_value($parameters ? \$parameters : SOAP::Utils::encode_data()) if $body; 1643 } 1644 elsif ($type eq 'fault') { 1645 SOAP::Trace::fault(@parameters); 1646 # -> attr({'xmlns' => ''}) 1647 # Parameter order fixed thanks to Tom Fischer 1648 $body = SOAP::Data-> name(SOAP::Utils::qualify($self->envprefix => 'Fault')) 1649 -> value(\SOAP::Data->set_value( 1650 SOAP::Data->name(faultcode => SOAP::Utils::qualify($self->envprefix => $parameters[0]))->type(""), 1651 SOAP::Data->name(faultstring => SOAP::Utils::encode_data($parameters[1]))->type(""), 1652 defined($parameters[3]) 1653 ? SOAP::Data->name(faultactor => $parameters[3])->type("") 1654 : (), 1655 defined($parameters[2]) 1656 ? SOAP::Data->name(detail => do{ 1657 my $detail = $parameters[2]; 1658 ref $detail 1659 ? \$detail 1660 : SOAP::Utils::encode_data($detail) 1661 }) 1662 : (), 1663 )); 1664 } 1665 elsif ($type eq 'freeform') { 1666 SOAP::Trace::freeform(@parameters); 1667 $body = SOAP::Data->set_value(@parameters); 1668 } 1669 elsif (!defined($type)) { 1670 # This occurs when the Body is intended to be null. When no method has been 1671 # passed in of any kind. 1672 } 1673 else { 1674 die "Wrong type of envelope ($type) for SOAP call\n"; 1675 } 1676 1677 $self->{ _seen } = {}; # reinitialize multiref table 1678 1679 # Build the envelope 1680 # Right now it is possible for $body to be a SOAP::Data element that has not 1681 # XML escaped any values. How do you remedy this? 1682 my($encoded) = $self->encode_object( 1683 SOAP::Data->name( 1684 SOAP::Utils::qualify($self->envprefix => 'Envelope') => \SOAP::Data->value( 1685 ($header 1686 ? SOAP::Data->name( SOAP::Utils::qualify($self->envprefix => 'Header') => \$header) 1687 : () 1688 ), 1689 ($body 1690 ? SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body') => \$body) 1691 : SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body')) ), 1692 ) 1693 )->attr($self->attr) 1694 ); 1695 1696 $self->signature($parameters->signature) if ref $parameters; 1697 1698 # IMHO multirefs should be encoded after Body, but only some 1699 # toolkits understand this encoding, so we'll keep them for now (04/15/2001) 1700 # as the last element inside the Body 1701 # v -------------- subelements of Envelope 1702 # vv -------- last of them (Body) 1703 # v --- subelements 1704 push(@{$encoded->[2]->[-1]->[2]}, $self->encode_multirefs) if ref $encoded->[2]->[-1]->[2]; 1705 1706 # Sometimes SOAP::Serializer is invoked statically when there is no context. 1707 # So first check to see if a context exists. 1708 # TODO - a context needs to be initialized by a constructor? 1709 if ($self->context && $self->context->packager->parts) { 1710 # TODO - this needs to be called! Calling it though wraps the payload twice! 1711 # return $self->context->packager->package($self->xmlize($encoded)); 1712 } 1713 1714 return $self->xmlize($encoded); 1715} 1716 1717# ====================================================================== 1718 1719package SOAP::Parser; 1720 1721sub DESTROY { SOAP::Trace::objects('()') } 1722 1723sub xmlparser { 1724 my $self = shift; 1725 return eval { 1726 $SOAP::Constants::DO_NOT_USE_XML_PARSER 1727 ? undef 1728 : do { 1729 require XML::Parser; 1730 XML::Parser->new() } 1731 } 1732 || eval { require XML::Parser::Lite; XML::Parser::Lite->new } 1733 || die "XML::Parser is not @{[$SOAP::Constants::DO_NOT_USE_XML_PARSER ? 'used' : 'available']} and ", $@; 1734} 1735 1736sub parser { 1737 my $self = shift->new; 1738 @_ 1739 ? do { 1740 $self->{'_parser'} = shift; 1741 return $self; 1742 } 1743 : return ($self->{'_parser'} ||= $self->xmlparser); 1744} 1745 1746sub new { 1747 my $self = shift; 1748 return $self if ref $self; 1749 my $class = $self; 1750 SOAP::Trace::objects('()'); 1751 return bless {_parser => shift}, $class; 1752} 1753 1754sub decode { SOAP::Trace::trace('()'); 1755 my $self = shift; 1756 1757 $self->parser->setHandlers( 1758 Final => sub { shift; $self->final(@_) }, 1759 Start => sub { shift; $self->start(@_) }, 1760 End => sub { shift; $self->end(@_) }, 1761 Char => sub { shift; $self->char(@_) }, 1762 ExternEnt => sub { shift; die "External entity (pointing to '$_[1]') is not allowed" }, 1763 ); 1764 # my $parsed = $self->parser->parse($_[0]); 1765 # return $parsed; 1766 # 1767 my $ret = undef; 1768 eval { 1769 $ret = $self->parser->parse($_[0]); 1770 }; 1771 if ($@) { 1772 $self->final; # Clean up in the event of an error 1773 die $@; # Pass back the error 1774 } 1775 return $ret; 1776} 1777 1778sub final { 1779 my $self = shift; 1780 1781 # clean handlers, otherwise SOAP::Parser won't be deleted: 1782 # it refers to XML::Parser which refers to subs from SOAP::Parser 1783 # Thanks to Ryan Adams <iceman@mit.edu> 1784 # and Craig Johnston <craig.johnston@pressplay.com> 1785 # checked by number of tests in t/02-payload.t 1786 1787 undef $self->{_values}; 1788 $self->parser->setHandlers( 1789 Final => undef, 1790 Start => undef, 1791 End => undef, 1792 Char => undef, 1793 ExternEnt => undef, 1794 ); 1795 $self->{_done}; 1796} 1797 1798sub start { push @{shift->{_values}}, [shift, {@_}] } 1799 1800# string concatenation changed to arrays which should improve performance 1801# for strings with many entity-encoded elements. 1802# Thanks to Mathieu Longtin <mrdamnfrenchy@yahoo.com> 1803sub char { push @{shift->{_values}->[-1]->[3]}, shift } 1804 1805sub end { 1806 my $self = shift; 1807 my $done = pop @{$self->{_values}}; 1808 $done->[2] = defined $done->[3] 1809 ? join('',@{$done->[3]}) 1810 : '' unless ref $done->[2]; 1811 undef $done->[3]; 1812 @{$self->{_values}} 1813 ? (push @{$self->{_values}->[-1]->[2]}, $done) 1814 : ($self->{_done} = $done); 1815} 1816 1817# ====================================================================== 1818 1819package SOAP::SOM; 1820 1821use Carp (); 1822use SOAP::Lite::Utils; 1823 1824sub BEGIN { 1825 no strict 'refs'; 1826 my %path = ( 1827 root => '/', 1828 envelope => '/Envelope', 1829 body => '/Envelope/Body', 1830 header => '/Envelope/Header', 1831 headers => '/Envelope/Header/[>0]', 1832 fault => '/Envelope/Body/Fault', 1833 faultcode => '/Envelope/Body/Fault/faultcode', 1834 faultstring => '/Envelope/Body/Fault/faultstring', 1835 faultactor => '/Envelope/Body/Fault/faultactor', 1836 faultdetail => '/Envelope/Body/Fault/detail', 1837 ); 1838 for my $method (keys %path) { 1839 *$method = sub { 1840 my $self = shift; 1841 ref $self or return $path{$method}; 1842 Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; 1843 return $self->valueof($path{$method}); 1844 }; 1845 } 1846 my %results = ( 1847 method => '/Envelope/Body/[1]', 1848 result => '/Envelope/Body/[1]/[1]', 1849 freeform => '/Envelope/Body/[>0]', 1850 paramsin => '/Envelope/Body/[1]/[>0]', 1851 paramsall => '/Envelope/Body/[1]/[>0]', 1852 paramsout => '/Envelope/Body/[1]/[>1]' 1853 ); 1854 for my $method (keys %results) { 1855 *$method = sub { 1856 my $self = shift; 1857 ref $self or return $results{$method}; 1858 Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; 1859 defined $self->fault ? return : return $self->valueof($results{$method}); 1860 }; 1861 } 1862 1863 for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils 1864 *$method = \&{'SOAP::Utils::'.$method}; 1865 } 1866 1867 __PACKAGE__->__mk_accessors('context'); 1868 1869} 1870 1871# use object in boolean context return true/false on last match 1872# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success'; 1873use overload fallback => 1, 'bool' => sub { @{shift->{_current}} > 0 }; 1874 1875sub DESTROY { SOAP::Trace::objects('()') } 1876 1877sub new { 1878 my $self = shift; 1879 my $class = ref($self) || $self; 1880 my $content = shift; 1881 SOAP::Trace::objects('()'); 1882 return bless { _content => $content, _current => [$content] } => $class; 1883} 1884 1885sub parts { 1886 my $self = shift; 1887 if (@_) { 1888 $self->context->packager->parts(@_); 1889 return $self; 1890 } 1891 else { 1892 return $self->context->packager->parts; 1893 } 1894} 1895 1896sub is_multipart { 1897 my $self = shift; 1898 return defined($self->parts); 1899} 1900 1901sub current { 1902 my $self = shift; 1903 $self->{_current} = [@_], return $self if @_; 1904 return wantarray ? @{$self->{_current}} : $self->{_current}->[0]; 1905} 1906 1907sub valueof { 1908 my $self = shift; 1909 local $self->{_current} = $self->{_current}; 1910 $self->match(shift) if @_; 1911 return wantarray 1912 ? map {o_value($_)} @{$self->{_current}} 1913 : @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef; 1914} 1915 1916sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it 1917 wantarray 1918 ? map { bless $_ => 'SOAP::Header' } shift->dataof(@_) 1919 : do { # header returned by ->dataof can be undef in scalar context 1920 my $header = shift->dataof(@_); 1921 ref $header ? bless($header => 'SOAP::Header') : undef; 1922 }; 1923} 1924 1925sub dataof { 1926 my $self = shift; 1927 local $self->{_current} = $self->{_current}; 1928 $self->match(shift) if @_; 1929 return wantarray 1930 ? map {$self->_as_data($_)} @{$self->{_current}} 1931 : @{$self->{_current}} 1932 ? $self->_as_data($self->{_current}->[0]) 1933 : undef; 1934} 1935 1936sub namespaceuriof { 1937 my $self = shift; 1938 local $self->{_current} = $self->{_current}; 1939 $self->match(shift) if @_; 1940 return wantarray 1941 ? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}} 1942 : @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef; 1943} 1944 1945#sub _as_data { 1946# my $self = shift; 1947# my $pointer = shift; 1948# 1949# SOAP::Data 1950# -> new(prefix => '', name => o_qname($pointer), name => o_lname($pointer), attr => o_lattr($pointer)) 1951# -> set_value(o_value($pointer)); 1952#} 1953 1954sub _as_data { 1955 my $self = shift; 1956 my $node = shift; 1957 1958 my $data = SOAP::Data->new( prefix => '', 1959 # name => o_qname has side effect: sets namespace ! 1960 name => o_qname($node), 1961 name => o_lname($node), 1962 attr => o_lattr($node) ); 1963 1964 if ( defined o_child($node) ) { 1965 my @children; 1966 foreach my $child ( @{ o_child($node) } ) { 1967 push( @children, $self->_as_data($child) ); 1968 } 1969 $data->set_value( \SOAP::Data->value(@children) ); 1970 } 1971 else { 1972 $data->set_value( o_value($node) ); 1973 } 1974 1975 return $data; 1976} 1977 1978 1979sub match { 1980 my $self = shift; 1981 my $path = shift; 1982 $self->{_current} = [ 1983 $path =~ s!^/!! || !@{$self->{_current}} 1984 ? $self->_traverse($self->{_content}, 1 => split '/' => $path) 1985 : map {$self->_traverse_tree(o_child($_), split '/' => $path)} @{$self->{_current}} 1986 ]; 1987 return $self; 1988} 1989 1990sub _traverse { 1991 my ($self, $pointer, $itself, $path, @path) = @_; 1992 1993 die "Incorrect parameter" unless $itself =~/^\d$/; 1994 1995 if ($path && substr($path, 0, 1) eq '{') { 1996 $path = join '/', $path, shift @path while @path && $path !~ /}/; 1997 } 1998 1999 my($op, $num) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/ if defined $path; 2000 2001 return $pointer unless defined $path; 2002 2003 if (! $op) { 2004 $op = '=='; 2005 } 2006 elsif ($op eq '=' || $op eq '!') { 2007 $op .= '='; 2008 } 2009 my $numok = defined $num && eval "$itself $op $num"; 2010 my $nameok = (o_lname($pointer) || '') =~ /(?:^|\})$path$/ if defined $path; # name can be with namespace 2011 2012 my $anynode = $path eq ''; 2013 unless ($anynode) { 2014 if (@path) { 2015 return if defined $num && !$numok || !defined $num && !$nameok; 2016 } 2017 else { 2018 return $pointer if defined $num && $numok || !defined $num && $nameok; 2019 return; 2020 } 2021 } 2022 2023 my @walk; 2024 push @walk, $self->_traverse_tree([$pointer], @path) if $anynode; 2025 push @walk, $self->_traverse_tree(o_child($pointer), $anynode ? ($path, @path) : @path); 2026 return @walk; 2027} 2028 2029sub _traverse_tree { 2030 my ($self, $pointer, @path) = @_; 2031 2032 # can be list of children or value itself. Traverse only children 2033 return unless ref $pointer eq 'ARRAY'; 2034 2035 my $itself = 1; 2036 2037 grep {defined} 2038 map {$self->_traverse($_, $itself++, @path)} 2039 grep {!ref o_lattr($_) || 2040 !exists o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} || 2041 o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ne '0'} 2042 @$pointer; 2043} 2044 2045# ====================================================================== 2046 2047package SOAP::Deserializer; 2048 2049use vars qw(@ISA); 2050use SOAP::Lite::Utils; 2051use Class::Inspector; 2052 2053@ISA = qw(SOAP::Cloneable); 2054 2055sub DESTROY { SOAP::Trace::objects('()') } 2056 2057sub BEGIN { 2058 __PACKAGE__->__mk_accessors( qw(ids hrefs parts parser 2059 base xmlschemas xmlschema context) ); 2060} 2061 2062# Cache (slow) Class::Inspector results 2063my %_class_loaded=(); 2064 2065sub new { 2066 my $self = shift; 2067 return $self if ref $self; 2068 my $class = $self; 2069 SOAP::Trace::objects('()'); 2070 return bless { 2071 '_ids' => {}, 2072 '_hrefs' => {}, 2073 '_parser' => SOAP::Parser->new, 2074 '_xmlschemas' => { 2075 $SOAP::Constants::NS_APS => 'SOAP::XMLSchemaApacheSOAP::Deserializer', 2076# map { 2077# $_ => $SOAP::Constants::XML_SCHEMAS{$_} . '::Deserializer' 2078# } keys %SOAP::Constants::XML_SCHEMAS 2079 map { 2080 $_ => 'SOAP::Lite::Deserializer::' . $SOAP::Constants::XML_SCHEMA_OF{$_} 2081 } keys %SOAP::Constants::XML_SCHEMA_OF 2082 2083 }, 2084 }, $class; 2085} 2086 2087sub is_xml { 2088 # Added check for envelope delivery. Fairly standard with MMDF and sendmail 2089 # Thanks to Chris Davies <Chris.Davies@ManheimEurope.com> 2090 $_[1] =~ /^\s*</ || $_[1] !~ /^(?:[\w-]+:|From )/; 2091} 2092 2093sub baselocation { 2094 my $self = shift; 2095 my $location = shift; 2096 if ($location) { 2097 my $uri = URI->new($location); 2098 # make absolute location if relative 2099 $location = $uri->abs($self->base || 'thismessage:/')->as_string unless $uri->scheme; 2100 } 2101 return $location; 2102} 2103 2104# Returns the envelope and populates SOAP::Packager with parts 2105sub decode_parts { 2106 my $self = shift; 2107 my $env = $self->context->packager->unpackage($_[0],$self->context); 2108 my $body = $self->parser->decode($env); 2109 # TODO - This shouldn't be here! This is packager specific! 2110 # However this does need to pull out all the cid's 2111 # to populate ids hash with. 2112 foreach (@{$self->context->packager->parts}) { 2113 my $data = $_->bodyhandle->as_string; 2114 my $type = $_->head->mime_attr('Content-Type'); 2115 my $location = $_->head->mime_attr('Content-Location'); 2116 my $id = $_->head->mime_attr('Content-Id'); 2117 $location = $self->baselocation($location); 2118 my $part = lc($type) eq 'text/xml' && !$SOAP::Constants::DO_NOT_PROCESS_XML_IN_MIME 2119 ? $self->parser->decode($data) 2120 : ['mimepart', {}, $data]; 2121 # This below looks like unnecessary bloat!!! 2122 # I should probably dereference the mimepart, provide a callback to get the string data 2123 $id =~ s/^<([^>]*)>$/$1/; # string any leading and trailing brackets 2124 $self->ids->{$id} = $part if $id; 2125 $self->ids->{$location} = $part if $location; 2126 } 2127 return $body; 2128} 2129 2130# decode returns a parsed body in the form of an ARRAY 2131# each element of the ARRAY is a HASH, ARRAY or SCALAR 2132sub decode { 2133 my $self = shift->new; # this actually is important 2134 return $self->is_xml($_[0]) 2135 ? $self->parser->decode($_[0]) 2136 : $self->decode_parts($_[0]); 2137} 2138 2139# deserialize returns a SOAP::SOM object and parses straight 2140# text as input 2141sub deserialize { 2142 SOAP::Trace::trace('()'); 2143 my $self = shift->new; 2144 2145 # initialize 2146 $self->hrefs({}); 2147 $self->ids({}); 2148 2149 # If the document is XML, then ids will be empty 2150 # If the document is MIME, then ids will hold a list of cids 2151 my $parsed = $self->decode($_[0]); 2152 2153 # Having this code here makes multirefs in the Body work, but multirefs 2154 # that reference XML fragments in a MIME part do not work. 2155 if (keys %{$self->ids()}) { 2156 $self->traverse_ids($parsed); 2157 } 2158 else { 2159 # delay - set ids to be traversed later in decode_object, they only get 2160 # traversed if an href is found that is referencing an id. 2161 $self->ids($parsed); 2162 } 2163 $self->decode_object($parsed); 2164 my $som = SOAP::SOM->new($parsed); 2165 $som->context($self->context); # TODO - try removing this and see if it works! 2166 return $som; 2167} 2168 2169sub traverse_ids { 2170 my $self = shift; 2171 my $ref = shift; 2172 my($undef, $attrs, $children) = @$ref; 2173 # ^^^^^^ to fix nasty error on Mac platform (Carl K. Cunningham) 2174 $self->ids->{$attrs->{'id'}} = $ref if exists $attrs->{'id'}; 2175 return unless ref $children; 2176 for (@$children) { 2177 $self->traverse_ids($_) 2178 }; 2179} 2180 2181use constant _ATTRS => 6; 2182use constant _NAME => 5; 2183 2184sub decode_object { 2185 my $self = shift; 2186 my $ref = shift; 2187 my($name, $attrs_ref, $children, $value) = @$ref; 2188 2189 my %attrs = %{ $attrs_ref }; 2190 2191 $ref->[ _ATTRS ] = \%attrs; # make a copy for long attributes 2192 2193 use vars qw(%uris); 2194 local %uris = (%uris, map { 2195 do { (my $ns = $_) =~ s/^xmlns:?//; $ns } => delete $attrs{$_} 2196 } grep {/^xmlns(:|$)/} keys %attrs); 2197 2198 foreach (keys %attrs) { 2199 next unless m/^($SOAP::Constants::NSMASK?):($SOAP::Constants::NSMASK)$/; 2200 2201 $1 =~ /^[xX][mM][lL]/ || 2202 $uris{$1} && 2203 do { 2204 $attrs{SOAP::Utils::longname($uris{$1}, $2)} = do { 2205 my $value = $attrs{$_}; 2206 $2 ne 'type' && $2 ne 'arrayType' 2207 ? $value 2208 : SOAP::Utils::longname($value =~ m/^($SOAP::Constants::NSMASK?):(${SOAP::Constants::NSMASK}(?:\[[\d,]*\])*)/ 2209 ? ($uris{$1} || die("Unresolved prefix '$1' for attribute value '$value'\n"), $2) 2210 : ($uris{''} || die("Unspecified namespace for type '$value'\n"), $value) 2211 ); 2212 }; 2213 1; 2214 } 2215 || die "Unresolved prefix '$1' for attribute '$_'\n"; 2216 } 2217 2218 # and now check the element 2219 my $ns = ($name =~ s/^($SOAP::Constants::NSMASK?):// ? $1 : ''); 2220 $ref->[ _NAME ] = SOAP::Utils::longname( 2221 $ns 2222 ? ($uris{$ns} || die "Unresolved prefix '$ns' for element '$name'\n") 2223 : (defined $uris{''} ? $uris{''} : undef), 2224 $name 2225 ); 2226 2227 ($children, $value) = (undef, $children) unless ref $children; 2228 2229 return $name => ($ref->[4] = $self->decode_value( 2230 [$ref->[ _NAME ], \%attrs, $children, $value] 2231 )); 2232} 2233 2234sub decode_value { 2235 my $self = shift; 2236 my($name, $attrs, $children, $value) = @{ $_[0] }; 2237 2238 # check SOAP version if applicable 2239 use vars '$level'; local $level = $level || 0; 2240 if (++$level == 1) { 2241 my($namespace, $envelope) = SOAP::Utils::splitlongname($name); 2242 SOAP::Lite->soapversion($namespace) if $envelope eq 'Envelope' && $namespace; 2243 } 2244 2245 if (exists $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}) { 2246 # check encodingStyle 2247 # future versions may bind deserializer to encodingStyle 2248 my $encodingStyle = $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}; 2249 # TODO - SOAP 1.2 and 1.1 have different rules about valid encodingStyle values 2250 # For example, in 1.1 - any http://schemas.xmlsoap.org/soap/encoding/* 2251 # value is valid 2252 if (defined $encodingStyle && length($encodingStyle)) { 2253 my %styles = map { $_ => undef } @SOAP::Constants::SUPPORTED_ENCODING_STYLES; 2254 my $found = 0; 2255 foreach my $e (split(/ +/,$encodingStyle)) { 2256 if (exists $styles{$e}) { 2257 $found ++; 2258 } 2259 } 2260 die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'" 2261 if (! $found) && !(SOAP::Lite->soapversion == 1.1 && $encodingStyle =~ /(?:^|\b)$SOAP::Constants::NS_ENC/); 2262 } 2263 } 2264 use vars '$arraytype'; # type of Array element specified on Array itself 2265 # either specified with xsi:type, or <enc:name/> or array element 2266 my ($type) = grep { defined } 2267 map($attrs->{$_}, sort grep {/^\{$SOAP::Constants::NS_XSI_ALL\}type$/o} keys %$attrs), 2268 $name =~ /^\{$SOAP::Constants::NS_ENC\}/ ? $name : $arraytype; 2269 local $arraytype; # it's used only for one level, we don't need it anymore 2270 2271 # $name is not used here since type should be encoded as type, not as name 2272 my ($schema, $class) = SOAP::Utils::splitlongname($type) if $type; 2273 my $schemaclass = defined($schema) && $self->{ _xmlschemas }->{$schema} 2274 || $self; 2275 2276 if (! exists $_class_loaded{$schemaclass}) { 2277 no strict qw(refs); 2278 if (! Class::Inspector->loaded($schemaclass) ) { 2279 eval "require $schemaclass" or die $@ if not ref $schemaclass; 2280 } 2281 $_class_loaded{$schemaclass} = undef; 2282 } 2283 2284 # store schema that is used in parsed message 2285 $self->{ _xmlschema } = $schema if ($schema) && $schema =~ /XMLSchema/; 2286 2287 # don't use class/type if anyType/ur-type is specified on wire 2288 undef $class 2289 if $schemaclass->can('anyTypeValue') 2290 && $schemaclass->anyTypeValue eq $class; 2291 2292 my $method = 'as_' . ($class || '-'); # dummy type if not defined 2293 $class =~ s/__|\./::/g if $class; 2294 2295 my $id = $attrs->{id}; 2296 if (defined $id && exists $self->hrefs->{$id}) { 2297 return $self->hrefs->{$id}; 2298 } 2299 elsif (exists $attrs->{href}) { 2300 (my $id = delete $attrs->{href}) =~ s/^(#|cid:|uuid:)?//; 2301 # convert to absolute if not internal '#' or 'cid:' 2302 $id = $self->baselocation($id) unless $1; 2303 return $self->hrefs->{$id} if exists $self->hrefs->{$id}; 2304 # First time optimization. we don't traverse IDs unless asked for it. 2305 # This is where traversing id's is delayed from before 2306 # - the first time through - ids should contain a copy of the parsed XML 2307 # structure! seems silly to make so many copies 2308 my $ids = $self->ids; 2309 if (ref($ids) ne 'HASH') { 2310 $self->ids({}); # reset list of ids first time through 2311 $self->traverse_ids($ids); 2312 } 2313 if (exists($self->ids->{$id})) { 2314 my $obj = ($self->decode_object(delete($self->ids->{$id})))[1]; 2315 return $self->hrefs->{$id} = $obj; 2316 } 2317 else { 2318 die "Unresolved (wrong?) href ($id) in element '$name'\n"; 2319 } 2320 } 2321 2322 return undef if grep { 2323 /^$SOAP::Constants::NS_XSI_NILS$/ && do { 2324 my $class = $self->xmlschemas->{ $1 || $2 }; 2325 eval "require $class" or die @$;; 2326 $class->as_undef($attrs->{$_}) 2327 } 2328 } keys %$attrs; 2329 2330 # try to handle with typecasting 2331 my $res = $self->typecast($value, $name, $attrs, $children, $type); 2332 return $res if defined $res; 2333 2334 # ok, continue with others 2335 if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) { 2336 my $res = []; 2337 $self->hrefs->{$id} = $res if defined $id; 2338 2339 # check for arrayType which could be [1], [,2][5] or [] 2340 # [,][1] will NOT be allowed right now (multidimensional sparse array) 2341 my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"} 2342 =~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/ 2343 or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!; 2344 2345 my @dimensions = map { $_ || undef } split /,/, $multisize; 2346 my $size = 1; 2347 foreach (@dimensions) { $size *= $_ || 0 } 2348 2349 # TODO ähm, shouldn't this local be my? 2350 local $arraytype = $type; 2351 2352 # multidimensional 2353 if ($multisize =~ /,/) { 2354 @$res = splitarray( 2355 [@dimensions], 2356 [map { scalar(($self->decode_object($_))[1]) } @{$children || []}] 2357 ); 2358 } 2359 # normal 2360 else { 2361 @$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []}; 2362 } 2363 2364 # sparse (position) 2365 if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) { 2366 my @new; 2367 for (my $pos = 0; $pos < @$children; $pos++) { 2368 # TBD implement position in multidimensional array 2369 my($position) = SOAP::Utils::o_lattr($children->[$pos])->{"{$SOAP::Constants::NS_ENC}position"} =~ /^\[(\d+)\]$/ 2370 or die "Position must be specified for all elements of sparse array\n"; 2371 $new[$position] = $res->[$pos]; 2372 } 2373 @$res = @new; 2374 } 2375 2376 # partially transmitted (offset) 2377 # TBD implement offset in multidimensional array 2378 my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/ 2379 if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"}; 2380 unshift(@$res, (undef) x $offset) if $offset; 2381 2382 die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n" 2383 if $multisize && $size < @$res; 2384 2385 # extend the array if number of elements is specified 2386 $#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0]; 2387 2388 return defined $class && $class ne 'Array' ? bless($res => $class) : $res; 2389 2390 } 2391 elsif ($name =~ /^\{$SOAP::Constants::NS_ENC\}Struct$/ 2392 || !$schemaclass->can($method) 2393 && (ref $children || defined $class && $value =~ /^\s*$/)) { 2394 my $res = {}; 2395 $self->hrefs->{$id} = $res if defined $id; 2396 2397 # Patch code introduced in 0.65 - deserializes array properly 2398 # Decode each element of the struct. 2399 my %child_count_of = (); 2400 foreach my $child (@{$children || []}) { 2401 my ($child_name, $child_value) = $self->decode_object($child); 2402 # Store the decoded element in the struct. If the element name is 2403 # repeated, replace the previous scalar value with a new array 2404 # containing both values. 2405 if (not $child_count_of{$child_name}) { 2406 # first time to see this value: use scalar 2407 $res->{$child_name} = $child_value; 2408 } 2409 elsif ($child_count_of{$child_name} == 1) { 2410 # second time to see this value: convert scalar to array 2411 $res->{$child_name} = [ $res->{$child_name}, $child_value ]; 2412 } 2413 else { 2414 # already have an array: append to it 2415 push @{$res->{$child_name}}, $child_value; 2416 } 2417 $child_count_of{$child_name}++; 2418 } 2419 # End patch code 2420 2421 return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res; 2422 } 2423 else { 2424 my $res; 2425 if (my $method_ref = $schemaclass->can($method)) { 2426 $res = $method_ref->($self, $value, $name, $attrs, $children, $type); 2427 } 2428 else { 2429 $res = $self->typecast($value, $name, $attrs, $children, $type); 2430 $res = $class ? die "Unrecognized type '$type'\n" : $value 2431 unless defined $res; 2432 } 2433 $self->hrefs->{$id} = $res if defined $id; 2434 return $res; 2435 } 2436} 2437 2438sub splitarray { 2439 my @sizes = @{+shift}; 2440 my $size = shift @sizes; 2441 my $array = shift; 2442 2443 return splice(@$array, 0, $size) unless @sizes; 2444 my @array = (); 2445 push @array, [ 2446 splitarray([@sizes], $array) 2447 ] while @$array && (!defined $size || $size--); 2448 return @array; 2449} 2450 2451sub typecast { } # typecast is called for both objects AND scalar types 2452 # check ref of the second parameter (first is the object) 2453 # return undef if you don't want to handle it 2454 2455# ====================================================================== 2456 2457package SOAP::Client; 2458 2459 2460use SOAP::Lite::Utils; 2461 2462$VERSION = $SOAP::Lite::VERSION; 2463sub BEGIN { 2464 __PACKAGE__->__mk_accessors(qw(endpoint code message 2465 is_success status options)); 2466} 2467 2468# ====================================================================== 2469 2470package SOAP::Server::Object; 2471 2472sub gen_id; *gen_id = \&SOAP::Serializer::gen_id; 2473 2474my %alive; 2475my %objects; 2476 2477sub objects_by_reference { 2478 shift; 2479 while (@_) { 2480 @alive{shift()} = ref $_[0] 2481 ? shift 2482 : sub { 2483 $_[1]-$_[$_[5] ? 5 : 4] > $SOAP::Constants::OBJS_BY_REF_KEEPALIVE 2484 } 2485 } 2486 keys %alive; 2487} 2488 2489sub reference { 2490 my $self = shift; 2491 my $stamp = time; 2492 my $object = shift; 2493 my $id = $stamp . $self->gen_id($object); 2494 2495 # this is code for garbage collection 2496 my $time = time; 2497 my $type = ref $object; 2498 my @objects = grep { $objects{$_}->[1] eq $type } keys %objects; 2499 for (grep { $alive{$type}->(scalar @objects, $time, @{$objects{$_}}) } @objects) { 2500 delete $objects{$_}; 2501 } 2502 2503 $objects{$id} = [$object, $type, $stamp]; 2504 bless { id => $id } => ref $object; 2505} 2506 2507sub references { 2508 my $self = shift; 2509 return @_ unless %alive; # small optimization 2510 return map { 2511 ref($_) && exists $alive{ref $_} 2512 ? $self->reference($_) 2513 : $_ 2514 } @_; 2515} 2516 2517sub object { 2518 my $self = shift; 2519 my $class = ref($self) || $self; 2520 my $object = shift; 2521 return $object unless ref($object) && $alive{ref $object} && exists $object->{id}; 2522 2523 my $reference = $objects{$object->{id}}; 2524 die "Object with specified id couldn't be found\n" unless ref $reference->[0]; 2525 2526 $reference->[3] = time; # last access time 2527 return $reference->[0]; # reference to actual object 2528} 2529 2530sub objects { 2531 my $self = shift; 2532 return @_ unless %alive; # small optimization 2533 return map { 2534 ref($_) && exists $alive{ref $_} && exists $_->{id} 2535 ? $self->object($_) 2536 : $_ 2537 } @_; 2538} 2539 2540# ====================================================================== 2541 2542package SOAP::Server::Parameters; 2543 2544sub byNameOrOrder { 2545 unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) { 2546 warn "Last parameter is expected to be envelope\n" if $^W; 2547 pop; 2548 return @_; 2549 } 2550 my $params = pop->method; 2551 my @mandatory = ref $_[0] eq 'ARRAY' 2552 ? @{shift()} 2553 : die "list of parameters expected as the first parameter for byName"; 2554 my $byname = 0; 2555 my @res = map { $byname += exists $params->{$_}; $params->{$_} } @mandatory; 2556 return $byname 2557 ? @res 2558 : @_; 2559} 2560 2561sub byName { 2562 unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) { 2563 warn "Last parameter is expected to be envelope\n" if $^W; 2564 pop; 2565 return @_; 2566 } 2567 return @{pop->method}{ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName"}; 2568} 2569 2570# ====================================================================== 2571 2572package SOAP::Server; 2573 2574use Carp (); 2575use Scalar::Util qw(weaken); 2576sub DESTROY { SOAP::Trace::objects('()') } 2577 2578sub initialize { 2579 return ( 2580 packager => SOAP::Packager::MIME->new, 2581 transport => SOAP::Transport->new, 2582 serializer => SOAP::Serializer->new, 2583 deserializer => SOAP::Deserializer->new, 2584 on_action => sub { ; }, 2585 on_dispatch => sub { 2586 return; 2587 }, 2588 ); 2589} 2590 2591sub new { 2592 my $self = shift; 2593 return $self if ref $self; 2594 2595 unless (ref $self) { 2596 my $class = $self; 2597 my(@params, @methods); 2598 2599 while (@_) { 2600 my($method, $params) = splice(@_,0,2); 2601 $class->can($method) 2602 ? push(@methods, $method, $params) 2603 : $^W && Carp::carp "Unrecognized parameter '$method' in new()"; 2604 } 2605 2606 $self = bless { 2607 _dispatch_to => [], 2608 _dispatch_with => {}, 2609 _dispatched => [], 2610 _action => '', 2611 _options => {}, 2612 } => $class; 2613 unshift(@methods, $self->initialize); 2614 no strict qw(refs); 2615 while (@methods) { 2616 my($method, $params) = splice(@methods,0,2); 2617 $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 2618 } 2619 SOAP::Trace::objects('()'); 2620 } 2621 2622 Carp::carp "Odd (wrong?) number of parameters in new()" 2623 if $^W && (@_ & 1); 2624 2625 no strict qw(refs); 2626 while (@_) { 2627 my($method, $params) = splice(@_,0,2); 2628 $self->can($method) 2629 ? $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 2630 : $^W && Carp::carp "Unrecognized parameter '$method' in new()" 2631 } 2632 2633 return $self; 2634} 2635 2636sub init_context { 2637 my $self = shift; 2638 $self->{'_deserializer'}->{'_context'} = $self; 2639 # weaken circular reference to avoid a memory hole 2640 weaken($self->{'_deserializer'}->{'_context'}); 2641 2642 $self->{'_serializer'}->{'_context'} = $self; 2643 # weaken circular reference to avoid a memory hole 2644 weaken($self->{'_serializer'}->{'_context'}); 2645} 2646 2647sub BEGIN { 2648 no strict 'refs'; 2649 for my $method (qw(serializer deserializer transport)) { 2650 my $field = '_' . $method; 2651 *$method = sub { 2652 my $self = shift->new(); 2653 if (@_) { 2654 my $context = $self->{$field}->{'_context'}; # save the old context 2655 $self->{$field} = shift; 2656 $self->{$field}->{'_context'} = $context; # restore the old context 2657 return $self; 2658 } 2659 else { 2660 return $self->{$field}; 2661 } 2662 } 2663 } 2664 2665 for my $method (qw(action myuri options dispatch_with packager)) { 2666 my $field = '_' . $method; 2667 *$method = sub { 2668 my $self = shift->new(); 2669 (@_) 2670 ? do { 2671 $self->{$field} = shift; 2672 return $self; 2673 } 2674 : return $self->{$field}; 2675 } 2676 } 2677 for my $method (qw(on_action on_dispatch)) { 2678 my $field = '_' . $method; 2679 *$method = sub { 2680 my $self = shift->new; 2681 # my $self = shift; 2682 return $self->{$field} unless @_; 2683 local $@; 2684 # commented out because that 'eval' was unsecure 2685 # > ref $_[0] eq 'CODE' ? shift : eval shift; 2686 # Am I paranoid enough? 2687 $self->{$field} = shift; 2688 Carp::croak $@ if $@; 2689 Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)" 2690 unless ref $self->{$field} eq 'CODE'; 2691 return $self; 2692 } 2693 } 2694 2695 # __PACKAGE__->__mk_accessors( qw(dispatch_to) ); 2696 for my $method (qw(dispatch_to)) { 2697 my $field = '_' . $method; 2698 *$method = sub { 2699 my $self = shift->new; 2700 # my $self = shift; 2701 (@_) 2702 ? do { 2703 $self->{$field} = [@_]; 2704 return $self; 2705 } 2706 : return @{ $self->{$field} }; 2707 } 2708 } 2709} 2710 2711sub objects_by_reference { 2712 my $self = shift; 2713 $self = $self->new() if not ref $self; 2714 @_ 2715 ? (SOAP::Server::Object->objects_by_reference(@_), return $self) 2716 : SOAP::Server::Object->objects_by_reference; 2717} 2718 2719sub dispatched { 2720 my $self = shift; 2721 $self = $self->new() if not ref $self; 2722 @_ 2723 ? (push(@{$self->{_dispatched}}, @_), return $self) 2724 : return @{$self->{_dispatched}}; 2725} 2726 2727sub find_target { 2728 my $self = shift; 2729 my $request = shift; 2730 2731 # try to find URI/method from on_dispatch call first 2732 my($method_uri, $method_name) = $self->on_dispatch->($request); 2733 2734 # if nothing there, then get it from envelope itself 2735 $request->match((ref $request)->method); 2736 ($method_uri, $method_name) = ($request->namespaceuriof || '', $request->dataof->name) 2737 unless $method_name; 2738 2739 $self->on_action->(my $action = $self->action, $method_uri, $method_name); 2740 2741 # check to avoid security vulnerability: Protected->Unprotected::method(@parameters) 2742 # see for more details: http://www.phrack.org/phrack/58/p58-0x09 2743 die "Denied access to method ($method_name)\n" unless $method_name =~ /^\w+$/; 2744 2745 my ($class, $static); 2746 # try to bind directly 2747 if (defined($class = $self->dispatch_with->{$method_uri} 2748 || $self->dispatch_with->{$action || ''} 2749 || (defined($action) && $action =~ /^"(.+)"$/ 2750 ? $self->dispatch_with->{$1} 2751 : undef))) { 2752 # return object, nothing else to do here 2753 return ($class, $method_uri, $method_name) if ref $class; 2754 $static = 1; 2755 } 2756 else { 2757 die "URI path shall map to class" unless defined ($class = URI->new($method_uri)->path); 2758 2759 for ($class) { s!^/|/$!!g; s!/!::!g; s/^$/main/; } 2760 die "Failed to access class ($class)" unless $class =~ /^(\w[\w:]*)$/; 2761 2762 my $fullname = "$class\::$method_name"; 2763 foreach ($self->dispatch_to) { 2764 return ($_, $method_uri, $method_name) if ref eq $class; # $OBJECT 2765 next if ref; # skip other objects 2766 # will ignore errors, because it may complain on 2767 # d:\foo\bar, which is PATH and not regexp 2768 eval { 2769 $static ||= $class =~ /^$_$/ # MODULE 2770 || $fullname =~ /^$_$/ # MODULE::method 2771 || $method_name =~ /^$_$/ && ($class eq 'main'); # method ('main' assumed) 2772 }; 2773 } 2774 } 2775 2776 no strict 'refs'; 2777 2778# TODO - sort this mess out: 2779# The task is to test whether the class in question has already been loaded. 2780# 2781# SOAP::Lite 0.60: 2782# unless (defined %{"${class}::"}) { 2783# Patch to SOAP::Lite 0.60: 2784# The following patch does not work for packages defined within a BEGIN block 2785# unless (exists($INC{join '/', split /::/, $class.'.pm'})) { 2786# Combination of 0.60 and patch did not work reliably, either. 2787# 2788# Now we do the following: Check whether the class is main (always loaded) 2789# or the class implements the method in question 2790# or the package exists as file in %INC. 2791# 2792# This is still sort of a hack - but I don't know anything better 2793# If you have some idea, please help me out... 2794# 2795 unless (($class eq 'main') || $class->can($method_name) 2796 || exists($INC{join '/', split /::/, $class . '.pm'})) { 2797 2798 # allow all for static and only specified path for dynamic bindings 2799 local @INC = (($static ? @INC : ()), grep {!ref && m![/\\.]!} $self->dispatch_to()); 2800 eval 'local $^W; ' . "require $class"; 2801 die "Failed to access class ($class): $@" if $@; 2802 $self->dispatched($class) unless $static; 2803 } 2804 2805 die "Denied access to method ($method_name) in class ($class)" 2806 unless $static || grep {/^$class$/} $self->dispatched; 2807 2808 return ($class, $method_uri, $method_name); 2809} 2810 2811sub handle { 2812 SOAP::Trace::trace('()'); 2813 my $self = shift; 2814 $self = $self->new if !ref $self; # inits the server when called in a static context 2815 $self->init_context(); 2816 # we want to restore it when we are done 2817 local $SOAP::Constants::DEFAULT_XML_SCHEMA 2818 = $SOAP::Constants::DEFAULT_XML_SCHEMA; 2819 2820 # SOAP version WILL NOT be restored when we are done. 2821 # is it problem? 2822 2823 my $result = eval { 2824 local $SIG{__DIE__}; 2825 # why is this here: 2826 $self->serializer->soapversion(1.1); 2827 my $request = eval { $self->deserializer->deserialize($_[0]) }; 2828 2829 die SOAP::Fault 2830 ->faultcode($SOAP::Constants::FAULT_VERSION_MISMATCH) 2831 ->faultstring($@) 2832 if $@ && $@ =~ /^$SOAP::Constants::WRONG_VERSION/; 2833 2834 die "Application failed during request deserialization: $@" if $@; 2835 my $som = ref $request; 2836 die "Can't find root element in the message" 2837 unless $request->match($som->envelope); 2838 $self->serializer->soapversion(SOAP::Lite->soapversion); 2839 $self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA 2840 = $self->deserializer->xmlschema) 2841 if $self->deserializer->xmlschema; 2842 2843 die SOAP::Fault 2844 ->faultcode($SOAP::Constants::FAULT_MUST_UNDERSTAND) 2845 ->faultstring("Unrecognized header has mustUnderstand attribute set to 'true'") 2846 if !$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND && 2847 grep { 2848 $_->mustUnderstand 2849 && (!$_->actor || $_->actor eq $SOAP::Constants::NEXT_ACTOR) 2850 } $request->dataof($som->headers); 2851 2852 die "Can't find method element in the message" 2853 unless $request->match($som->method); 2854 # TODO - SOAP::Dispatcher plugs in here 2855 # my $handler = $self->dispatcher->find_handler($request); 2856 my($class, $method_uri, $method_name) = $self->find_target($request); 2857 my @results = eval { 2858 local $^W; 2859 my @parameters = $request->paramsin; 2860 2861 # SOAP::Trace::dispatch($fullname); 2862 SOAP::Trace::parameters(@parameters); 2863 2864 push @parameters, $request 2865 if UNIVERSAL::isa($class => 'SOAP::Server::Parameters'); 2866 2867 no strict qw(refs); 2868 SOAP::Server::Object->references( 2869 defined $parameters[0] 2870 && ref $parameters[0] 2871 && UNIVERSAL::isa($parameters[0] => $class) 2872 ? do { 2873 my $object = shift @parameters; 2874 SOAP::Server::Object->object(ref $class 2875 ? $class 2876 : $object 2877 )->$method_name(SOAP::Server::Object->objects(@parameters)), 2878 2879 # send object back as a header 2880 # preserve name, specify URI 2881 SOAP::Header 2882 ->uri($SOAP::Constants::NS_SL_HEADER => $object) 2883 ->name($request->dataof($som->method.'/[1]')->name) 2884 } # end do block 2885 2886 # SOAP::Dispatcher will plug-in here as well 2887 # $handler->dispatch(SOAP::Server::Object->objects(@parameters) 2888 : $class->$method_name(SOAP::Server::Object->objects(@parameters)) ); 2889 }; # end eval block 2890 SOAP::Trace::result(@results); 2891 2892 # let application errors pass through with 'Server' code 2893 die ref $@ 2894 ? $@ 2895 : $@ =~ /^Can\'t locate object method "$method_name"/ 2896 ? "Failed to locate method ($method_name) in class ($class)" 2897 : SOAP::Fault->faultcode($SOAP::Constants::FAULT_SERVER)->faultstring($@) 2898 if $@; 2899 2900 my $result = $self->serializer 2901 ->prefix('s') # distinguish generated element names between client and server 2902 ->uri($method_uri) 2903 ->envelope(response => $method_name . 'Response', @results); 2904 return $result; 2905 }; 2906 2907 # void context 2908 return unless defined wantarray; 2909 2910 # normal result 2911 return $result unless $@; 2912 2913 # check fails, something wrong with message 2914 return $self->make_fault($SOAP::Constants::FAULT_CLIENT, $@) unless ref $@; 2915 2916 # died with SOAP::Fault 2917 return $self->make_fault($@->faultcode || $SOAP::Constants::FAULT_SERVER, 2918 $@->faultstring || 'Application error', 2919 $@->faultdetail, $@->faultactor) 2920 if UNIVERSAL::isa($@ => 'SOAP::Fault'); 2921 2922 # died with complex detail 2923 return $self->make_fault($SOAP::Constants::FAULT_SERVER, 'Application error' => $@); 2924 2925} # end of handle() 2926 2927sub make_fault { 2928 my $self = shift; 2929 my($code, $string, $detail, $actor) = @_; 2930 $self->serializer->fault($code, $string, $detail, $actor || $self->myuri); 2931} 2932 2933# ====================================================================== 2934 2935package SOAP::Trace; 2936 2937use Carp (); 2938 2939my @list = qw( 2940 transport dispatch result 2941 parameters headers objects 2942 method fault freeform 2943 trace debug); 2944{ 2945 no strict 'refs'; 2946 for (@list) { 2947 *$_ = sub {} 2948 } 2949} 2950 2951sub defaultlog { 2952 my $caller = (caller(1))[3]; # the 4th element returned by caller is the subroutine namea 2953 $caller = (caller(2))[3] if $caller =~ /eval/; 2954 chomp(my $msg = join ' ', @_); 2955 printf STDERR "%s: %s\n", $caller, $msg; 2956} 2957 2958sub import { 2959 no strict 'refs'; 2960 local $^W; 2961 my $pack = shift; 2962 my(@notrace, @symbols); 2963 for (@_) { 2964 if (ref eq 'CODE') { 2965 my $call = $_; 2966 foreach (@symbols) { *$_ = sub { $call->(@_) } } 2967 @symbols = (); 2968 } 2969 else { 2970 local $_ = $_; 2971 my $minus = s/^-//; 2972 my $all = $_ eq 'all'; 2973 Carp::carp "Illegal symbol for tracing ($_)" unless $all || $pack->can($_); 2974 $minus ? push(@notrace, $all ? @list : $_) : push(@symbols, $all ? @list : $_); 2975 } 2976 } 2977 # TODO - I am getting a warning here about redefining a subroutine 2978 foreach (@symbols) { *$_ = \&defaultlog } 2979 foreach (@notrace) { *$_ = sub {} } 2980} 2981 2982# ====================================================================== 2983 2984package SOAP::Custom::XML::Data; 2985 2986use vars qw(@ISA $AUTOLOAD); 2987@ISA = qw(SOAP::Data); 2988 2989use overload fallback => 1, '""' => sub { shift->value }; 2990 2991sub _compileit { 2992 no strict 'refs'; 2993 my $method = shift; 2994 *$method = sub { 2995 return __PACKAGE__->SUPER::name($method => $_[0]->attr->{$method}) 2996 if exists $_[0]->attr->{$method}; 2997 my @elems = grep { 2998 ref $_ && UNIVERSAL::isa($_ => __PACKAGE__) 2999 && $_->SUPER::name =~ /(^|:)$method$/ 3000 } $_[0]->value; 3001 return wantarray? @elems : $elems[0]; 3002 }; 3003} 3004 3005sub BEGIN { foreach (qw(name type import use)) { _compileit($_) } } 3006 3007sub AUTOLOAD { 3008 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); 3009 return if $method eq 'DESTROY'; 3010 3011 _compileit($method); 3012 goto &$AUTOLOAD; 3013} 3014 3015# ====================================================================== 3016 3017package SOAP::Custom::XML::Deserializer; 3018 3019use vars qw(@ISA); 3020@ISA = qw(SOAP::Deserializer); 3021 3022sub decode_value { 3023 my $self = shift; 3024 my $ref = shift; 3025 my($name, $attrs, $children, $value) = @$ref; 3026 # base class knows what to do with it 3027 return $self->SUPER::decode_value($ref) if exists $attrs->{href}; 3028 3029 SOAP::Custom::XML::Data 3030 -> SOAP::Data::name($name) 3031 -> attr($attrs) 3032 -> set_value(ref $children && @$children 3033 ? map(scalar(($self->decode_object($_))[1]), @$children) 3034 : $value); 3035} 3036 3037# ====================================================================== 3038 3039package SOAP::Schema::Deserializer; 3040 3041use vars qw(@ISA); 3042@ISA = qw(SOAP::Custom::XML::Deserializer); 3043 3044# ====================================================================== 3045 3046package SOAP::Schema::WSDL; 3047 3048use vars qw(%imported @ISA); 3049@ISA = qw(SOAP::Schema); 3050 3051sub new { 3052 my $self = shift; 3053 3054 unless (ref $self) { 3055 my $class = $self; 3056 $self = $class->SUPER::new(@_); 3057 } 3058 return $self; 3059} 3060 3061sub base { 3062 my $self = shift->new; 3063 @_ 3064 ? ($self->{_base} = shift, return $self) 3065 : return $self->{_base}; 3066} 3067 3068sub import { 3069 my $self = shift->new; 3070 my $s = shift; 3071 my $base = shift || $self->base || die "Missing base argument for ", __PACKAGE__, "\n"; 3072 3073 my @a = $s->import; 3074 local %imported = %imported; 3075 foreach (@a) { 3076 next unless $_->location; 3077 my $location = URI->new_abs($_->location->value, $base)->as_string; 3078 if ($imported{$location}++) { 3079 warn "Recursion loop detected in service description from '$location'. Ignored\n" if $^W; 3080 return $s; 3081 } 3082 my $root = $self->import( 3083 $self->deserializer->deserialize( 3084 $self->access($location) 3085 )->root, $location); 3086 3087 $root->SOAP::Data::name eq 'definitions' ? $s->set_value($s->value, $root->value) : 3088 $root->SOAP::Data::name eq 'schema' ? do { # add <types> element if there is no one 3089 $s->set_value($s->value, $self->deserializer->deserialize('<types></types>')->root) unless $s->types; 3090 $s->types->set_value($s->types->value, $root) } : 3091 die "Don't know what to do with '@{[$root->SOAP::Data::name]}' in schema imported from '$location'\n"; 3092 } 3093 3094 # return the parsed WSDL file 3095 $s; 3096} 3097 3098# TODO - This is woefully incomplete! 3099sub parse_schema_element { 3100 my $element = shift; 3101 # Current element is a complex type 3102 if (defined($element->complexType)) { 3103 my @elements = (); 3104 if (defined($element->complexType->sequence)) { 3105 3106 foreach my $e ($element->complexType->sequence->element) { 3107 push @elements,parse_schema_element($e); 3108 } 3109 } 3110 return @elements; 3111 } 3112 elsif ($element->simpleType) { 3113 } 3114 else { 3115 return $element; 3116 } 3117} 3118 3119sub parse { 3120 my $self = shift->new; 3121 my($s, $service, $port) = @_; 3122 my @result; 3123 3124 # handle imports 3125 $self->import($s); 3126 3127 # handle descriptions without <service>, aka tModel-type descriptions 3128 my @services = $s->service; 3129 my $tns = $s->{'_attr'}->{'targetNamespace'}; 3130 # if there is no <service> element we'll provide it 3131 @services = $self->deserializer->deserialize(<<"FAKE")->root->service unless @services; 3132<definitions> 3133 <service name="@{[$service || 'FakeService']}"> 3134 <port name="@{[$port || 'FakePort']}" binding="@{[$s->binding->name]}"/> 3135 </service> 3136</definitions> 3137FAKE 3138 3139 my $has_warned = 0; 3140 foreach (@services) { 3141 my $name = $_->name; 3142 next if $service && $service ne $name; 3143 my %services; 3144 foreach ($_->port) { 3145 next if $port && $port ne $_->name; 3146 my $binding = SOAP::Utils::disqualify($_->binding); 3147 my $endpoint = ref $_->address ? $_->address->location : undef; 3148 foreach ($s->binding) { 3149 # is this a SOAP binding? 3150 next unless grep { $_->uri eq 'http://schemas.xmlsoap.org/wsdl/soap/' } $_->binding; 3151 next unless $_->name eq $binding; 3152 my $default_style = $_->binding->style; 3153 my $porttype = SOAP::Utils::disqualify($_->type); 3154 foreach ($_->operation) { 3155 my $opername = $_->name; 3156 $services{$opername} = {}; # should be initialized in 5.7 and after 3157 my $soapaction = $_->operation->soapAction; 3158 my $invocationStyle = $_->operation->style || $default_style || "rpc"; 3159 my $encodingStyle = $_->input->body->use || "encoded"; 3160 my $namespace = $_->input->body->namespace || $tns; 3161 my @parts; 3162 foreach ($s->portType) { 3163 next unless $_->name eq $porttype; 3164 foreach ($_->operation) { 3165 next unless $_->name eq $opername; 3166 my $inputmessage = SOAP::Utils::disqualify($_->input->message); 3167 foreach my $msg ($s->message) { 3168 next unless $msg->name eq $inputmessage; 3169 if ($invocationStyle eq "document" && $encodingStyle eq "literal") { 3170# warn "document/literal support is EXPERIMENTAL in SOAP::Lite" 3171# if !$has_warned && ($has_warned = 1); 3172 my ($input_ns,$input_name) = SOAP::Utils::splitqname($msg->part->element); 3173 foreach my $schema ($s->types->schema) { 3174 foreach my $element ($schema->element) { 3175 next unless $element->name eq $input_name; 3176 push @parts,parse_schema_element($element); 3177 } 3178 $services{$opername}->{parameters} = [ @parts ]; 3179 } 3180 } 3181 else { 3182 # TODO - support all combinations of doc|rpc/lit|enc. 3183 #warn "$invocationStyle/$encodingStyle is not supported in this version of SOAP::Lite"; 3184 @parts = $msg->part; 3185 $services{$opername}->{parameters} = [ @parts ]; 3186 } 3187 } 3188 } 3189 3190 for ($services{$opername}) { 3191 $_->{endpoint} = $endpoint; 3192 $_->{soapaction} = $soapaction; 3193 $_->{namespace} = $namespace; 3194 # $_->{parameters} = [@parts]; 3195 } 3196 } 3197 } 3198 } 3199 } 3200 # fix nonallowed characters in package name, and add 's' if started with digit 3201 for ($name) { s/\W+/_/g; s/^(\d)/s$1/ } 3202 push @result, $name => \%services; 3203 } 3204 return @result; 3205} 3206 3207# ====================================================================== 3208 3209# Naming? SOAP::Service::Schema? 3210package SOAP::Schema; 3211 3212use Carp (); 3213 3214sub DESTROY { SOAP::Trace::objects('()') } 3215 3216sub new { 3217 my $self = shift; 3218 return $self if ref $self; 3219 unless (ref $self) { 3220 my $class = $self; 3221 require LWP::UserAgent; 3222 $self = bless { 3223 '_deserializer' => SOAP::Schema::Deserializer->new, 3224 '_useragent' => LWP::UserAgent->new, 3225 }, $class; 3226 3227 SOAP::Trace::objects('()'); 3228 } 3229 3230 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 3231 no strict qw(refs); 3232 while (@_) { 3233 my $method = shift; 3234 $self->$method(shift) if $self->can($method) 3235 } 3236 3237 return $self; 3238} 3239 3240sub schema { 3241 warn "SOAP::Schema->schema has been deprecated. " 3242 . "Please use SOAP::Schema->schema_url instead."; 3243 return shift->schema_url(@_); 3244} 3245 3246sub BEGIN { 3247 no strict 'refs'; 3248 for my $method (qw(deserializer schema_url services useragent stub cache_dir cache_ttl)) { 3249 my $field = '_' . $method; 3250 *$method = sub { 3251 my $self = shift->new; 3252 @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; 3253 } 3254 } 3255} 3256 3257sub parse { 3258 my $self = shift; 3259 my $s = $self->deserializer->deserialize($self->access)->root; 3260 # here should be something that defines what schema description we want to use 3261 $self->services({SOAP::Schema::WSDL->base($self->schema_url)->parse($s, @_)}); 3262} 3263 3264sub refresh_cache { 3265 my $self = shift; 3266 my ($filename,$contents) = @_; 3267 open CACHE,">$filename" or Carp::croak "Could not open cache file for writing: $!"; 3268 print CACHE $contents; 3269 close CACHE; 3270} 3271 3272sub load { 3273 my $self = shift->new; 3274 local $^W; # supress warnings about redefining 3275 foreach (keys %{$self->services || Carp::croak 'Nothing to load. Schema is not specified'}) { 3276 # TODO - check age of cached file, and delete if older than configured amount 3277 if ($self->cache_dir) { 3278 my $cached_file = File::Spec->catfile($self->cache_dir,$_.".pm"); 3279 my $ttl = $self->cache_ttl || $SOAP::Constants::DEFAULT_CACHE_TTL; 3280 open (CACHE, "<$cached_file"); 3281 my @stat = stat($cached_file) unless eof(CACHE); 3282 close CACHE; 3283 if (@stat) { 3284 # Cache exists 3285 my $cache_lived = time() - $stat[9]; 3286 if ($ttl > 0 && $cache_lived > $ttl) { 3287 $self->refresh_cache($cached_file,$self->generate_stub($_)); 3288 } 3289 } 3290 else { 3291 # Cache doesn't exist 3292 $self->refresh_cache($cached_file,$self->generate_stub($_)); 3293 } 3294 push @INC,$self->cache_dir; 3295 eval "require $_" or Carp::croak "Could not load cached file: $@"; 3296 } 3297 else { 3298 eval $self->generate_stub($_) or Carp::croak "Bad stub: $@"; 3299 } 3300 } 3301 $self; 3302} 3303 3304sub access { 3305 my $self = shift->new; 3306 my $url = shift || $self->schema_url || Carp::croak 'Nothing to access. URL is not specified'; 3307 $self->useragent->env_proxy if $ENV{'HTTP_proxy'}; 3308 3309 my $req = HTTP::Request->new(GET => $url); 3310 $req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'}) 3311 if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'}); 3312 3313 my $resp = $self->useragent->request($req); 3314 $resp->is_success ? $resp->content : die "Service description '$url' can't be loaded: ", $resp->status_line, "\n"; 3315} 3316 3317sub generate_stub { 3318 my $self = shift->new; 3319 my $package = shift; 3320 my $services = $self->services->{$package}; 3321 my $schema_url = $self->schema_url; 3322 3323 $self->{'_stub'} = <<"EOP"; 3324package $package; 3325# Generated by SOAP::Lite (v$SOAP::Lite::VERSION) for Perl -- soaplite.com 3326# Copyright (C) 2000-2006 Paul Kulchenko, Byrne Reese 3327# -- generated at [@{[scalar localtime]}] 3328EOP 3329 $self->{'_stub'} .= "# -- generated from $schema_url\n" if $schema_url; 3330 $self->{'_stub'} .= 'my %methods = ('."\n"; 3331 foreach my $service (keys %$services) { 3332 $self->{'_stub'} .= "'$service' => {\n"; 3333 foreach (qw(endpoint soapaction namespace)) { 3334 $self->{'_stub'} .= " $_ => '".$services->{$service}{$_}."',\n"; 3335 } 3336 $self->{'_stub'} .= " parameters => [\n"; 3337 foreach (@{$services->{$service}{parameters}}) { 3338 # This is a workaround for https://sourceforge.net/tracker/index.php?func=detail&aid=2001592&group_id=66000&atid=513017 3339 next unless ref $_; 3340 $self->{'_stub'} .= " SOAP::Data->new(name => '".$_->name."', type => '".$_->type."', attr => {"; 3341 $self->{'_stub'} .= do { 3342 my %attr = %{$_->attr}; 3343 join(', ', map {"'$_' => '$attr{$_}'"} 3344 grep {/^xmlns:(?!-)/} 3345 keys %attr); 3346 }; 3347 $self->{'_stub'} .= "}),\n"; 3348 } 3349 $self->{'_stub'} .= " ], # end parameters\n"; 3350 $self->{'_stub'} .= " }, # end $service\n"; 3351 } 3352 $self->{'_stub'} .= "); # end my %methods\n"; 3353 $self->{'_stub'} .= <<'EOP'; 3354 3355use SOAP::Lite; 3356use Exporter; 3357use Carp (); 3358 3359use vars qw(@ISA $AUTOLOAD @EXPORT_OK %EXPORT_TAGS); 3360@ISA = qw(Exporter SOAP::Lite); 3361@EXPORT_OK = (keys %methods); 3362%EXPORT_TAGS = ('all' => [@EXPORT_OK]); 3363 3364sub _call { 3365 my ($self, $method) = (shift, shift); 3366 my $name = UNIVERSAL::isa($method => 'SOAP::Data') ? $method->name : $method; 3367 my %method = %{$methods{$name}}; 3368 $self->proxy($method{endpoint} || Carp::croak "No server address (proxy) specified") 3369 unless $self->proxy; 3370 my @templates = @{$method{parameters}}; 3371 my @parameters = (); 3372 foreach my $param (@_) { 3373 if (@templates) { 3374 my $template = shift @templates; 3375 my ($prefix,$typename) = SOAP::Utils::splitqname($template->type); 3376 my $method = 'as_'.$typename; 3377 # TODO - if can('as_'.$typename) {...} 3378 my $result = $self->serializer->$method($param, $template->name, $template->type, $template->attr); 3379 push(@parameters, $template->value($result->[2])); 3380 } 3381 else { 3382 push(@parameters, $param); 3383 } 3384 } 3385 $self->endpoint($method{endpoint}) 3386 ->ns($method{namespace}) 3387 ->on_action(sub{qq!"$method{soapaction}"!}); 3388EOP 3389 my $namespaces = $self->deserializer->ids->[1]; 3390 foreach my $key (keys %{$namespaces}) { 3391 my ($ns,$prefix) = SOAP::Utils::splitqname($key); 3392 $self->{'_stub'} .= ' $self->serializer->register_ns("'.$namespaces->{$key}.'","'.$prefix.'");'."\n" 3393 if ($ns eq "xmlns"); 3394 } 3395 $self->{'_stub'} .= <<'EOP'; 3396 my $som = $self->SUPER::call($method => @parameters); 3397 if ($self->want_som) { 3398 return $som; 3399 } 3400 UNIVERSAL::isa($som => 'SOAP::SOM') ? wantarray ? $som->paramsall : $som->result : $som; 3401} 3402 3403sub BEGIN { 3404 no strict 'refs'; 3405 for my $method (qw(want_som)) { 3406 my $field = '_' . $method; 3407 *$method = sub { 3408 my $self = shift->new; 3409 @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; 3410 } 3411 } 3412} 3413no strict 'refs'; 3414for my $method (@EXPORT_OK) { 3415 my %method = %{$methods{$method}}; 3416 *$method = sub { 3417 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) 3418 ? ref $_[0] 3419 ? shift # OBJECT 3420 # CLASS, either get self or create new and assign to self 3421 : (shift->self || __PACKAGE__->self(__PACKAGE__->new)) 3422 # function call, either get self or create new and assign to self 3423 : (__PACKAGE__->self || __PACKAGE__->self(__PACKAGE__->new)); 3424 $self->_call($method, @_); 3425 } 3426} 3427 3428sub AUTOLOAD { 3429 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); 3430 return if $method eq 'DESTROY' || $method eq 'want_som'; 3431 die "Unrecognized method '$method'. List of available method(s): @EXPORT_OK\n"; 3432} 3433 34341; 3435EOP 3436 return $self->stub; 3437} 3438 3439# ====================================================================== 3440 3441package SOAP; 3442 3443use vars qw($AUTOLOAD); 3444require URI; 3445 3446my $soap; # shared between SOAP and SOAP::Lite packages 3447 3448{ 3449 no strict 'refs'; 3450 *AUTOLOAD = sub { 3451 local($1,$2); 3452 my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/; 3453 return if $method eq 'DESTROY'; 3454 3455 my $soap = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite') 3456 ? $_[0] 3457 : $soap 3458 || die "SOAP:: prefix shall only be used in combination with +autodispatch option\n"; 3459 3460 my $uri = URI->new($soap->uri); 3461 my $currenturi = $uri->path; 3462 $package = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite') 3463 ? $currenturi 3464 : $package eq 'SOAP' 3465 ? ref $_[0] || ($_[0] eq 'SOAP' 3466 ? $currenturi || Carp::croak "URI is not specified for method call" 3467 : $_[0]) 3468 : $package eq 'main' 3469 ? $currenturi || $package 3470 : $package; 3471 3472 # drop first parameter if it's a class name 3473 { 3474 my $pack = $package; 3475 for ($pack) { s!^/!!; s!/!::!g; } 3476 shift @_ if @_ && !ref $_[0] && ($_[0] eq $pack || $_[0] eq 'SOAP') 3477 || ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite'); 3478 } 3479 3480 for ($package) { s!::!/!g; s!^/?!/!; } 3481 $uri->path($package); 3482 3483 my $som = $soap->uri($uri->as_string)->call($method => @_); 3484 UNIVERSAL::isa($som => 'SOAP::SOM') 3485 ? wantarray 3486 ? $som->paramsall 3487 : $som->result 3488 : $som; 3489 }; 3490} 3491 3492# ====================================================================== 3493 3494package SOAP::Lite; 3495 3496use vars qw($AUTOLOAD @ISA); 3497use Carp (); 3498 3499use SOAP::Lite::Utils; 3500use SOAP::Constants; 3501use SOAP::Packager; 3502 3503use Scalar::Util qw(weaken blessed); 3504 3505@ISA = qw(SOAP::Cloneable); 3506 3507# provide access to global/autodispatched object 3508sub self { 3509 @_ > 1 3510 ? $soap = $_[1] 3511 : $soap 3512} 3513 3514# no more warnings about "used only once" 3515*UNIVERSAL::AUTOLOAD if 0; 3516 3517sub autodispatched { \&{*UNIVERSAL::AUTOLOAD} eq \&{*SOAP::AUTOLOAD} }; 3518 3519sub soapversion { 3520 my $self = shift; 3521 my $version = shift or return $SOAP::Constants::SOAP_VERSION; 3522 3523 ($version) = grep { 3524 $SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV} eq $version 3525 } keys %SOAP::Constants::SOAP_VERSIONS 3526 unless exists $SOAP::Constants::SOAP_VERSIONS{$version}; 3527 3528 die qq!$SOAP::Constants::WRONG_VERSION Supported versions:\n@{[ 3529 join "\n", map {" $_ ($SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV})"} keys %SOAP::Constants::SOAP_VERSIONS 3530 ]}\n! 3531 unless defined($version) && defined(my $def = $SOAP::Constants::SOAP_VERSIONS{$version}); 3532 3533 foreach (keys %$def) { 3534 eval "\$SOAP::Constants::$_ = '$SOAP::Constants::SOAP_VERSIONS{$version}->{$_}'"; 3535 } 3536 3537 $SOAP::Constants::SOAP_VERSION = $version; 3538 3539 return $self; 3540} 3541 3542BEGIN { SOAP::Lite->soapversion(1.1) } 3543 3544sub import { 3545 my $pkg = shift; 3546 my $caller = caller; 3547 no strict 'refs'; 3548 # emulate 'use SOAP::Lite 0.99' behavior 3549 $pkg->require_version(shift) if defined $_[0] && $_[0] =~ /^\d/; 3550 3551 while (@_) { 3552 my $command = shift; 3553 3554 my @parameters = UNIVERSAL::isa($_[0] => 'ARRAY') 3555 ? @{shift()} 3556 : shift 3557 if @_ && $command ne 'autodispatch'; 3558 3559 if ($command eq 'autodispatch' || $command eq 'dispatch_from') { 3560 $soap = ($soap||$pkg)->new; 3561 no strict 'refs'; 3562 foreach ($command eq 'autodispatch' 3563 ? 'UNIVERSAL' 3564 : @parameters 3565 ) { 3566 my $sub = "${_}::AUTOLOAD"; 3567 defined &{*$sub} 3568 ? (\&{*$sub} eq \&{*SOAP::AUTOLOAD} 3569 ? () 3570 : Carp::croak "$sub already assigned and won't work with DISPATCH. Died") 3571 : (*$sub = *SOAP::AUTOLOAD); 3572 } 3573 } 3574 elsif ($command eq 'service') { 3575 foreach (keys %{SOAP::Schema->schema_url(shift(@parameters))->parse(@parameters)->load->services}) { 3576 $_->export_to_level(1, undef, ':all'); 3577 } 3578 } 3579 elsif ($command eq 'debug' || $command eq 'trace') { 3580 SOAP::Trace->import(@parameters ? @parameters : 'all'); 3581 } 3582 elsif ($command eq 'import') { 3583 local $^W; # supress warnings about redefining 3584 my $package = shift(@parameters); 3585 $package->export_to_level(1, undef, @parameters ? @parameters : ':all') if $package; 3586 } 3587 else { 3588 Carp::carp "Odd (wrong?) number of parameters in import(), still continue" if $^W && !(@parameters & 1); 3589 $soap = ($soap||$pkg)->$command(@parameters); 3590 } 3591 } 3592} 3593 3594sub DESTROY { SOAP::Trace::objects('()') } 3595 3596sub new { 3597 my $self = shift; 3598 return $self if ref $self; 3599 unless (ref $self) { 3600 my $class = $self; 3601 # Check whether we can clone. Only the SAME class allowed, no inheritance 3602 $self = ref($soap) eq $class ? $soap->clone : { 3603 _transport => SOAP::Transport->new, 3604 _serializer => SOAP::Serializer->new, 3605 _deserializer => SOAP::Deserializer->new, 3606 _packager => SOAP::Packager::MIME->new, 3607 _schema => undef, 3608 _autoresult => 0, 3609 _on_action => sub { sprintf '"%s#%s"', shift || '', shift }, 3610 _on_fault => sub {ref $_[1] ? return $_[1] : Carp::croak $_[0]->transport->is_success ? $_[1] : $_[0]->transport->status}, 3611 }; 3612 bless $self => $class; 3613 $self->on_nonserialized($self->on_nonserialized || $self->serializer->on_nonserialized); 3614 SOAP::Trace::objects('()'); 3615 } 3616 3617 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); 3618 no strict qw(refs); 3619 while (@_) { 3620 my($method, $params) = splice(@_,0,2); 3621 $self->can($method) 3622 ? $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 3623 : $^W && Carp::carp "Unrecognized parameter '$method' in new()" 3624 } 3625 3626 return $self; 3627} 3628 3629sub init_context { 3630 my $self = shift->new; 3631 $self->{'_deserializer'}->{'_context'} = $self; 3632 # weaken circular reference to avoid a memory hole 3633 weaken $self->{'_deserializer'}->{'_context'}; 3634 3635 $self->{'_serializer'}->{'_context'} = $self; 3636 # weaken circular reference to avoid a memory hole 3637 weaken $self->{'_serializer'}->{'_context'}; 3638} 3639 3640# Naming? wsdl_parser 3641sub schema { 3642 my $self = shift; 3643 if (@_) { 3644 $self->{'_schema'} = shift; 3645 return $self; 3646 } 3647 else { 3648 if (!defined $self->{'_schema'}) { 3649 $self->{'_schema'} = SOAP::Schema->new; 3650 } 3651 return $self->{'_schema'}; 3652 } 3653} 3654 3655sub BEGIN { 3656 no strict 'refs'; 3657 for my $method (qw(serializer deserializer)) { 3658 my $field = '_' . $method; 3659 *$method = sub { 3660 my $self = shift->new; 3661 if (@_) { 3662 my $context = $self->{$field}->{'_context'}; # save the old context 3663 $self->{$field} = shift; 3664 $self->{$field}->{'_context'} = $context; # restore the old context 3665 return $self; 3666 } 3667 else { 3668 return $self->{$field}; 3669 } 3670 } 3671 } 3672 3673 __PACKAGE__->__mk_accessors( 3674 qw(endpoint transport outputxml autoresult packager) 3675 ); 3676 # for my $method () { 3677 # my $field = '_' . $method; 3678 # *$method = sub { 3679 # my $self = shift->new; 3680 # @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; 3681 # } 3682 # } 3683 for my $method (qw(on_action on_fault on_nonserialized)) { 3684 my $field = '_' . $method; 3685 *$method = sub { 3686 my $self = shift->new; 3687 return $self->{$field} unless @_; 3688 local $@; 3689 # commented out because that 'eval' was unsecure 3690 # > ref $_[0] eq 'CODE' ? shift : eval shift; 3691 # Am I paranoid enough? 3692 $self->{$field} = shift; 3693 Carp::croak $@ if $@; 3694 Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)" 3695 unless ref $self->{$field} eq 'CODE'; 3696 return $self; 3697 } 3698 } 3699 # SOAP::Transport Shortcuts 3700 # TODO - deprecate proxy() in favor of new language endpoint_url() 3701 no strict qw(refs); 3702 for my $method (qw(proxy)) { 3703 *$method = sub { 3704 my $self = shift->new; 3705 @_ ? ($self->transport->$method(@_), return $self) : return $self->transport->$method(); 3706 } 3707 } 3708 3709 # SOAP::Seriailizer Shortcuts 3710 for my $method (qw(autotype readable envprefix encodingStyle 3711 encprefix multirefinplace encoding 3712 typelookup header maptype xmlschema 3713 uri ns_prefix ns_uri use_prefix use_default_ns 3714 ns default_ns)) { 3715 *$method = sub { 3716 my $self = shift->new; 3717 @_ ? ($self->serializer->$method(@_), return $self) : return $self->serializer->$method(); 3718 } 3719 } 3720 3721 # SOAP::Schema Shortcuts 3722 for my $method (qw(cache_dir cache_ttl)) { 3723 *$method = sub { 3724 my $self = shift->new; 3725 @_ ? ($self->schema->$method(@_), return $self) : return $self->schema->$method(); 3726 } 3727 } 3728} 3729 3730sub parts { 3731 my $self = shift; 3732 $self->packager->parts(@_); 3733 return $self; 3734} 3735 3736# Naming? wsdl 3737sub service { 3738 my $self = shift->new; 3739 return $self->{'_service'} unless @_; 3740 $self->schema->schema_url($self->{'_service'} = shift); 3741 my %services = %{$self->schema->parse(@_)->load->services}; 3742 3743 Carp::croak "More than one service in service description. Service and port names have to be specified\n" 3744 if keys %services > 1; 3745 my $service = (keys %services)[0]->new; 3746 return $service; 3747} 3748 3749sub AUTOLOAD { 3750 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); 3751 return if $method eq 'DESTROY'; 3752 3753 ref $_[0] or Carp::croak qq!Can\'t locate class method "$method" via package \"! . __PACKAGE__ .'\"'; 3754 3755 no strict 'refs'; 3756 *$AUTOLOAD = sub { 3757 my $self = shift; 3758 my $som = $self->call($method => @_); 3759 return $self->autoresult && UNIVERSAL::isa($som => 'SOAP::SOM') 3760 ? wantarray ? $som->paramsall : $som->result 3761 : $som; 3762 }; 3763 goto &$AUTOLOAD; 3764} 3765 3766sub call { 3767 SOAP::Trace::trace('()'); 3768 my $self = shift; 3769 3770 die "A service address has not been specified either by using SOAP::Lite->proxy() or a service description)\n" 3771 unless defined $self->proxy && UNIVERSAL::isa($self->proxy => 'SOAP::Client'); 3772 3773 $self->init_context(); 3774 3775 my $serializer = $self->serializer; 3776 $serializer->on_nonserialized($self->on_nonserialized); 3777 3778 my $response = $self->transport->send_receive( 3779 context => $self, # this is provided for context 3780 endpoint => $self->endpoint, 3781 action => scalar($self->on_action->($serializer->uriformethod($_[0]))), 3782 # leave only parameters so we can later update them if required 3783 envelope => $serializer->envelope(method => shift, @_), 3784 encoding => $serializer->encoding, 3785 parts => @{$self->packager->parts} ? $self->packager->parts : undef, 3786 ); 3787 3788 return $response if $self->outputxml; 3789 3790 my $result = eval { $self->deserializer->deserialize($response) } 3791 if $response; 3792 3793 if (!$self->transport->is_success || # transport fault 3794 $@ || # not deserializible 3795 # fault message even if transport OK 3796 # or no transport error (for example, fo TCP, POP3, IO implementations) 3797 UNIVERSAL::isa($result => 'SOAP::SOM') && $result->fault) { 3798 return ($self->on_fault->($self, $@ 3799 ? $@ . ($response || '') 3800 : $result) 3801 || $result 3802 ); 3803 # ? # trick editors 3804 } 3805 # this might be trouble for connection close... 3806 return unless $response; # nothing to do for one-ways 3807 3808 # little bit tricky part that binds in/out parameters 3809 if (UNIVERSAL::isa($result => 'SOAP::SOM') 3810 && ($result->paramsout || $result->headers) 3811 && $serializer->signature) { 3812 my $num = 0; 3813 my %signatures = map {$_ => $num++} @{$serializer->signature}; 3814 for ($result->dataof(SOAP::SOM::paramsout), $result->dataof(SOAP::SOM::headers)) { 3815 my $signature = join $;, $_->name, $_->type || ''; 3816 if (exists $signatures{$signature}) { 3817 my $param = $signatures{$signature}; 3818 my($value) = $_->value; # take first value 3819 3820 # fillup parameters 3821 UNIVERSAL::isa($_[$param] => 'SOAP::Data') 3822 ? $_[$param]->SOAP::Data::value($value) 3823 : UNIVERSAL::isa($_[$param] => 'ARRAY') 3824 ? (@{$_[$param]} = @$value) 3825 : UNIVERSAL::isa($_[$param] => 'HASH') 3826 ? (%{$_[$param]} = %$value) 3827 : UNIVERSAL::isa($_[$param] => 'SCALAR') 3828 ? (${$_[$param]} = $$value) 3829 : ($_[$param] = $value) 3830 } 3831 } 3832 } 3833 return $result; 3834} # end of call() 3835 3836# ====================================================================== 3837 3838package SOAP::Lite::COM; 3839 3840require SOAP::Lite; 3841 3842sub required { 3843 foreach (qw( 3844 URI::_foreign URI::http URI::https 3845 LWP::Protocol::http LWP::Protocol::https LWP::Authen::Basic LWP::Authen::Digest 3846 HTTP::Daemon Compress::Zlib SOAP::Transport::HTTP 3847 XMLRPC::Lite XMLRPC::Transport::HTTP 3848 )) { 3849 eval join ';', 'local $SIG{__DIE__}', "require $_"; 3850 } 3851} 3852 3853sub new { required; SOAP::Lite->new(@_) } 3854 3855sub create; *create = \&new; # make alias. Somewhere 'new' is registered keyword 3856 3857sub soap; *soap = \&new; # also alias. Just to be consistent with .xmlrpc call 3858 3859sub xmlrpc { required; XMLRPC::Lite->new(@_) } 3860 3861sub server { required; shift->new(@_) } 3862 3863sub data { SOAP::Data->new(@_) } 3864 3865sub header { SOAP::Header->new(@_) } 3866 3867sub hash { +{@_} } 3868 3869sub instanceof { 3870 my $class = shift; 3871 die "Incorrect class name" unless $class =~ /^(\w[\w:]*)$/; 3872 eval "require $class"; 3873 $class->new(@_); 3874} 3875 3876# ====================================================================== 3877 38781; 3879 3880__END__ 3881 3882=pod 3883 3884=head1 NAME 3885 3886SOAP::Lite - Perl's Web Services Toolkit 3887 3888=head1 DESCRIPTION 3889 3890SOAP::Lite is a collection of Perl modules which provides a simple and 3891lightweight interface to the Simple Object Access Protocol (SOAP) both on 3892client and server side. 3893 3894=head1 PERL VERSION WARNING 3895 3896SOAP::Lite 0.71 will be the last version of SOAP::Lite running on perl 5.005 3897 3898Future versions of SOAP::Lite will require at least perl 5.6.0 3899 3900If you have not had the time to upgrad your perl, you should consider this 3901now. 3902 3903=head1 OVERVIEW OF CLASSES AND PACKAGES 3904 3905=over 3906 3907=item F<lib/SOAP/Lite.pm> 3908 3909L<SOAP::Lite> - Main class provides all logic 3910 3911L<SOAP::Transport> - Transport backend 3912 3913L<SOAP::Data> - Data objects 3914 3915L<SOAP::Header> - Header Data Objects 3916 3917L<SOAP::Serializer> - Serializes data structures to SOAP messages 3918 3919L<SOAP::Deserializer> - Deserializes SOAP messages into SOAP::SOM objects 3920 3921L<SOAP::SOM> - SOAP Message objects 3922 3923L<SOAP::Constants> - Provides access to common constants and defaults 3924 3925L<SOAP::Trace> - Tracing facilities 3926 3927L<SOAP::Schema> - Provides access and stub(s) for schema(s) 3928 3929L<SOAP::Schema::WSDL|SOAP::Schema/SOAP::Schema::WSDL> - WSDL implementation for SOAP::Schema 3930 3931L<SOAP::Server> - Handles requests on server side 3932 3933SOAP::Server::Object - Handles objects-by-reference 3934 3935L<SOAP::Fault> - Provides support for Faults on server side 3936 3937L<SOAP::Utils> - A set of private and public utility subroutines 3938 3939=item F<lib/SOAP/Packager.pm> 3940 3941L<SOAP::Packager> - Provides an abstract class for implementing custom packagers. 3942 3943L<SOAP::Packager::MIME|SOAP::Packager/SOAP::Packager::MIME> - Provides MIME support to SOAP::Lite 3944 3945L<SOAP::Packager::DIME|SOAP::Packager/SOAP::Packager::DIME> - Provides DIME support to SOAP::Lite 3946 3947=item F<lib/SOAP/Transport/HTTP.pm> 3948 3949L<SOAP::Transport::HTTP::Client|SOAP::Transport/SOAP::Transport::HTTP::Client> - Client interface to HTTP transport 3950 3951L<SOAP::Transport::HTTP::Server|SOAP::Transport/SOAP::Transport::HTTP::Server> - Server interface to HTTP transport 3952 3953L<SOAP::Transport::HTTP::CGI|SOAP::Transport/SOAP::Transport::HTTP::CGI> - CGI implementation of server interface 3954 3955L<SOAP::Transport::HTTP::Daemon|SOAP::Transport/SOAP::Transport::HTTP::Daemon> - Daemon implementation of server interface 3956 3957L<SOAP::Transport::HTTP::Apache|SOAP::Transport/SOAP::Transport::HTTP::Apache> - mod_perl implementation of server interface 3958 3959=item F<lib/SOAP/Transport/POP3.pm> 3960 3961L<SOAP::Transport::POP3::Server|SOAP::Transport/SOAP::Transport::POP3::Server> - Server interface to POP3 protocol 3962 3963=item F<lib/SOAP/Transport/MAILTO.pm> 3964 3965L<SOAP::Transport::MAILTO::Client|SOAP::Transport/SOAP::Transport::MAILTO::Client> - Client interface to SMTP/sendmail 3966 3967=item F<lib/SOAP/Transport/LOCAL.pm> 3968 3969L<SOAP::Transport::LOCAL::Client|SOAP::Transport/SOAP::Transport::LOCAL::Client> - Client interface to local transport 3970 3971=item F<lib/SOAP/Transport/TCP.pm> 3972 3973L<SOAP::Transport::TCP::Server|SOAP::Transport/SOAP::Transport::TCP::Server> - Server interface to TCP protocol 3974 3975L<SOAP::Transport::TCP::Client|SOAP::Transport/SOAP::Transport::TCP::Client> - Client interface to TCP protocol 3976 3977=item F<lib/SOAP/Transport/IO.pm> 3978 3979L<SOAP::Transport::IO::Server|SOAP::Transport/SOAP::Transport::IO::Server> - Server interface to IO transport 3980 3981=back 3982 3983=head1 METHODS 3984 3985All accessor methods return the current value when called with no arguments, 3986while returning the object reference itself when called with a new value. 3987This allows the set-attribute calls to be chained together. 3988 3989=over 3990 3991=item new(optional key/value pairs) 3992 3993 $client = SOAP::Lite->new(proxy => $endpoint) 3994 3995Constructor. Many of the accessor methods defined here may be initialized at 3996creation by providing their name as a key, followed by the desired value. 3997The example provides the value for the proxy element of the client. 3998 3999=item transport(optional transport object) 4000 4001 $transp = $client->transport( ); 4002 4003Gets or sets the transport object used for sending/receiving SOAP messages. 4004 4005See L<SOAP::Transport> for details. 4006 4007=item serializer(optional serializer object) 4008 4009 $serial = $client->serializer( ) 4010 4011Gets or sets the serializer object used for creating XML messages. 4012 4013See L<SOAP::Serializer> for details. 4014 4015=item packager(optional packager object) 4016 4017 $packager = $client->packager( ) 4018 4019Provides access to the C<SOAP::Packager> object that the client uses to manage 4020the use of attachments. The default packager is a MIME packager, but unless 4021you specify parts to send, no MIME formatting will be done. 4022 4023See also: L<SOAP::Packager>. 4024 4025=item proxy(endpoint, optional extra arguments) 4026 4027 $client->proxy('http://soap.xml.info/ endPoint'); 4028 4029The proxy is the server or endpoint to which the client is going to connect. 4030This method allows the setting of the endpoint, along with any extra 4031information that the transport object may need when communicating the request. 4032 4033This method is actually an alias to the proxy method of L<SOAP::Transport>. 4034It is the same as typing: 4035 4036 $client->transport( )->proxy(...arguments); 4037 4038Extra parameters can be passed to proxy() - see below. 4039 4040=over 4041 4042=item compress_threshold 4043 4044See L<COMPRESSION|SOAP::Transport/"COMPRESSION"> in L<HTTP::Transport>. 4045 4046=item All initialization options from the underlying transport layer 4047 4048The options for HTTP(S) are the same as for LWP::UserAgent's new() method. 4049 4050A common option is to create a instance of HTTP::Cookies and pass it as 4051cookie_jar option: 4052 4053 my $cookie_jar = HTTP::Cookies->new() 4054 $client->proxy('http://www.example.org/webservice', 4055 cookie_jar => $cookie_jar, 4056 ); 4057 4058=back 4059 4060For example, if you wish to set the HTTP timeout for a SOAP::Lite client to 5 4061seconds, use the following code: 4062 4063 my $soap = SOAP::Lite 4064 ->uri($uri) 4065 ->proxy($proxyUrl, timeout => 5 ); 4066 4067See L<LWP::UserAgent>. 4068 4069=item endpoint(optional new endpoint address) 4070 4071 $client->endpoint('http://soap.xml.info/ newPoint') 4072 4073It may be preferable to set a new endpoint without the additional work of 4074examining the new address for protocol information and checking to ensure the 4075support code is loaded and available. This method allows the caller to change 4076the endpoint that the client is currently set to connect to, without 4077reloading the relevant transport code. Note that the proxy method must have 4078been called before this method is used. 4079 4080=item service(service URL) 4081 4082 $client->service('http://svc.perl.org/Svc.wsdl'); 4083 4084C<SOAP::Lite> offers some support for creating method stubs from service 4085descriptions. At present, only WSDL support is in place. This method loads 4086the specified WSDL schema and uses it as the basis for generating stubs. 4087 4088=item outputxml(boolean) 4089 4090 $client->outputxml('true'); 4091 4092When set to a true value, the raw XML is returned by the call to a remote 4093method. 4094 4095The default is to return the a L<SOAP::SOM> object (false). 4096 4097=item autotype(boolean) 4098 4099 $client->autotype(0); 4100 4101This method is a shortcut for: 4102 4103 $client->serializer->autotype(boolean); 4104 4105By default, the serializer tries to automatically deduce types for the data 4106being sent in a message. Setting a false value with this method disables the 4107behavior. 4108 4109=item readable(boolean) 4110 4111 $client->readable(1); 4112 4113This method is a shortcut for: 4114 4115 $client->serializer->readable(boolean); 4116 4117When this is used to set a true value for this property, the generated XML 4118sent to the endpoint has extra characters (spaces and new lines) added in to 4119make the XML itself more readable to human eyes (presumably for debugging). 4120The default is to not send any additional characters. 4121 4122=item default_ns($uri) 4123 4124Sets the default namespace for the request to the specified uri. This 4125overrides any previous namespace declaration that may have been set using a 4126previous call to C<ns()> or C<default_ns()>. Setting the default namespace 4127causes elements to be serialized without a namespace prefix, like this: 4128 4129 <soap:Envelope> 4130 <soap:Body> 4131 <myMethod xmlns="http://www.someuri.com"> 4132 <foo /> 4133 </myMethod> 4134 </soap:Body> 4135 </soap:Envelope> 4136 4137Some .NET web services have been reported to require this XML namespace idiom. 4138 4139=item ns($uri,$prefix=undef) 4140 4141Sets the namespace uri and optionally the namespace prefix for the request to 4142the specified values. This overrides any previous namespace declaration that 4143may have been set using a previous call to C<ns()> or C<default_ns()>. 4144 4145If a prefix is not specified, one will be generated for you automatically. 4146Setting the namespace causes elements to be serialized with a declared 4147namespace prefix, like this: 4148 4149 <soap:Envelope> 4150 <soap:Body> 4151 <my:myMethod xmlns:my="http://www.someuri.com"> 4152 <my:foo /> 4153 </my:myMethod> 4154 </soap:Body> 4155 </soap:Envelope> 4156 4157=item use_prefix(boolean) 4158 4159Deprecated. Use the C<ns()> and C<default_ns> methods described above. 4160 4161Shortcut for C<< serializer->use_prefix() >>. This lets you turn on/off the 4162use of a namespace prefix for the children of the /Envelope/Body element. 4163Default is 'true'. 4164 4165When use_prefix is set to 'true', serialized XML will look like this: 4166 4167 <SOAP-ENV:Envelope ...attributes skipped> 4168 <SOAP-ENV:Body> 4169 <namesp1:mymethod xmlns:namesp1="urn:MyURI" /> 4170 </SOAP-ENV:Body> 4171 </SOAP-ENV:Envelope> 4172 4173When use_prefix is set to 'false', serialized XML will look like this: 4174 4175 <SOAP-ENV:Envelope ...attributes skipped> 4176 <SOAP-ENV:Body> 4177 <mymethod xmlns="urn:MyURI" /> 4178 </SOAP-ENV:Body> 4179 </SOAP-ENV:Envelope> 4180 4181Some .NET web services have been reported to require this XML namespace idiom. 4182 4183=item soapversion(optional value) 4184 4185 $client->soapversion('1.2'); 4186 4187If no parameter is given, returns the current version of SOAP that is being 4188used by the client object to encode requests. If a parameter is given, the 4189method attempts to set that as the version of SOAP being used. 4190 4191The value should be either 1.1 or 1.2. 4192 4193=item envprefix(QName) 4194 4195 $client->envprefix('env'); 4196 4197This method is a shortcut for: 4198 4199 $client->serializer->envprefix(QName); 4200 4201Gets or sets the namespace prefix for the SOAP namespace. The default is 4202SOAP. 4203 4204The prefix itself has no meaning, but applications may wish to chose one 4205explicitly to denote different versions of SOAP or the like. 4206 4207=item encprefix(QName) 4208 4209 $client->encprefix('enc'); 4210 4211This method is a shortcut for: 4212 4213 $client->serializer->encprefix(QName); 4214 4215Gets or sets the namespace prefix for the encoding rules namespace. 4216The default value is SOAP-ENC. 4217 4218=back 4219 4220While it may seem to be an unnecessary operation to set a value that isn't 4221relevant to the message, such as the namespace labels for the envelope and 4222encoding URNs, the ability to set these labels explicitly can prove to be a 4223great aid in distinguishing and debugging messages on the server side of 4224operations. 4225 4226=over 4227 4228=item encoding(encoding URN) 4229 4230 $client->encoding($soap_12_encoding_URN); 4231 4232This method is a shortcut for: 4233 4234 $client->serializer->encoding(args); 4235 4236Where the earlier method dealt with the label used for the attributes related 4237to the SOAP encoding scheme, this method actually sets the URN to be specified 4238as the encoding scheme for the message. The default is to specify the encoding 4239for SOAP 1.1, so this is handy for applications that need to encode according 4240to SOAP 1.2 rules. 4241 4242=item typelookup 4243 4244 $client->typelookup; 4245 4246This method is a shortcut for: 4247 4248 $client->serializer->typelookup; 4249 4250Gives the application access to the type-lookup table from the serializer 4251object. See the section on L<SOAP::Serializer>. 4252 4253=item uri(service specifier) 4254 4255Deprecated - the C<uri> subroutine is deprecated in order to provide a more 4256intuitive naming scheme for subroutines that set namespaces. In the future, 4257you will be required to use either the C<ns()> or C<default_ns()> subroutines 4258instead of C<uri()>. 4259 4260 $client->uri($service_uri); 4261 4262This method is a shortcut for: 4263 4264 $client->serializer->uri(service); 4265 4266The URI associated with this accessor on a client object is the 4267service-specifier for the request, often encoded for HTTP-based requests as 4268the SOAPAction header. While the names may seem confusing, this method 4269doesn't specify the endpoint itself. In most circumstances, the C<uri> refers 4270to the namespace used for the request. 4271 4272Often times, the value may look like a valid URL. Despite this, it doesn't 4273have to point to an existing resource (and often doesn't). This method sets 4274and retrieves this value from the object. Note that no transport code is 4275triggered by this because it has no direct effect on the transport of the 4276object. 4277 4278=item multirefinplace(boolean) 4279 4280 $client->multirefinplace(1); 4281 4282This method is a shortcut for: 4283 4284 $client->serializer->multirefinplace(boolean); 4285 4286Controls how the serializer handles values that have multiple references to 4287them. Recall from previous SOAP chapters that a value may be tagged with an 4288identifier, then referred to in several places. When this is the case for a 4289value, the serializer defaults to putting the data element towards the top of 4290the message, right after the opening tag of the method-specification. It is 4291serialized as a standalone entity with an ID that is then referenced at the 4292relevant places later on. If this method is used to set a true value, the 4293behavior is different. When the multirefinplace attribute is true, the data 4294is serialized at the first place that references it, rather than as a separate 4295element higher up in the body. This is more compact but may be harder to read 4296or trace in a debugging environment. 4297 4298=item parts( ARRAY ) 4299 4300Used to specify an array of L<MIME::Entity>'s to be attached to the 4301transmitted SOAP message. Attachments that are returned in a response can be 4302accessed by C<SOAP::SOM::parts()>. 4303 4304=item self 4305 4306 $ref = SOAP::Lite->self; 4307 4308Returns an object reference to the default global object the C<SOAP::Lite> 4309package maintains. This is the object that processes many of the arguments 4310when provided on the use line. 4311 4312=back 4313 4314The following method isn't an accessor style of method but neither does it fit 4315with the group that immediately follows it: 4316 4317=over 4318 4319=item call(arguments) 4320 4321 $client->call($method => @arguments); 4322 4323As has been illustrated in previous chapters, the C<SOAP::Lite> client objects 4324can manage remote calls with auto-dispatching using some of Perl's more 4325elaborate features. call is used when the application wants a greater degree 4326of control over the details of the call itself. The method may be built up 4327from a L<SOAP::Data> object, so as to allow full control over the namespace 4328associated with the tag, as well as other attributes like encoding. This is 4329also important for calling methods that contain characters not allowable in 4330Perl function names, such as A.B.C. 4331 4332=back 4333 4334The next four methods used in the C<SOAP::Lite> class are geared towards 4335handling the types of events than can occur during the message lifecycle. Each 4336of these sets up a callback for the event in question: 4337 4338=over 4339 4340=item on_action(callback) 4341 4342 $client->on_action(sub { qq("$_[0]") }); 4343 4344Triggered when the transport object sets up the SOAPAction header for an 4345HTTP-based call. The default is to set the header to the string, uri#method, 4346in which URI is the value set by the uri method described earlier, and method 4347is the name of the method being called. When called, the routine referenced 4348(or the closure, if specified as in the example) is given two arguments, uri 4349and method, in that order. 4350 4351.NET web services usually expect C</> as separator for C<uri> and C<method>. 4352To change SOAP::Lite's behaviour to use uri/method as SOAPAction header, use 4353the following code: 4354 4355 $client->on_action( sub { join '/', @_ } ); 4356=item on_fault(callback) 4357 4358 $client->on_fault(sub { popup_dialog($_[1]) }); 4359 4360Triggered when a method call results in a fault response from the server. 4361When it is called, the argument list is first the client object itself, 4362followed by the object that encapsulates the fault. In the example, the fault 4363object is passed (without the client object) to a hypothetical GUI function 4364that presents an error dialog with the text of fault extracted from the object 4365(which is covered shortly under the L<SOAP::SOM> methods). 4366 4367=item on_nonserialized(callback) 4368 4369 $client->on_nonserialized(sub { die "$_[0]?!?" }); 4370 4371Occasionally, the serializer may be given data it can't turn into SOAP-savvy 4372XML; for example, if a program bug results in a code reference or something 4373similar being passed in as a parameter to method call. When that happens, this 4374callback is activated, with one argument. That argument is the data item that 4375could not be understood. It will be the only argument. If the routine returns, 4376the return value is pasted into the message as the serialization. Generally, 4377an error is in order, and this callback allows for control over signaling that 4378error. 4379 4380=item on_debug(callback) 4381 4382 $client->on_debug(sub { print @_ }); 4383 4384Deprecated. Use the global +debug and +trace facilities described in 4385L<SOAP::Trace> 4386 4387Note that this method will not work as expected: Instead of affecting the 4388debugging behaviour of the object called on, it will globally affect the 4389debugging behaviour for all objects of that class. 4390 4391=back 4392 4393=head1 WRITING A SOAP CLIENT 4394 4395This chapter guides you to writing a SOAP client by example. 4396 4397The SOAP service to be accessed is a simple variation of the well-known 4398hello world program. It accepts two parameters, a name and a given name, 4399and returns "Hello $given_name $name". 4400 4401We will use "Martin Kutter" as the name for the call, so all variants will 4402print the following message on success: 4403 4404 Hello Martin Kutter! 4405 4406=head2 SOAP message styles 4407 4408There are three common (and one less common) variants of SOAP messages. 4409 4410These address the message style (positional parameters vs. specified message 4411documents) and encoding (as-is vs. typed). 4412 4413The different message styles are: 4414 4415=over 4416 4417=item * rpc/encoded 4418 4419Typed, positional parameters. Widely used in scripting languages. 4420The type of the arguments is included in the message. 4421Arrays and the like may be encoded using SOAP encoding rules (or others). 4422 4423=item * rpc/literal 4424 4425As-is, positional parameters. The type of arguments is defined by some 4426pre-exchanged interface definition. 4427 4428=item * document/encoded 4429 4430Specified message with typed elements. Rarely used. 4431 4432=item * document/literal 4433 4434Specified message with as-is elements. The message specification and 4435element types are defined by some pre-exchanged interface definition. 4436 4437=back 4438 4439As of 2008, document/literal has become the predominant SOAP message 4440variant. rpc/literal and rpc/encoded are still in use, mainly with scripting 4441languages, while document/encoded is hardly used at all. 4442 4443You will see clients for the rpc/encoded and document/literal SOAP variants in 4444this section. 4445 4446=head2 Example implementations 4447 4448=head3 RPC/ENCODED 4449 4450Rpc/encoded is most popular with scripting languages like perl, php and python 4451without the use of a WSDL. Usual method descriptions look like this: 4452 4453 Method: sayHello(string, string) 4454 Parameters: 4455 name: string 4456 givenName: string 4457 4458Such a description usually means that you can call a method named "sayHello" 4459with two positional parameters, "name" and "givenName", which both are 4460strings. 4461 4462The message corresponding to this description looks somewhat like this: 4463 4464 <sayHello xmlns="urn:HelloWorld"> 4465 <s-gensym01 xsi:type="xsd:string">Kutter</s-gensym01> 4466 <s-gensym02 xsi:type="xsd:string">Martin</s-gensym02> 4467 </sayHello> 4468 4469Any XML tag names may be used instead of the "s-gensym01" stuff - parameters 4470are positional, the tag names have no meaning. 4471 4472A client producing such a call is implemented like this: 4473 4474 use SOAP::Lite; 4475 my $soap = SOAP::Lite->new( proxy => 'http://localhost:81/soap-wsdl-test/helloworld.pl'); 4476 $soap->default_ns('urn:HelloWorld'); 4477 my $som = $soap->call('sayHello', 'Kutter', 'Martin'); 4478 die $som->faultstring if ($som->fault); 4479 print $som->result, "\n"; 4480 4481You can of course use a one-liner, too... 4482 4483Sometimes, rpc/encoded interfaces are described with WSDL definitions. 4484A WSDL accepting "named" parameters with rpc/encoded looks like this: 4485 4486 <definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" 4487 xmlns:s="http://www.w3.org/2001/XMLSchema" 4488 xmlns:s0="urn:HelloWorld" 4489 targetNamespace="urn:HelloWorld" 4490 xmlns="http://schemas.xmlsoap.org/wsdl/"> 4491 <types> 4492 <s:schema targetNamespace="urn:HelloWorld"> 4493 </s:schema> 4494 </types> 4495 <message name="sayHello"> 4496 <part name="name" type="s:string" /> 4497 <part name="givenName" type="s:string" /> 4498 </message> 4499 <message name="sayHelloResponse"> 4500 <part name="sayHelloResult" type="s:string" /> 4501 </message> 4502 4503 <portType name="Service1Soap"> 4504 <operation name="sayHello"> 4505 <input message="s0:sayHello" /> 4506 <output message="s0:sayHelloResponse" /> 4507 </operation> 4508 </portType> 4509 4510 <binding name="Service1Soap" type="s0:Service1Soap"> 4511 <soap:binding transport="http://schemas.xmlsoap.org/soap/http" 4512 style="rpc" /> 4513 <operation name="sayHello"> 4514 <soap:operation soapAction="urn:HelloWorld#sayHello"/> 4515 <input> 4516 <soap:body use="encoded" 4517 encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/> 4518 </input> 4519 <output> 4520 <soap:body use="encoded" 4521 encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/> 4522 </output> 4523 </operation> 4524 </binding> 4525 <service name="HelloWorld"> 4526 <port name="HelloWorldSoap" binding="s0:Service1Soap"> 4527 <soap:address location="http://localhost:81/soap-wsdl-test/helloworld.pl" /> 4528 </port> 4529 </service> 4530 </definitions> 4531 4532The message corresponding to this schema looks like this: 4533 4534 <sayHello xmlns="urn:HelloWorld"> 4535 <name xsi:type="xsd:string">Kutter</name> 4536 <givenName xsi:type="xsd:string">Martin</givenName> 4537 </sayHello> 4538 4539A web service client using this schema looks like this: 4540 4541 use SOAP::Lite; 4542 my $soap = SOAP::Lite->service("file:say_hello_rpcenc.wsdl"); 4543 eval { my $result = $soap->sayHello('Kutter', 'Martin'); }; 4544 if ($@) { 4545 die $@; 4546 } 4547 print $som->result(); 4548 4549You may of course also use the following one-liner: 4550 4551 perl -MSOAP::Lite -e 'print SOAP::Lite->service("file:say_hello_rpcenc.wsdl")\ 4552 ->sayHello('Kutter', 'Martin'), "\n";' 4553 4554A web service client (without a service description) looks like this. 4555 4556 use SOAP::Lite; 4557 my $soap = SOAP::Lite->new( proxy => 'http://localhost:81/soap-wsdl-test/helloworld.pl'); 4558 $soap->default_ns('urn:HelloWorld'); 4559 my $som = $soap->call('sayHello', 4560 SOAP::Data->name('name')->value('Kutter'), 4561 SOAP::Data->name('givenName')->value('Martin') 4562 ); 4563 die $som->faultstring if ($som->fault); 4564 print $som->result, "\n"; 4565 4566=head3 RPC/LITERAL 4567 4568SOAP web services using the document/literal message encoding are usually 4569described by some Web Service Definition. Our web service has the following 4570WSDL description: 4571 4572 <definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" 4573 xmlns:s="http://www.w3.org/2001/XMLSchema" 4574 xmlns:s0="urn:HelloWorld" 4575 targetNamespace="urn:HelloWorld" 4576 xmlns="http://schemas.xmlsoap.org/wsdl/"> 4577 <types> 4578 <s:schema targetNamespace="urn:HelloWorld"> 4579 <s:complexType name="sayHello"> 4580 <s:sequence> 4581 <s:element minOccurs="0" maxOccurs="1" name="name" 4582 type="s:string" /> 4583 <s:element minOccurs="0" maxOccurs="1" name="givenName" 4584 type="s:string" nillable="1" /> 4585 </s:sequence> 4586 </s:complexType> 4587 4588 <s:complexType name="sayHelloResponse"> 4589 <s:sequence> 4590 <s:element minOccurs="0" maxOccurs="1" name="sayHelloResult" 4591 type="s:string" /> 4592 </s:sequence> 4593 </s:complexType> 4594 </s:schema> 4595 </types> 4596 <message name="sayHello"> 4597 <part name="parameters" type="s0:sayHello" /> 4598 </message> 4599 <message name="sayHelloResponse"> 4600 <part name="parameters" type="s0:sayHelloResponse" /> 4601 </message> 4602 4603 <portType name="Service1Soap"> 4604 <operation name="sayHello"> 4605 <input message="s0:sayHello" /> 4606 <output message="s0:sayHelloResponse" /> 4607 </operation> 4608 </portType> 4609 4610 <binding name="Service1Soap" type="s0:Service1Soap"> 4611 <soap:binding transport="http://schemas.xmlsoap.org/soap/http" 4612 style="rpc" /> 4613 <operation name="sayHello"> 4614 <soap:operation soapAction="urn:HelloWorld#sayHello"/> 4615 <input> 4616 <soap:body use="literal" namespace="urn:HelloWorld"/> 4617 </input> 4618 <output> 4619 <soap:body use="literal" namespace="urn:HelloWorld"/> 4620 </output> 4621 </operation> 4622 </binding> 4623 <service name="HelloWorld"> 4624 <port name="HelloWorldSoap" binding="s0:Service1Soap"> 4625 <soap:address location="http://localhost:80//helloworld.pl" /> 4626 </port> 4627 </service> 4628 </definitions> 4629 4630The XML message (inside the SOAP Envelope) look like this: 4631 4632 4633 <ns0:sayHello xmlns:ns0="urn:HelloWorld"> 4634 <parameters> 4635 <name>Kutter</name> 4636 <givenName>Martin</givenName> 4637 </parameters> 4638 </ns0:sayHello> 4639 4640 <sayHelloResponse xmlns:ns0="urn:HelloWorld"> 4641 <parameters> 4642 <sayHelloResult>Hello Martin Kutter!</sayHelloResult> 4643 </parameters> 4644 </sayHelloResponse> 4645 4646This is the SOAP::Lite implementation for the web service client: 4647 4648 use SOAP::Lite +trace; 4649 my $soap = SOAP::Lite->new( proxy => 'http://localhost:80/helloworld.pl'); 4650 4651 $soap->on_action( sub { "urn:HelloWorld#sayHello" }); 4652 $soap->autotype(0)->readable(1); 4653 $soap->default_ns('urn:HelloWorld'); 4654 4655 my $som = $soap->call('sayHello', SOAP::Data->name('parameters')->value( 4656 \SOAP::Data->value([ 4657 SOAP::Data->name('name')->value( 'Kutter' ), 4658 SOAP::Data->name('givenName')->value('Martin'), 4659 ])) 4660); 4661 4662 die $som->fault->{ faultstring } if ($som->fault); 4663 print $som->result, "\n"; 4664 4665=head3 DOCUMENT/LITERAL 4666 4667SOAP web services using the document/literal message encoding are usually 4668described by some Web Service Definition. Our web service has the following 4669WSDL description: 4670 4671 <definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" 4672 xmlns:s="http://www.w3.org/2001/XMLSchema" 4673 xmlns:s0="urn:HelloWorld" 4674 targetNamespace="urn:HelloWorld" 4675 xmlns="http://schemas.xmlsoap.org/wsdl/"> 4676 <types> 4677 <s:schema targetNamespace="urn:HelloWorld"> 4678 <s:element name="sayHello"> 4679 <s:complexType> 4680 <s:sequence> 4681 <s:element minOccurs="0" maxOccurs="1" name="name" type="s:string" /> 4682 <s:element minOccurs="0" maxOccurs="1" name="givenName" type="s:string" nillable="1" /> 4683 </s:sequence> 4684 </s:complexType> 4685 </s:element> 4686 4687 <s:element name="sayHelloResponse"> 4688 <s:complexType> 4689 <s:sequence> 4690 <s:element minOccurs="0" maxOccurs="1" name="sayHelloResult" type="s:string" /> 4691 </s:sequence> 4692 </s:complexType> 4693 </s:element> 4694 </types> 4695 <message name="sayHelloSoapIn"> 4696 <part name="parameters" element="s0:sayHello" /> 4697 </message> 4698 <message name="sayHelloSoapOut"> 4699 <part name="parameters" element="s0:sayHelloResponse" /> 4700 </message> 4701 4702 <portType name="Service1Soap"> 4703 <operation name="sayHello"> 4704 <input message="s0:sayHelloSoapIn" /> 4705 <output message="s0:sayHelloSoapOut" /> 4706 </operation> 4707 </portType> 4708 4709 <binding name="Service1Soap" type="s0:Service1Soap"> 4710 <soap:binding transport="http://schemas.xmlsoap.org/soap/http" 4711 style="document" /> 4712 <operation name="sayHello"> 4713 <soap:operation soapAction="urn:HelloWorld#sayHello"/> 4714 <input> 4715 <soap:body use="literal" /> 4716 </input> 4717 <output> 4718 <soap:body use="literal" /> 4719 </output> 4720 </operation> 4721 </binding> 4722 <service name="HelloWorld"> 4723 <port name="HelloWorldSoap" binding="s0:Service1Soap"> 4724 <soap:address location="http://localhost:80//helloworld.pl" /> 4725 </port> 4726 </service> 4727 </definitions> 4728 4729The XML message (inside the SOAP Envelope) look like this: 4730 4731 <sayHello xmlns="urn:HelloWorld"> 4732 <name>Kutter</name> 4733 <givenName>Martin</givenName> 4734 </sayHello> 4735 4736 <sayHelloResponse> 4737 <sayHelloResult>Hello Martin Kutter!</sayHelloResult> 4738 </sayHelloResponse> 4739 4740You can call this web service with the following client code: 4741 4742 use SOAP::Lite; 4743 my $soap = SOAP::Lite->new( proxy => 'http://localhost:80/helloworld.pl'); 4744 4745 $soap->on_action( sub { "urn:HelloWorld#sayHello" }); 4746 $soap->autotype(0); 4747 $soap->default_ns('urn:HelloWorld'); 4748 4749 my $som = $soap->call("sayHello", 4750 SOAP::Data->name('name')->value( 'Kutter' ), 4751 SOAP::Data->name('givenName')->value('Martin'), 4752); 4753 4754 die $som->fault->{ faultstring } if ($som->fault); 4755 print $som->result, "\n"; 4756 4757=head2 Differences between the implementations 4758 4759You may have noticed that there's little difference between the rpc/encoded, 4760rpc/literal and the document/literal example's implementation. In fact, from 4761SOAP::Lite's point of view, the only differences between rpc/literal and 4762document/literal that parameters are always named. 4763 4764In our example, the rpc/encoded variant already used named parameters (by 4765using two messages), so there's no difference at all. 4766 4767You may have noticed the somewhat strange idiom for passing a list of named 4768paraneters in the rpc/literal example: 4769 4770 my $som = $soap->call('sayHello', SOAP::Data->name('parameters')->value( 4771 \SOAP::Data->value([ 4772 SOAP::Data->name('name')->value( 'Kutter' ), 4773 SOAP::Data->name('givenName')->value('Martin'), 4774 ])) 4775 ); 4776 4777While SOAP::Data provides full control over the XML generated, passing 4778hash-like structures require additional coding. 4779 4780=head1 WRITING A SOAP SERVER 4781 4782See L<SOAP::Server>, or L<SOAP::Transport>. 4783 4784=head1 FEATURES 4785 4786=head2 ATTACHMENTS 4787 4788C<SOAP::Lite> features support for the SOAP with Attachments specification. 4789Currently, SOAP::Lite only supports MIME based attachments. DIME based 4790attachments are yet to be fully functional. 4791 4792=head3 EXAMPLES 4793 4794=head4 Client sending an attachment 4795 4796C<SOAP::Lite> clients can specify attachments to be sent along with a request 4797by using the C<SOAP::Lite::parts()> method, which takes as an argument an 4798ARRAY of C<MIME::Entity>'s. 4799 4800 use SOAP::Lite; 4801 use MIME::Entity; 4802 my $ent = build MIME::Entity 4803 Type => "image/gif", 4804 Encoding => "base64", 4805 Path => "somefile.gif", 4806 Filename => "saveme.gif", 4807 Disposition => "attachment"; 4808 my $som = SOAP::Lite 4809 ->uri($SOME_NAMESPACE) 4810 ->parts([ $ent ]) 4811 ->proxy($SOME_HOST) 4812 ->some_method(SOAP::Data->name("foo" => "bar")); 4813 4814=head4 Client retrieving an attachment 4815 4816A client accessing attachments that were returned in a response by using the 4817C<SOAP::SOM::parts()> accessor. 4818 4819 use SOAP::Lite; 4820 use MIME::Entity; 4821 my $soap = SOAP::Lite 4822 ->uri($NS) 4823 ->proxy($HOST); 4824 my $som = $soap->foo(); 4825 foreach my $part (${$som->parts}) { 4826 print $part->stringify; 4827 } 4828 4829=head4 Server receiving an attachment 4830 4831Servers, like clients, use the S<SOAP::SOM> module to access attachments 4832transmitted to it. 4833 4834 package Attachment; 4835 use SOAP::Lite; 4836 use MIME::Entity; 4837 use strict; 4838 use vars qw(@ISA); 4839 @ISA = qw(SOAP::Server::Parameters); 4840 sub someMethod { 4841 my $self = shift; 4842 my $envelope = pop; 4843 foreach my $part (@{$envelope->parts}) { 4844 print "AttachmentService: attachment found! (".ref($part).")\n"; 4845 } 4846 # do something 4847 } 4848 4849=head4 Server responding with an attachment 4850 4851Servers wishing to return an attachment to the calling client need only return 4852C<MIME::Entity> objects along with SOAP::Data elements, or any other data 4853intended for the response. 4854 4855 package Attachment; 4856 use SOAP::Lite; 4857 use MIME::Entity; 4858 use strict; 4859 use vars qw(@ISA); 4860 @ISA = qw(SOAP::Server::Parameters); 4861 sub someMethod { 4862 my $self = shift; 4863 my $envelope = pop; 4864 my $ent = build MIME::Entity 4865 'Id' => "<1234>", 4866 'Type' => "text/xml", 4867 'Path' => "some.xml", 4868 'Filename' => "some.xml", 4869 'Disposition' => "attachment"; 4870 return SOAP::Data->name("foo" => "blah blah blah"),$ent; 4871 } 4872 4873=head2 DEFAULT SETTINGS 4874 4875Though this feature looks similar to 4876L<autodispatch|/"IN/OUT, OUT PARAMETERS AND AUTOBINDING"> they have (almost) 4877nothing in common. This capability allows you specify default settings so that 4878all objects created after that will be initialized with the proper default 4879settings. 4880 4881If you wish to provide common C<proxy()> or C<uri()> settings for all 4882C<SOAP::Lite> objects in your application you may do: 4883 4884 use SOAP::Lite 4885 proxy => 'http://localhost/cgi-bin/soap.cgi', 4886 uri => 'http://my.own.com/My/Examples'; 4887 4888 my $soap1 = new SOAP::Lite; # will get the same proxy()/uri() as above 4889 print $soap1->getStateName(1)->result; 4890 4891 my $soap2 = SOAP::Lite->new; # same thing as above 4892 print $soap2->getStateName(2)->result; 4893 4894 # or you may override any settings you want 4895 my $soap3 = SOAP::Lite->proxy('http://localhost/'); 4896 print $soap3->getStateName(1)->result; 4897 4898B<Any> C<SOAP::Lite> properties can be propagated this way. Changes in object 4899copies will not affect global settings and you may still change global 4900settings with C<< SOAP::Lite->self >> call which returns reference to global 4901object. Provided parameter will update this object and you can even set it to 4902C<undef>: 4903 4904 SOAP::Lite->self(undef); 4905 4906The C<use SOAP::Lite> syntax also lets you specify default event handlers for 4907your code. If you have different SOAP objects and want to share the same 4908C<on_action()> (or C<on_fault()> for that matter) handler. You can specify 4909C<on_action()> during initialization for every object, but you may also do: 4910 4911 use SOAP::Lite 4912 on_action => sub {sprintf '%s#%s', @_}; 4913 4914and this handler will be the default handler for all your SOAP objects. You 4915can override it if you specify a handler for a particular object. See F<t/*.t> 4916for example of on_fault() handler. 4917 4918Be warned, that since C<use ...> is executed at compile time B<all> C<use> 4919statements will be executed B<before> script execution that can make 4920unexpected results. Consider code: 4921 4922 use SOAP::Lite proxy => 'http://localhost/'; 4923 print SOAP::Lite->getStateName(1)->result; 4924 4925 use SOAP::Lite proxy => 'http://localhost/cgi-bin/soap.cgi'; 4926 print SOAP::Lite->getStateName(1)->result; 4927 4928B<Both> SOAP calls will go to C<'http://localhost/cgi-bin/soap.cgi'>. If you 4929want to execute C<use> at run-time, put it in C<eval>: 4930 4931 eval "use SOAP::Lite proxy => 'http://localhost/cgi-bin/soap.cgi'; 1" or die; 4932 4933Or alternatively, 4934 4935 SOAP::Lite->self->proxy('http://localhost/cgi-bin/soap.cgi'); 4936 4937=head2 SETTING MAXIMUM MESSAGE SIZE 4938 4939One feature of C<SOAP::Lite> is the ability to control the maximum size of a 4940message a SOAP::Lite server will be allowed to process. To control this 4941feature simply define C<$SOAP::Constants::MAX_CONTENT_SIZE> in your code like 4942so: 4943 4944 use SOAP::Transport::HTTP; 4945 use MIME::Entity; 4946 $SOAP::Constants::MAX_CONTENT_SIZE = 10000; 4947 SOAP::Transport::HTTP::CGI 4948 ->dispatch_to('TemperatureService') 4949 ->handle; 4950 4951=head2 IN/OUT, OUT PARAMETERS AND AUTOBINDING 4952 4953C<SOAP::Lite> gives you access to all parameters (both in/out and out) and 4954also does some additional work for you. Lets consider following example: 4955 4956 <mehodResponse> 4957 <res1>name1</res1> 4958 <res2>name2</res2> 4959 <res3>name3</res3> 4960 </mehodResponse> 4961 4962In that case: 4963 4964 $result = $r->result; # gives you 'name1' 4965 $paramout1 = $r->paramsout; # gives you 'name2', because of scalar context 4966 $paramout1 = ($r->paramsout)[0]; # gives you 'name2' also 4967 $paramout2 = ($r->paramsout)[1]; # gives you 'name3' 4968 4969or 4970 4971 @paramsout = $r->paramsout; # gives you ARRAY of out parameters 4972 $paramout1 = $paramsout[0]; # gives you 'res2', same as ($r->paramsout)[0] 4973 $paramout2 = $paramsout[1]; # gives you 'res3', same as ($r->paramsout)[1] 4974 4975Generally, if server returns C<return (1,2,3)> you will get C<1> as the result 4976and C<2> and C<3> as out parameters. 4977 4978If the server returns C<return [1,2,3]> you will get an ARRAY reference from 4979C<result()> and C<undef> from C<paramsout()>. 4980 4981Results can be arbitrary complex: they can be an array references, they can be 4982objects, they can be anything and still be returned by C<result()> . If only 4983one parameter is returned, C<paramsout()> will return C<undef>. 4984 4985Furthermore, if you have in your output parameters a parameter with the same 4986signature (name+type) as in the input parameters this parameter will be mapped 4987into your input automatically. For example: 4988 4989B<Server Code>: 4990 4991 sub mymethod { 4992 shift; # object/class reference 4993 my $param1 = shift; 4994 my $param2 = SOAP::Data->name('myparam' => shift() * 2); 4995 return $param1, $param2; 4996 } 4997 4998B<Client Code>: 4999 5000 $a = 10; 5001 $b = SOAP::Data->name('myparam' => 12); 5002 $result = $soap->mymethod($a, $b); 5003 5004After that, C<< $result == 10 and $b->value == 24 >>! Magic? Sort of. 5005 5006Autobinding gives it to you. That will work with objects also with one 5007difference: you do not need to worry about the name and the type of object 5008parameter. Consider the C<PingPong> example (F<examples/My/PingPong.pm> 5009and F<examples/pingpong.pl>): 5010 5011B<Server Code>: 5012 5013 package My::PingPong; 5014 5015 sub new { 5016 my $self = shift; 5017 my $class = ref($self) || $self; 5018 bless {_num=>shift} => $class; 5019 } 5020 5021 sub next { 5022 my $self = shift; 5023 $self->{_num}++; 5024 } 5025 5026B<Client Code>: 5027 5028 use SOAP::Lite +autodispatch => 5029 uri => 'urn:', 5030 proxy => 'http://localhost/'; 5031 5032 my $p = My::PingPong->new(10); # $p->{_num} is 10 now, real object returned 5033 print $p->next, "\n"; # $p->{_num} is 11 now!, object autobinded 5034 5035=head2 STATIC AND DYNAMIC SERVICE DEPLOYMENT 5036 5037Let us scrutinize the deployment process. When designing your SOAP server you 5038can consider two kind of deployment: B<static> and B<dynamic>. For both, 5039static and dynamic, you should specify C<MODULE>, C<MODULE::method>, 5040C<method> or C<PATH/> when creating C<use>ing the SOAP::Lite module. The 5041difference between static and dynamic deployment is that in case of 'dynamic', 5042any module which is not present will be loaded on demand. See the 5043L</"SECURITY"> section for detailed description. 5044 5045When statically deploying a SOAP Server, you need to know all modules handling 5046SOAP requests before. 5047 5048Dynamic deployment allows extending your SOAP Server's interface by just 5049installing another module into the dispatch_to path (see below). 5050 5051=head3 STATIC DEPLOYMENT EXAMPLE 5052 5053 use SOAP::Transport::HTTP; 5054 use My::Examples; # module is preloaded 5055 5056 SOAP::Transport::HTTP::CGI 5057 # deployed module should be present here or client will get 5058 # 'access denied' 5059 -> dispatch_to('My::Examples') 5060 -> handle; 5061 5062For static deployment you should specify the MODULE name directly. 5063 5064You should also use static binding when you have several different classes in 5065one file and want to make them available for SOAP calls. 5066 5067=head3 DYNAMIC DEPLOYMENT EXAMPLE 5068 5069 use SOAP::Transport::HTTP; 5070 # name is unknown, module will be loaded on demand 5071 5072 SOAP::Transport::HTTP::CGI 5073 # deployed module should be present here or client will get 'access denied' 5074 -> dispatch_to('/Your/Path/To/Deployed/Modules', 'My::Examples') 5075 -> handle; 5076 5077For dynamic deployment you can specify the name either directly (in that case 5078it will be C<require>d without any restriction) or indirectly, with a PATH. In 5079that case, the ONLY path that will be available will be the PATH given to the 5080dispatch_to() method). For information how to handle this situation see 5081L</"SECURITY"> section. 5082 5083=head3 SUMMARY 5084 5085 dispatch_to( 5086 # dynamic dispatch that allows access to ALL modules in specified directory 5087 PATH/TO/MODULES 5088 # 1. specifies directory 5089 # -- AND -- 5090 # 2. gives access to ALL modules in this directory without limits 5091 5092 # static dispatch that allows access to ALL methods in particular MODULE 5093 MODULE 5094 # 1. gives access to particular module (all available methods) 5095 # PREREQUISITES: 5096 # module should be loaded manually (for example with 'use ...') 5097 # -- OR -- 5098 # you can still specify it in PATH/TO/MODULES 5099 5100 # static dispatch that allows access to particular method ONLY 5101 MODULE::method 5102 # same as MODULE, but gives access to ONLY particular method, 5103 # so there is not much sense to use both MODULE and MODULE::method 5104 # for the same MODULE 5105 ); 5106 5107In addition to this C<SOAP::Lite> also supports an experimental syntax that 5108allows you to bind a specific URL or SOAPAction to a CLASS/MODULE or object. 5109 5110For example: 5111 5112 dispatch_with({ 5113 URI => MODULE, # 'http://www.soaplite.com/' => 'My::Class', 5114 SOAPAction => MODULE, # 'http://www.soaplite.com/method' => 'Another::Class', 5115 URI => object, # 'http://www.soaplite.com/obj' => My::Class->new, 5116 }) 5117 5118C<URI> is checked before C<SOAPAction>. You may use both the C<dispatch_to()> 5119and C<dispatch_with()> methods in the same server, but note that 5120C<dispatch_with()> has a higher order of precedence. C<dispatch_to()> will be 5121checked only after C<URI> and C<SOAPAction> has been checked. 5122 5123See also: 5124L<EXAMPLE APACHE::REGISTRY USAGE|SOAP::Transport/"EXAMPLE APACHE::REGISTRY USAGE">, 5125L</"SECURITY"> 5126 5127=head2 COMPRESSION 5128 5129C<SOAP::Lite> provides you option to enable transparent compression over the 5130wire. Compression can be enabled by specifying a threshold value (in the form 5131of kilobytes) for compression on both the client and server sides: 5132 5133I<Note: Compression currently only works for HTTP based servers and clients.> 5134 5135B<Client Code> 5136 5137 print SOAP::Lite 5138 ->uri('http://localhost/My/Parameters') 5139 ->proxy('http://localhost/', options => {compress_threshold => 10000}) 5140 ->echo(1 x 10000) 5141 ->result; 5142 5143B<Server Code> 5144 5145 my $server = SOAP::Transport::HTTP::CGI 5146 ->dispatch_to('My::Parameters') 5147 ->options({compress_threshold => 10000}) 5148 ->handle; 5149 5150For more information see L<COMPRESSION|SOAP::Transport/"COMPRESSION"> in 5151L<HTTP::Transport>. 5152 5153=head1 SECURITY 5154 5155For security reasons, the exisiting path for Perl modules (C<@INC>) will be 5156disabled once you have chosen dynamic deployment and specified your own 5157C<PATH/>. If you wish to access other modules in your included package you 5158have several options: 5159 5160=over 4 5161 5162=item 1 5163 5164Switch to static linking: 5165 5166 use MODULE; 5167 $server->dispatch_to('MODULE'); 5168 5169Which can also be useful when you want to import something specific from the 5170deployed modules: 5171 5172 use MODULE qw(import_list); 5173 5174=item 2 5175 5176Change C<use> to C<require>. The path is only unavailable during the 5177initialization phase. It is available once more during execution. Therefore, 5178if you utilize C<require> somewhere in your package, it will work. 5179 5180=item 3 5181 5182Wrap C<use> in an C<eval> block: 5183 5184 eval 'use MODULE qw(import_list)'; die if $@; 5185 5186=item 4 5187 5188Set your include path in your package and then specify C<use>. Don't forget to 5189put C<@INC> in a C<BEGIN{}> block or it won't work. For example, 5190 5191 BEGIN { @INC = qw(my_directory); use MODULE } 5192 5193=back 5194 5195=head1 INTEROPERABILITY 5196 5197=head2 Microsoft .NET client with SOAP::Lite Server 5198 5199In order to use a .NET client with a SOAP::Lite server, be sure you use fully 5200qualified names for your return values. For example: 5201 5202 return SOAP::Data->name('myname') 5203 ->type('string') 5204 ->uri($MY_NAMESPACE) 5205 ->value($output); 5206 5207In addition see comment about default incoding in .NET Web Services below. 5208 5209=head2 SOAP::Lite client with a .NET server 5210 5211If experiencing problems when using a SOAP::Lite client to call a .NET Web 5212service, it is recommended you check, or adhere to all of the following 5213recommendations: 5214 5215=over 4 5216 5217=item Declare a proper soapAction in your call 5218 5219For example, use 5220C<on_action( sub { 'http://www.myuri.com/WebService.aspx#someMethod'; } )>. 5221 5222=item Disable charset definition in Content-type header 5223 5224Some users have said that Microsoft .NET prefers the value of 5225the Content-type header to be a mimetype exclusively, but SOAP::Lite specifies 5226a character set in addition to the mimetype. This results in an error similar 5227to: 5228 5229 Server found request content type to be 'text/xml; charset=utf-8', 5230 but expected 'text/xml' 5231 5232To turn off this behavior specify use the following code: 5233 5234 use SOAP::Lite; 5235 $SOAP::Constants::DO_NOT_USE_CHARSET = 1; 5236 # The rest of your code 5237 5238=item Use fully qualified name for method parameters 5239 5240For example, the following code is preferred: 5241 5242 SOAP::Data->name(Query => 'biztalk') 5243 ->uri('http://tempuri.org/') 5244 5245As opposed to: 5246 5247 SOAP::Data->name('Query' => 'biztalk') 5248 5249=item Place method in default namespace 5250 5251For example, the following code is preferred: 5252 5253 my $method = SOAP::Data->name('add') 5254 ->attr({xmlns => 'http://tempuri.org/'}); 5255 my @rc = $soap->call($method => @parms)->result; 5256 5257As opposed to: 5258 5259 my @rc = $soap->call(add => @parms)->result; 5260 # -- OR -- 5261 my @rc = $soap->add(@parms)->result; 5262 5263=item Disable use of explicit namespace prefixes 5264 5265Some user's have reported that .NET will simply not parse messages that use 5266namespace prefixes on anything but SOAP elements themselves. For example, the 5267following XML would not be parsed: 5268 5269 <SOAP-ENV:Envelope ...attributes skipped> 5270 <SOAP-ENV:Body> 5271 <namesp1:mymethod xmlns:namesp1="urn:MyURI" /> 5272 </SOAP-ENV:Body> 5273 </SOAP-ENV:Envelope> 5274 5275SOAP::Lite allows users to disable the use of explicit namespaces through the 5276C<use_prefix()> method. For example, the following code: 5277 5278 $som = SOAP::Lite->uri('urn:MyURI') 5279 ->proxy($HOST) 5280 ->use_prefix(0) 5281 ->myMethod(); 5282 5283Will result in the following XML, which is more pallatable by .NET: 5284 5285 <SOAP-ENV:Envelope ...attributes skipped> 5286 <SOAP-ENV:Body> 5287 <mymethod xmlns="urn:MyURI" /> 5288 </SOAP-ENV:Body> 5289 </SOAP-ENV:Envelope> 5290 5291=item Modify your .NET server, if possible 5292 5293Stefan Pharies <stefanph@microsoft.com>: 5294 5295SOAP::Lite uses the SOAP encoding (section 5 of the soap 1.1 spec), and 5296the default for .NET Web Services is to use a literal encoding. So 5297elements in the request are unqualified, but your service expects them to 5298be qualified. .Net Web Services has a way for you to change the expected 5299message format, which should allow you to get your interop working. 5300At the top of your class in the asmx, add this attribute (for Beta 1): 5301 5302 [SoapService(Style=SoapServiceStyle.RPC)] 5303 5304Another source said it might be this attribute (for Beta 2): 5305 5306 [SoapRpcService] 5307 5308Full Web Service text may look like: 5309 5310 <%@ WebService Language="C#" Class="Test" %> 5311 using System; 5312 using System.Web.Services; 5313 using System.Xml.Serialization; 5314 5315 [SoapService(Style=SoapServiceStyle.RPC)] 5316 public class Test : WebService { 5317 [WebMethod] 5318 public int add(int a, int b) { 5319 return a + b; 5320 } 5321 } 5322 5323Another example from Kirill Gavrylyuk <kirillg@microsoft.com>: 5324 5325"You can insert [SoapRpcService()] attribute either on your class or on 5326operation level". 5327 5328 <%@ WebService Language=CS class="DataType.StringTest"%> 5329 5330 namespace DataType { 5331 5332 using System; 5333 using System.Web.Services; 5334 using System.Web.Services.Protocols; 5335 using System.Web.Services.Description; 5336 5337 [SoapRpcService()] 5338 public class StringTest: WebService { 5339 [WebMethod] 5340 [SoapRpcMethod()] 5341 public string RetString(string x) { 5342 return(x); 5343 } 5344 } 5345 } 5346 5347Example from Yann Christensen <yannc@microsoft.com>: 5348 5349 using System; 5350 using System.Web.Services; 5351 using System.Web.Services.Protocols; 5352 5353 namespace Currency { 5354 [WebService(Namespace="http://www.yourdomain.com/example")] 5355 [SoapRpcService] 5356 public class Exchange { 5357 [WebMethod] 5358 public double getRate(String country, String country2) { 5359 return 122.69; 5360 } 5361 } 5362 } 5363 5364=back 5365 5366Special thanks goes to the following people for providing the above 5367description and details on .NET interoperability issues: 5368 5369Petr Janata <petr.janata@i.cz>, 5370 5371Stefan Pharies <stefanph@microsoft.com>, 5372 5373Brian Jepson <bjepson@jepstone.net>, and others 5374 5375=head1 TROUBLESHOOTING 5376 5377=over 4 5378 5379=item SOAP::Lite serializes "18373" as an integer, but I want it to be a string! 5380 5381SOAP::Lite guesses datatypes from the content provided, using a set of 5382common-sense rules. These rules are not 100% reliable, though they fit for 5383most data. 5384 5385You may force the type by passing a SOAP::Data object with a type specified: 5386 5387 my $proxy = SOAP::Lite->proxy('http://www.example.org/soapservice'); 5388 my $som = $proxy->myMethod( 5389 SOAP::Data->name('foo')->value(12345)->type('string') 5390 ); 5391 5392You may also change the precedence of the type-guessing rules. Note that this 5393means fiddling with SOAP::Lite's internals - this may not work as 5394expected in future versions. 5395 5396The example above forces everything to be encoded as string (this is because 5397the string test is normally last and allways returns true): 5398 5399 my @list = qw(-1 45 foo bar 3838); 5400 my $proxy = SOAP::Lite->uri($uri)->proxy($proxyUrl); 5401 my $lookup = $proxy->serializer->typelookup; 5402 $lookup->{string}->[0] = 0; 5403 $proxy->serializer->typelookup($lookup); 5404 $proxy->myMethod(\@list); 5405 5406See L<SOAP::Serializer|SOAP::Serializer/AUTOTYPING> for more details. 5407 5408=item C<+autodispatch> doesn't work in Perl 5.8 5409 5410There is a bug in Perl 5.8's C<UNIVERSAL::AUTOLOAD> functionality that 5411prevents the C<+autodispatch> functionality from working properly. The 5412workaround is to use C<dispatch_from> instead. Where you might normally do 5413something like this: 5414 5415 use Some::Module; 5416 use SOAP::Lite +autodispatch => 5417 uri => 'urn:Foo' 5418 proxy => 'http://...'; 5419 5420You would do something like this: 5421 5422 use SOAP::Lite dispatch_from(Some::Module) => 5423 uri => 'urn:Foo' 5424 proxy => 'http://...'; 5425 5426=item Problems using SOAP::Lite's COM Interface 5427 5428=over 5429 5430=item Can't call method "server" on undefined value 5431 5432You probably did not register F<Lite.dll> using C<regsvr32 Lite.dll> 5433 5434=item Failed to load PerlCtrl Runtime 5435 5436It is likely that you have install Perl in two different locations and the 5437location of ActiveState's Perl is not the first instance of Perl specified 5438in your PATH. To rectify, rename the directory in which the non-ActiveState 5439Perl is installed, or be sure the path to ActiveState's Perl is specified 5440prior to any other instance of Perl in your PATH. 5441 5442=back 5443 5444=item Dynamic libraries are not found 5445 5446If you are using the Apache web server, and you are seeing something like the 5447following in your webserver log file: 5448 5449 Can't load '/usr/local/lib/perl5/site_perl/.../XML/Parser/Expat/Expat.so' 5450 for module XML::Parser::Expat: dynamic linker: /usr/local/bin/perl: 5451 libexpat.so.0 is NEEDED, but object does not exist at 5452 /usr/local/lib/perl5/.../DynaLoader.pm line 200. 5453 5454Then try placing the following into your F<httpd.conf> file and see if it 5455fixes your problem. 5456 5457 <IfModule mod_env.c> 5458 PassEnv LD_LIBRARY_PATH 5459 </IfModule> 5460 5461=item SOAP client reports "500 unexpected EOF before status line seen 5462 5463See L</"Apache is crashing with segfaults"> 5464 5465=item Apache is crashing with segfaults 5466 5467Using C<SOAP::Lite> (or L<XML::Parser::Expat>) in combination with mod_perl 5468causes random segmentation faults in httpd processes. To fix, try configuring 5469Apache with the following: 5470 5471 RULE_EXPAT=no 5472 5473If you are using Apache 1.3.20 and later, try configuring Apache with the 5474following option: 5475 5476 ./configure --disable-rule=EXPAT 5477 5478See http://archive.covalent.net/modperl/2000/04/0185.xml for more details and 5479lot of thanks to Robert Barta <rho@bigpond.net.au> for explaining this weird 5480behavior. 5481 5482If this doesn't address the problem, you may wish to try C<-Uusemymalloc>, 5483or a similar option in order to instruct Perl to use the system's own C<malloc>. 5484 5485Thanks to Tim Bunce <Tim.Bunce@pobox.com>. 5486 5487=item CGI scripts do not work under Microsoft Internet Information Server (IIS) 5488 5489CGI scripts may not work under IIS unless scripts use the C<.pl> extension, 5490opposed to C<.cgi>. 5491 5492=item Java SAX parser unable to parse message composed by SOAP::Lite 5493 5494In some cases SOAP messages created by C<SOAP::Lite> may not be parsed 5495properly by a SAX2/Java XML parser. This is due to a known bug in 5496C<org.xml.sax.helpers.ParserAdapter>. This bug manifests itself when an 5497attribute in an XML element occurs prior to the XML namespace declaration on 5498which it depends. However, according to the XML specification, the order of 5499these attributes is not significant. 5500 5501http://www.megginson.com/SAX/index.html 5502 5503Thanks to Steve Alpert (Steve_Alpert@idx.com) for pointing on it. 5504 5505=back 5506 5507=head1 PERFORMANCE 5508 5509=over 4 5510 5511=item Processing of XML encoded fragments 5512 5513C<SOAP::Lite> is based on L<XML::Parser> which is basically wrapper around 5514James Clark's expat parser. Expat's behavior for parsing XML encoded string 5515can affect processing messages that have lot of encoded entities, like XML 5516fragments, encoded as strings. Providing low-level details, parser will call 5517char() callback for every portion of processed stream, but individually for 5518every processed entity or newline. It can lead to lot of calls and additional 5519memory manager expenses even for small messages. By contrast, XML messages 5520which are encoded as base64Binary, don't have this problem and difference in 5521processing time can be significant. For XML encoded string that has about 20 5522lines and 30 tags, number of call could be about 100 instead of one for 5523the same string encoded as base64Binary. 5524 5525Since it is parser's feature there is NO fix for this behavior (let me know 5526if you find one), especially because you need to parse message you already 5527got (and you cannot control content of this message), however, if your are 5528in charge for both ends of processing you can switch encoding to base64 on 5529sender's side. It will definitely work with SOAP::Lite and it B<may> work with 5530other toolkits/implementations also, but obviously I cannot guarantee that. 5531 5532If you want to encode specific string as base64, just do 5533C<< SOAP::Data->type(base64 => $string) >> either on client or on server 5534side. If you want change behavior for specific instance of SOAP::Lite, you 5535may subclass C<SOAP::Serializer>, override C<as_string()> method that is 5536responsible for string encoding (take a look into C<as_base64Binary()>) and 5537specify B<new> serializer class for your SOAP::Lite object with: 5538 5539 my $soap = new SOAP::Lite 5540 serializer => My::Serializer->new, 5541 ..... other parameters 5542 5543or on server side: 5544 5545 my $server = new SOAP::Transport::HTTP::Daemon # or any other server 5546 serializer => My::Serializer->new, 5547 ..... other parameters 5548 5549If you want to change this behavior for B<all> instances of SOAP::Lite, just 5550substitute C<as_string()> method with C<as_base64Binary()> somewhere in your 5551code B<after> C<use SOAP::Lite> and B<before> actual processing/sending: 5552 5553 *SOAP::Serializer::as_string = \&SOAP::XMLSchema2001::Serializer::as_base64Binary; 5554 5555Be warned that last two methods will affect B<all> strings and convert them 5556into base64 encoded. It doesn't make any difference for SOAP::Lite, but it 5557B<may> make a difference for other toolkits. 5558 5559=back 5560 5561=head1 BUGS AND LIMITATIONS 5562 5563=over 4 5564 5565=item * 5566 5567No support for multidimensional, partially transmitted and sparse arrays 5568(however arrays of arrays are supported, as well as any other data structures, 5569and you can add your own implementation with SOAP::Data). 5570 5571=item * 5572 5573Limited support for WSDL schema. 5574 5575=item * 5576 5577XML::Parser::Lite relies on Unicode support in Perl and doesn't do entity decoding. 5578 5579=item * 5580 5581Limited support for mustUnderstand and Actor attributes. 5582 5583=back 5584 5585=head1 PLATFORM SPECIFICS 5586 5587=over 4 5588 5589=item MacOS 5590 5591Information about XML::Parser for MacPerl could be found here: 5592 5593http://bumppo.net/lists/macperl-modules/1999/07/msg00047.html 5594 5595Compiled XML::Parser for MacOS could be found here: 5596 5597http://www.perl.com/CPAN-local/authors/id/A/AS/ASANDSTRM/XML-Parser-2.27-bin-1-MacOS.tgz 5598 5599=back 5600 5601=head1 RELATED MODULES 5602 5603=head2 Transport Modules 5604 5605SOAP::Lite allows to add support for additional transport protocols, or 5606server handlers, via separate modules implementing the SOAP::Transport::* 5607interface. The following modules are available from CPAN: 5608 5609=over 5610 5611=item * SOAP-Transport-HTTP-Nginx 5612 5613L<SOAP::Transport::HTTP::Nginx|SOAP::Transport::HTTP::Nginx> provides a transport module for nginx (<http://nginx.net/>) 5614 5615=back 5616 5617=head1 AVAILABILITY 5618 5619You can download the latest version SOAP::Lite for Unix or SOAP::Lite for 5620Win32 from the following sources: 5621 5622 * CPAN: http://search.cpan.org/search?dist=SOAP-Lite 5623 * Sourceforge: http://sourceforge.net/projects/soaplite/ 5624 5625PPM packages are also available from sourceforge. 5626 5627You are welcome to send e-mail to the maintainers of SOAP::Lite with your 5628comments, suggestions, bug reports and complaints. 5629 5630=head1 ACKNOWLEDGEMENTS 5631 5632Special thanks to Randy J. Ray, author of 5633I<Programming Web Services with Perl>, who has contributed greatly to the 5634documentation effort of SOAP::Lite. 5635 5636Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite 5637to republish and redistribute the SOAP::Lite reference manual found in 5638Appendix B of I<Programming Web Services with Perl>. 5639 5640And special gratitude to all the developers who have contributed patches, 5641ideas, time, energy, and help in a million different forms to the development 5642of this software. 5643 5644=head1 HACKING 5645 5646SOAP::Lite's development takes place on sourceforge.net. 5647 5648There's a subversion repository set up at 5649 5650 https://soaplite.svn.sourceforge.net/svnroot/soaplite/ 5651 5652=head1 REPORTING BUGS 5653 5654Please report all suspected SOAP::Lite bugs using Sourceforge. This ensures 5655proper tracking of the issue and allows you the reporter to know when something 5656gets fixed. 5657 5658http://sourceforge.net/tracker/?group_id=66000&atid=513017 5659 5660=head1 COPYRIGHT 5661 5662Copyright (C) 2000-2007 Paul Kulchenko. All rights reserved. 5663 5664Copyright (C) 2007-2008 Martin Kutter 5665 5666=head1 LICENSE 5667 5668This library is free software; you can redistribute it and/or modify 5669it under the same terms as Perl itself. 5670 5671This text and all associated documentation for this library is made available 5672under the Creative Commons Attribution-NoDerivs 2.0 license. 5673http://creativecommons.org/licenses/by-nd/2.0/ 5674 5675=head1 AUTHORS 5676 5677Paul Kulchenko (paulclinger@yahoo.com) 5678 5679Randy J. Ray (rjray@blackperl.com) 5680 5681Byrne Reese (byrne@majordojo.com) 5682 5683Martin Kutter (martin.kutter@fen-net.de) 5684 5685=cut 5686