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