File Coverage

blib/lib/SOAP/Lite.pm
Criterion Covered Total %
statement 961 1855 51.8
branch 341 1052 32.4
condition 122 569 21.4
subroutine 228 334 68.2
pod 6 9 66.6
total 1658 3819 43.4


line stmt bran cond sub pod time code
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              
15             package SOAP::Lite;
16              
17 25     25   221583 use strict;
  25         69  
  25         1267  
18 25     25   140 use warnings;
  25         51  
  25         8841  
19              
20             our $VERSION = '1.11';
21              
22             package SOAP::XMLSchemaApacheSOAP::Deserializer;
23              
24             sub as_map {
25 0     0   0 my $self = shift;
26             return {
27 0         0 map {
28 0 0       0 my $hash = ($self->decode_object($_))[1];
29 0         0 ($hash->{key} => $hash->{value})
30 0         0 } @{$_[3] || []}
31             };
32             }
33             sub as_Map; *as_Map = \&as_map;
34              
35             # Thank to Kenneth Draper for this contribution
36             sub as_vector {
37 0     0   0 my $self = shift;
38 0 0       0 return [ map { scalar(($self->decode_object($_))[1]) } @{$_[3] || []} ];
  0         0  
  0         0  
39             }
40             sub as_Vector; *as_Vector = \&as_vector;
41              
42             # ----------------------------------------------------------------------
43              
44             package SOAP::XMLSchema::Serializer;
45              
46 25     25   170 use vars qw(@ISA);
  25         54  
  25         2983  
47              
48             sub xmlschemaclass {
49 136     136   197 my $self = shift;
50 136 100       575 return $ISA[0] unless @_;
51 25         787 @ISA = (shift);
52 25         116 return $self;
53             }
54              
55             # ----------------------------------------------------------------------
56              
57             package SOAP::XMLSchema1999::Serializer;
58              
59 25     25   147 use vars qw(@EXPORT $AUTOLOAD);
  25         56  
  25         6215  
60              
61             sub AUTOLOAD {
62 61     61   18618 local($1,$2);
63 61         374 my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
64 61 100       167 return if $method eq 'DESTROY';
65 25     25   142 no strict 'refs';
  25         145  
  25         7911  
66              
67 60         104 my $export_var = $package . '::EXPORT';
68 60         398 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 60 100 66     280 if ($method =~ s/^as_// && grep {$_ eq $method} @{$export_var}) {
  2065         2851  
  58         173  
78             # print STDERR "method is now '$method'\n";
79             } else {
80 2         14 return;
81             }
82              
83 58         106 $method =~ s/_/-/; # fix ur-type
84              
85             *$AUTOLOAD = sub {
86 72     72   200 my $self = shift;
87 72         128 my($value, $name, $type, $attr) = @_;
88 72         503 return [$name, {'xsi:type' => "xsd:$method", %$attr}, $value];
89 58         420 };
90 58         352 goto &$AUTOLOAD;
91             }
92              
93             BEGIN {
94 25     25   254 @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 25         89 foreach (@EXPORT) { eval "sub as_$_" }
  850         47126  
105             }
106              
107 25     25   139 sub nilValue { 'null' }
108              
109 1     1   93 sub anyTypeValue { 'ur-type' }
110              
111             sub as_base64 {
112 2     2   98 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 2 50       8 if ($SOAP::Constants::HAS_ENCODE) {
118 2 50       22 if (Encode::is_utf8($value)) {
119 0 0       0 if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions.
120 0         0 Encode::_utf8_off($value);
121             }
122             else {
123 0         0 $value = pack('C*',unpack('C*',$value)); # the slow but safe way,
124             # but this fallback works always.
125             }
126             }
127             }
128              
129 2         17 require MIME::Base64;
130             return [
131 2         20 $name,
132             {
133             'xsi:type' => SOAP::Utils::qualify($self->encprefix => 'base64'),
134             %$attr
135             },
136             MIME::Base64::encode_base64($value,'')
137             ];
138             }
139              
140             sub as_hex {
141 1     1   4 my ($self, $value, $name, $type, $attr) = @_;
142             return [
143 2         18 $name,
144             {
145             'xsi:type' => 'xsd:hex', %$attr
146             },
147             join '', map {
148 1         6 uc sprintf "%02x", ord
149             } split '', $value
150             ];
151             }
152              
153             sub as_long {
154 4     4   875 my($self, $value, $name, $type, $attr) = @_;
155             return [
156 4         22 $name,
157             {'xsi:type' => 'xsd:long', %$attr},
158             $value
159             ];
160             }
161              
162             sub as_dateTime {
163 1     1   36 my ($self, $value, $name, $type, $attr) = @_;
164 1         6 return [$name, {'xsi:type' => 'xsd:dateTime', %$attr}, $value];
165             }
166              
167             sub as_string {
168 10     10   1247 my ($self, $value, $name, $type, $attr) = @_;
169 10 100       30 die "String value expected instead of @{[ref $value]} reference\n"
  1         10  
170             if ref $value;
171             return [
172 9         36 $name,
173             {'xsi:type' => 'xsd:string', %$attr},
174             SOAP::Utils::encode_data($value)
175             ];
176             }
177              
178             sub as_anyURI {
179 5     5   2256 my($self, $value, $name, $type, $attr) = @_;
180 5 100       21 die "String value expected instead of @{[ref $value]} reference\n" if ref $value;
  1         8  
181             return [
182 4         24 $name,
183             {'xsi:type' => 'xsd:anyURI', %$attr},
184             SOAP::Utils::encode_data($value)
185             ];
186             }
187              
188 2 100   2   81 sub as_undef { $_[1] ? '1' : '0' }
189              
190             sub as_boolean {
191 2     2   119 my $self = shift;
192 2         7 my($value, $name, $type, $attr) = @_;
193             # fix [ 1.05279 ] Boolean serialization error
194             return [
195 2 100 66     25 $name,
196             {'xsi:type' => 'xsd:boolean', %$attr},
197             ( $value && $value ne 'false' ) ? 'true' : 'false'
198             ];
199             }
200              
201             sub as_float {
202 2     2   772 my($self, $value, $name, $type, $attr) = @_;
203             return [
204 2         12 $name,
205             {'xsi:type' => 'xsd:float', %$attr},
206             $value
207             ];
208             }
209              
210             # ----------------------------------------------------------------------
211              
212             package SOAP::XMLSchema2001::Serializer;
213              
214 25     25   203 use vars qw(@EXPORT);
  25         61  
  25         3728  
215              
216             # no more warnings about "used only once"
217             *AUTOLOAD if 0;
218              
219             *AUTOLOAD = \&SOAP::XMLSchema1999::Serializer::AUTOLOAD;
220              
221             BEGIN {
222 25     25   212 @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 25         77 foreach (@EXPORT) { eval "sub as_$_" }
  925         69337  
234             }
235              
236 47     47   223 sub nilValue { 'nil' }
237              
238 0     0   0 sub anyTypeValue { 'anyType' }
239              
240             sub as_long; *as_long = \&SOAP::XMLSchema1999::Serializer::as_long;
241             sub as_float; *as_float = \&SOAP::XMLSchema1999::Serializer::as_float;
242             sub as_string; *as_string = \&SOAP::XMLSchema1999::Serializer::as_string;
243             sub as_anyURI; *as_anyURI = \&SOAP::XMLSchema1999::Serializer::as_anyURI;
244              
245             # TODO - QNames still don't work for 2001 schema!
246             sub as_QName; *as_QName = \&SOAP::XMLSchema1999::Serializer::as_string;
247             sub as_hex; *as_hex = \&as_hexBinary;
248             sub as_base64; *as_base64 = \&as_base64Binary;
249             sub as_timeInstant; *as_timeInstant = \&as_dateTime;
250              
251             # only 0 and 1 allowed - that's easy...
252             sub as_undef {
253 22 50   22   217 $_[1]
254             ? 'true'
255             : 'false'
256             }
257              
258             sub as_hexBinary {
259 0     0   0 my ($self, $value, $name, $type, $attr) = @_;
260             return [
261 0         0 $name,
262             {'xsi:type' => 'xsd:hexBinary', %$attr},
263             join '', map {
264 0         0 uc sprintf "%02x", ord
265             } split '', $value
266             ];
267             }
268              
269             sub as_base64Binary {
270 1     1   11 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 1 50       100 if (eval "require Encode; 1") {
276 1 50       5 if (Encode::is_utf8($value)) {
277 0 0       0 if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions.
278 0         0 Encode::_utf8_off($value);
279             }
280             else {
281 0         0 $value = pack('C*',unpack('C*',$value)); # the slow but safe way,
282             # but this fallback works always.
283             }
284             }
285             }
286              
287 1         6 require MIME::Base64;
288             return [
289 1         7 $name,
290             {
291             'xsi:type' => 'xsd:base64Binary', %$attr
292             },
293             MIME::Base64::encode_base64($value,'')
294             ];
295             }
296              
297             sub as_boolean {
298 2     2   6 my ($self, $value, $name, $type, $attr) = @_;
299             # fix [ 1.05279 ] Boolean serialization error
300             return [
301 2 100 66     31 $name,
302             {
303             'xsi:type' => 'xsd:boolean', %$attr
304             },
305             ( $value && ($value ne 'false') )
306             ? 'true'
307             : 'false'
308             ];
309             }
310              
311              
312             # ======================================================================
313              
314             package SOAP::Utils;
315              
316             sub qualify {
317 177 50 33 177   1665 $_[1]
    50          
    100          
318             ? $_[1] =~ /:/
319             ? $_[1]
320             : join(':', $_[0] || (), $_[1])
321             : defined $_[1]
322             ? $_[0]
323             : ''
324             }
325              
326             sub overqualify (&$) {
327 0     0   0 for ($_[1]) {
328 0         0 &{$_[0]};
  0         0  
329 0         0 s/^:|:$//g
330             }
331             }
332              
333             sub disqualify {
334 106     106   1870 (my $qname = shift) =~ s/^($SOAP::Constants::NSMASK?)://;
335 106         1173 return $qname;
336             }
337              
338             sub splitqname {
339 84     84   238 local($1,$2);
340 84         369 $_[0] =~ /^(?:([^:]+):)?(.+)$/;
341 84         369 return ($1,$2)
342             }
343              
344             sub longname {
345 0 0   0   0 defined $_[0]
346             ? sprintf('{%s}%s', $_[0], $_[1])
347             : $_[1]
348             }
349              
350             sub splitlongname {
351 71     71   210 local($1,$2);
352 71         293 $_[0] =~ /^(?:\{(.*)\})?(.+)$/;
353 71         310 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              
370             my %encode_attribute = ('&' => '&', '>' => '>', '<' => '<', '"' => '"');
371 149     149   292 sub encode_attribute { (my $e = $_[0]) =~ s/([&<>\"])/$encode_attribute{$1}/g; $e }
  149         608  
372              
373             my %encode_data = ('&' => '&', '>' => '>', '<' => '<', "\xd" => ' ');
374             sub encode_data {
375 27     27   54 my $e = $_[0];
376 27 100       91 if ($e) {
377 11         19 $e =~ s/([&<>\015])/$encode_data{$1}/g;
378 11         19 $e =~ s/\]\]>/\]\]>/g;
379             }
380             $e
381 27         171 }
382              
383             # methods for internal tree (SOAP::Deserializer, SOAP::SOM and SOAP::Serializer)
384              
385 0     0   0 sub o_qname { $_[0]->[0] }
386 0     0   0 sub o_attr { $_[0]->[1] }
387 0 0   0   0 sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef }
388 0 0   0   0 sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] }
389             # $_[0]->[3] is not used. Serializer stores object ID there
390 0     0   0 sub o_value { $_[0]->[4] }
391 0     0   0 sub o_lname { $_[0]->[5] }
392 0     0   0 sub o_lattr { $_[0]->[6] }
393              
394             sub format_datetime {
395 0     0   0 my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5];
396 0         0 my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s);
397 0         0 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
402             BEGIN {
403             sub bytelength;
404             *bytelength = eval('use bytes; 1') # 5.6.0 and later?
405 25 50   25   48596 ? sub { use bytes; length(@_ ? $_[0] : $_) }
  25     11   374  
  25         142  
  11         74  
406 25 0   25   3621 : sub { length(@_ ? $_[0] : $_) };
  0 50   25   0  
  25         219  
  25         8835  
  25         143  
407             }
408              
409             # ======================================================================
410              
411             package SOAP::Cloneable;
412              
413             sub clone {
414 24     24   46 my $self = shift;
415              
416 24 50 33     298 return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__);
417              
418 24   33     251 my $clone = bless {} => ref($self) || $self;
419 24         289 for (keys %$self) {
420 199         303 my $value = $self->{$_};
421 199 100 100     1375 $clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value;
422             }
423 24         88 return $clone;
424             }
425              
426             # ======================================================================
427              
428             package SOAP::Transport;
429              
430 25     25   144 use vars qw($AUTOLOAD @ISA);
  25         377  
  25         2111  
431             @ISA = qw(SOAP::Cloneable);
432              
433 25     25   56939 use Class::Inspector;
  25         132300  
  25         8965  
434              
435              
436 15     15   57 sub DESTROY { SOAP::Trace::objects('()') }
437              
438             sub new {
439 15     15   37 my $self = shift;
440 15 50       60 return $self if ref $self;
441 15   33     113 my $class = ref($self) || $self;
442              
443 15         74 SOAP::Trace::objects('()');
444 15         148 return bless {} => $class;
445             }
446              
447             sub proxy {
448 84     84   158 my $self = shift;
449 84 50       258 $self = $self->new() if not ref $self;
450              
451 84         144 my $class = ref $self;
452              
453 84 100       951 return $self->{_proxy} unless @_;
454              
455 13 50       204 $_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
456 13         68 my $protocol = uc "$1"; # untainted now
457              
458             # HTTPS is handled by HTTP class
459 13         43 $protocol =~s/^HTTPS$/HTTP/;
460              
461 13         68 (my $protocol_class = "${class}::$protocol") =~ s/-/_/g;
462              
463 25     25   227 no strict 'refs';
  25         2946  
  25         6213  
464 13 50 33     153 unless (Class::Inspector->loaded("$protocol_class\::Client")
465             && UNIVERSAL::can("$protocol_class\::Client" => 'new')
466             ) {
467 13         2109 eval "require $protocol_class";
468 13 50       104 die "Unsupported protocol '$protocol'\n"
469             if $@ =~ m!^Can\'t locate SOAP/Transport/!;
470 13 50       66 die if $@;
471             }
472              
473 13         58 $protocol_class .= "::Client";
474 13         122 return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_);
475             }
476              
477             sub AUTOLOAD {
478 46     46   215 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
479 46 50       151 return if $method eq 'DESTROY';
480              
481 25     25   182 no strict 'refs';
  25         50  
  25         2394  
482 46     47   384 *$AUTOLOAD = sub { shift->proxy->$method(@_) };
  47         177  
483 46         229 goto &$AUTOLOAD;
484             }
485              
486             # ======================================================================
487              
488             package SOAP::Fault;
489              
490 25     25   180 use Carp ();
  25         60  
  25         735  
491              
492 25     25   48766 use overload fallback => 1, '""' => "stringify";
  25         29613  
  25         166  
493              
494 0     0   0 sub DESTROY { SOAP::Trace::objects('()') }
495              
496             sub new {
497 0     0   0 my $self = shift;
498              
499 0 0       0 unless (ref $self) {
500 0         0 my $class = $self;
501 0         0 $self = bless {} => $class;
502 0         0 SOAP::Trace::objects('()');
503             }
504              
505 0 0 0     0 Carp::carp "Odd (wrong?) number of parameters in new()"
506             if $^W && (@_ & 1);
507              
508 25     25   4335 no strict qw(refs);
  25         50  
  25         3494  
509 0         0 while (@_) {
510 0         0 my $method = shift;
511 0 0       0 $self->$method(shift)
512             if $self->can($method)
513             }
514              
515 0         0 return $self;
516             }
517              
518             sub stringify {
519 0     0   0 my $self = shift;
520 0         0 return join ': ', $self->faultcode, $self->faultstring;
521             }
522              
523             sub BEGIN {
524 25     25   139 no strict 'refs';
  25         57  
  25         3615  
525 25     25   75 for my $method (qw(faultcode faultstring faultactor faultdetail)) {
526 100         232 my $field = '_' . $method;
527             *$method = sub {
528 0 0   0   0 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
529             ? shift->new
530             : __PACKAGE__->new;
531 0 0       0 if (@_) {
532 0         0 $self->{$field} = shift;
533 0         0 return $self
534             }
535 0         0 return $self->{$field};
536             }
537 100         670 }
538 25         953 *detail = \&faultdetail;
539             }
540              
541             # ======================================================================
542              
543             package SOAP::Data;
544              
545 25     25   154 use vars qw(@ISA @EXPORT_OK);
  25         45  
  25         1733  
546 25     25   142 use Exporter;
  25         48  
  25         1253  
547 25     25   175 use Carp ();
  25         197  
  25         468  
548 25     25   18164 use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
  25         434  
  25         3151  
549              
550             @ISA = qw(Exporter);
551             @EXPORT_OK = qw(name type attr value uri);
552              
553 100     100   541 sub DESTROY { SOAP::Trace::objects('()') }
554              
555             sub new {
556 206     206   2319 my $self = shift;
557              
558 206 100       617 unless (ref $self) {
559 100         127 my $class = $self;
560 100         663 $self = bless {_attr => {}, _value => [], _signature => []} => $class;
561 100         240 SOAP::Trace::objects('()');
562             }
563 25     25   215 no strict qw(refs);
  25         41  
  25         17408  
564 206 50 33     1132 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
565 206         538 while (@_) {
566 0         0 my $method = shift;
567 0 0       0 $self->$method(shift) if $self->can($method)
568             }
569              
570 206         528 return $self;
571             }
572              
573             sub name {
574 297 50   297   954 my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
    100          
575 297 100       666 if (@_) {
576 99         140 my $name = shift;
577 99         119 my ($uri, $prefix); # predeclare, because can't declare in assign
578 99 100       225 if ($name) {
579 71         162 ($uri, $name) = SOAP::Utils::splitlongname($name);
580 71 50       200 unless (defined $uri) {
581 71         153 ($prefix, $name) = SOAP::Utils::splitqname($name);
582 71 100       282 $self->prefix($prefix) if defined $prefix;
583             } else {
584 0         0 $self->uri($uri);
585             }
586             }
587 99         288 $self->{_name} = $name;
588              
589 99 100       320 $self->value(@_) if @_;
590 99         476 return $self;
591             }
592 198         586 return $self->{_name};
593             }
594              
595             sub attr {
596 132 0   132   430 my $self = ref $_[0]
    50          
597             ? shift
598             : UNIVERSAL::isa($_[0] => __PACKAGE__)
599             ? shift->new()
600             : __PACKAGE__->new();
601 132 100       292 if (@_) {
602 32         68 $self->{_attr} = shift;
603 32 50       123 return $self->value(@_) if @_;
604 32         287 return $self
605             }
606 100         549 return $self->{_attr};
607             }
608              
609             sub type {
610 311 0   311   630 my $self = ref $_[0]
    50          
611             ? shift
612             : UNIVERSAL::isa($_[0] => __PACKAGE__)
613             ? shift->new()
614             : __PACKAGE__->new();
615 311 100       609 if (@_) {
616 5         12 $self->{_type} = shift;
617 5 50       12 $self->value(@_) if @_;
618 5         30 return $self;
619             }
620 306 50 66     959 if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) {
  102         2033  
  296         1398  
621 0         0 $self->{_type} = (SOAP::Utils::splitlongname(delete $self->{_attr}->{shift(@types)}))[1];
622             }
623 306         1659 return $self->{_type};
624             }
625              
626             BEGIN {
627 25     25   149 no strict 'refs';
  25         41  
  25         11461  
628 25     25   75 for my $method (qw(root mustUnderstand)) {
629 50         119 my $field = '_' . $method;
630             *$method = sub {
631 2 100   2   333 my $attr = $method eq 'root'
632             ? "{$SOAP::Constants::NS_ENC}$method"
633             : "{$SOAP::Constants::NS_ENV}$method";
634 2 50       16 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
635             ? shift->new
636             : __PACKAGE__->new;
637 2 50       6 if (@_) {
638 2 50       18 $self->{_attr}->{$attr} = $self->{$field} = shift() ? 1 : 0;
639 2 100       10 $self->value(@_) if @_;
640 2         12 return $self;
641             }
642 0 0 0     0 $self->{$field} = SOAP::Lite::Deserializer::XMLSchemaSOAP1_2->as_boolean($self->{_attr}->{$attr})
643             if !defined $self->{$field} && defined $self->{_attr}->{$attr};
644 0         0 return $self->{$field};
645             }
646 50         469 }
647              
648 25         60 for my $method (qw(actor encodingStyle)) {
649 50         527 my $field = '_' . $method;
650             *$method = sub {
651 0     0   0 my $attr = "{$SOAP::Constants::NS_ENV}$method";
652 0 0       0 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
653             ? shift->new()
654             : __PACKAGE__->new();
655 0 0       0 if (@_) {
656 0         0 $self->{_attr}->{$attr} = $self->{$field} = shift;
657 0 0       0 $self->value(@_) if @_;
658 0         0 return $self;
659             }
660 0 0 0     0 $self->{$field} = $self->{_attr}->{$attr}
661             if !defined $self->{$field} && defined $self->{_attr}->{$attr};
662 0         0 return $self->{$field};
663             }
664 50         13611 }
665             }
666              
667             sub prefix {
668 142 0   142   307 my $self = ref $_[0]
    50          
669             ? shift
670             : UNIVERSAL::isa($_[0] => __PACKAGE__)
671             ? shift->new()
672             : __PACKAGE__->new();
673 142 100       589 return $self->{_prefix} unless @_;
674 43         125 $self->{_prefix} = shift;
675 43 50       131 if (scalar @_) {
676 0         0 return $self->value(@_);
677             }
678 43         87 return $self;
679             }
680              
681             sub uri {
682 99 0   99   235 my $self = ref $_[0]
    50          
683             ? shift
684             : UNIVERSAL::isa($_[0] => __PACKAGE__)
685             ? shift->new()
686             : __PACKAGE__->new();
687 99 50       390 return $self->{_uri} unless @_;
688 0         0 my $uri = $self->{_uri} = shift;
689 0 0 0     0 warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n"
      0        
690             if defined $uri && $^W && $uri =~ /::/;
691 0 0       0 if (scalar @_) {
692 0         0 return $self->value(@_);
693             }
694 0         0 return $self;
695             }
696              
697             sub set_value {
698 99 50   99   309 my $self = ref $_[0]
    100          
699             ? shift
700             : UNIVERSAL::isa($_[0] => __PACKAGE__)
701             ? shift->new()
702             : __PACKAGE__->new();
703 99         276 $self->{_value} = [@_];
704 99         256 return $self;
705             }
706              
707             sub value {
708 174 50   174   1134 my $self = ref $_[0] ? shift
    100          
709             : UNIVERSAL::isa($_[0] => __PACKAGE__)
710             ? shift->new()
711             : __PACKAGE__->new;
712 174 100       348 if (@_) {
713 74         186 return $self->set_value(@_);
714             }
715             else {
716             return wantarray
717 100 50       375 ? @{$self->{_value}}
  100         345  
718             : $self->{_value}->[0];
719             }
720             }
721              
722             sub signature {
723 105 50   105   2246 my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
724             ? shift->new()
725             : __PACKAGE__->new();
726 105 100       4452 (@_)
727             ? ($self->{_signature} = shift, return $self)
728             : (return $self->{_signature});
729             }
730              
731             # ======================================================================
732              
733             package SOAP::Header;
734              
735 25     25   161 use vars qw(@ISA);
  25         43  
  25         1674  
736             @ISA = qw(SOAP::Data);
737              
738             # ======================================================================
739              
740             package SOAP::Serializer;
741 25     25   16515 use SOAP::Lite::Utils;
  25         63  
  25         148  
742 25     25   134 use Carp ();
  25         109  
  25         457  
743 25     25   118 use vars qw(@ISA);
  25         42  
  25         5585  
744              
745             @ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer);
746              
747             BEGIN {
748             # namespaces and anonymous data structures
749 25     25   56 my $ns = 0;
750 25         45 my $name = 0;
751 25         4049 my $prefix = 'c-';
752 11     11   31 sub gen_ns { 'namesp' . ++$ns }
753 41     41   255 sub gen_name { join '', $prefix, 'gensym', ++$name }
754 0     0   0 sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; }
  0         0  
755             }
756              
757             sub BEGIN {
758 25     25   263 no strict 'refs';
  25         46  
  25         2215  
759              
760 25     25   211 __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 25         53 for my $method (qw(method fault freeform)) { # aliases for envelope
765 6     6   25 *$method = sub { shift->envelope($method => @_) }
766 75         38130 }
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              
775 25     25   166 sub DESTROY { SOAP::Trace::objects('()') }
776              
777             sub new {
778 183     183   353 my $self = shift;
779 183 100       572 return $self if ref $self;
780              
781 25         118 my $class = $self;
782 0 0   0   0 $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 0         0 _on_nonserialized => sub {Carp::carp "Cannot marshall @{[ref shift]} reference" if $^W; return},
  0         0  
796 25         377 _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 28     28   128 $self->typelookup({
804             'base64Binary' =>
805             [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/ }, 'as_base64Binary'],
806             'zerostring' =>
807 28 100 100 27   96 [12, sub { $_[0] =~ /^0\d+$/ }, 'as_string'],
  27         397  
808             # int (and actually long too) are subtle: the negative range is one greater...
809             'int' =>
810 12 100   12   80 [20, sub {$_[0] =~ /^([+-]?\d+)$/ && ($1 <= 2147483647) && ($1 >= -2147483648); }, 'as_int'],
811             'long' =>
812 10     10   49 [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 10     10   25 [35, sub { $_[0] =~ /^--\d\d--(-\d\d:\d\d)?$/; }, 'as_gMonth'],
817             'gDay' =>
818 10     10   26 [40, sub { $_[0] =~ /^---\d\d(-\d\d:\d\d)?$/; }, 'as_gDay'],
819             'gYear' =>
820 10     10   29 [45, sub { $_[0] =~ /^-?\d\d\d\d(-\d\d:\d\d)?$/; }, 'as_gYear'],
821             'gMonthDay' =>
822 10     10   27 [50, sub { $_[0] =~ /^-\d\d-\d\d(-\d\d:\d\d)?$/; }, 'as_gMonthDay'],
823             'gYearMonth' =>
824 10     10   29 [55, sub { $_[0] =~ /^-?\d\d\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_gYearMonth'],
825             'date' =>
826 10     10   24 [60, sub { $_[0] =~ /^-?\d\d\d\d-\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_date'],
827             'time' =>
828 10     10   23 [70, sub { $_[0] =~ /^\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_time'],
829             'dateTime' =>
830 10     10   23 [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 10 100   10   71 [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 9     9   50 [90, sub { $_[0] =~ /^(true|false)$/i; }, 'as_boolean'],
848             'anyURI' =>
849 7     7   30 [95, sub { $_[0] =~ /^(urn:|http:\/\/)/i; }, 'as_anyURI'],
  6         43  
850             'string' =>
851 25         1583 [100, sub {1}, 'as_string'],
852             });
853 25         157 $self->register_ns($SOAP::Constants::NS_ENC,$SOAP::Constants::PREFIX_ENC);
854 25 50       237 $self->register_ns($SOAP::Constants::NS_ENV,$SOAP::Constants::PREFIX_ENV)
855             if $SOAP::Constants::PREFIX_ENV;
856 25         113 $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);
857 25         77 SOAP::Trace::objects('()');
858              
859 25     25   177 no strict qw(refs);
  25         51  
  25         54159  
860 25 50 66     143 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
861 25 0       108 while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }
  0         0  
  0         0  
862              
863 25         181 return $self;
864             }
865              
866             sub typelookup {
867 25     25   70 my ($self, $lookup) = @_;
868 25 50       209 if (defined $lookup) {
869 25         255 $self->{ _typelookup } = $lookup;
870 25         58 $self->{ _typelookup_order } = [ sort { $lookup->{$a}->[0] <=> $lookup->{$b}->[0] } keys %{ $lookup } ];
  1262         2235  
  25         238  
871 25         96 return $self;
872             }
873 0         0 return $self->{ _typelookup };
874             }
875              
876             sub ns {
877 3     3   279 my $self = shift;
878 3 100       16 $self = $self->new() if not ref $self;
879 3 50       10 if (@_) {
880 3         6 my ($u,$p) = @_;
881 3         5 my $prefix;
882              
883 3 100 33     17 if ($p) {
    50          
884 1         3 $prefix = $p;
885             }
886             elsif (!$p && !($prefix = $self->find_prefix($u))) {
887 2         6 $prefix = gen_ns;
888             }
889              
890 3         6 $self->{'_ns_uri'} = $u;
891 3         5 $self->{'_ns_prefix'} = $prefix;
892 3         7 $self->{'_use_default_ns'} = 0;
893             # $self->register_ns($u,$prefix);
894 3         6 $self->{'_namespaces'}->{$u} = $prefix;
895 3         24 return $self;
896             }
897 0         0 return $self->{'_ns_uri'};
898             }
899              
900             sub default_ns {
901 14     14   32 my $self = shift;
902 14 100       99 $self = $self->new() if not ref $self;
903 14 50       59 if (@_) {
904 14         33 my ($u) = @_;
905 14         42 $self->{'_ns_uri'} = $u;
906 14         36 $self->{'_ns_prefix'} = '';
907 14         32 $self->{'_use_default_ns'} = 1;
908 14         41 return $self;
909             }
910 0         0 return $self->{'_ns_uri'};
911             }
912              
913             sub use_prefix {
914 2     2   880 my $self = shift;
915 2 50       15 $self = $self->new() if not ref $self;
916 2         25 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 2 50       14 if (@_) {
919 2         5 my $use = shift;
920 2   100     12 $self->{'_use_default_ns'} = !$use || 0;
921 2         10 return $self;
922             } else {
923 0         0 return $self->{'_use_default_ns'};
924             }
925             }
926             sub uri {
927 26     26   66 my $self = shift;
928 26 50       98 $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 26 100       96 if (@_) {
931 14         33 my $ns = shift;
932 14 100       69 if ($self->{_use_default_ns}) {
933 13         66 $self->default_ns($ns);
934             }
935             else {
936 1         5 $self->ns($ns);
937             }
938             # $self->{'_ns_uri'} = $ns;
939             # $self->register_ns($self->{'_ns_uri'}) if (!$self->{_use_default_ns});
940 14         88 return $self;
941             }
942 12         54 return $self->{'_ns_uri'};
943             }
944              
945             sub encodingStyle {
946 1     1   3 my $self = shift;
947 1 50       5 $self = $self->new() if not ref $self;
948 1 50       25 return $self->{'_encodingStyle'} unless @_;
949              
950 0         0 my $cur_style = $self->{'_encodingStyle'};
951 0         0 delete($self->{'_namespaces'}->{$cur_style});
952              
953 0         0 my $new_style = shift;
954 0 0       0 if ($new_style eq "") {
955 0         0 delete($self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"});
956             }
957             else {
958 0         0 $self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"} = $new_style;
959 0         0 $self->{'_namespaces'}->{$new_style} = $SOAP::Constants::PREFIX_ENC;
960             }
961             }
962              
963             # TODO - changing SOAP version can affect previously set encodingStyle
964             sub soapversion {
965 1     1   2 my $self = shift;
966 1 50       4 return $self->{_soapversion} unless @_;
967 1 50       4 return $self if $self->{_soapversion} eq SOAP::Lite->soapversion;
968 0         0 $self->{_soapversion} = shift;
969              
970 0         0 $self->attr({
971             "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
972             });
973 0 0       0 $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 0         0 $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);
978              
979 0         0 return $self;
980             }
981              
982             sub xmlschema {
983 25     25   84 my $self = shift->new;
984 25 50       106 return $self->{_xmlschema} unless @_;
985              
986 25         50 my @schema;
987 25 50       108 if ($_[0]) {
988 25 100       106 @schema = grep {/XMLSchema/ && /$_[0]/} keys %SOAP::Constants::XML_SCHEMAS;
  100         1606  
989 25 50       118 Carp::croak "More than one schema match parameter '$_[0]': @{[join ', ', @schema]}" if @schema > 1;
  0         0  
990 25 50       96 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 25         153 my $ns = $self->namespaces;
997             # delete current schema from namespaces
998 25 50       115 if (my $schema = $self->{_xmlschema}) {
999 0         0 delete $ns->{$schema};
1000 0         0 delete $ns->{"$schema-instance"};
1001             }
1002              
1003             # add new schema into namespaces
1004 25 50       119 if (my $schema = $self->{_xmlschema} = shift @schema) {
1005 25         60 $ns->{$schema} = 'xsd';
1006 25         103 $ns->{"$schema-instance"} = 'xsi';
1007             }
1008              
1009             # and here is the class serializer should work with
1010 25 50       155 my $class = exists $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}}
1011             ? $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} . '::Serializer'
1012             : $self;
1013              
1014 25         202 $self->xmlschemaclass($class);
1015              
1016 25         60 return $self;
1017             }
1018              
1019             sub envprefix {
1020 42     42   112 my $self = shift->new();
1021 42 50       211 return $self->namespaces->{$SOAP::Constants::NS_ENV} unless @_;
1022 0         0 $self->namespaces->{$SOAP::Constants::NS_ENV} = shift;
1023 0         0 return $self;
1024             }
1025              
1026             sub encprefix {
1027 3     3   7 my $self = shift->new();
1028 3 50       13 return $self->namespaces->{$SOAP::Constants::NS_ENC} unless @_;
1029 0         0 $self->namespaces->{$SOAP::Constants::NS_ENC} = shift;
1030 0         0 return $self;
1031             }
1032              
1033 204     204   1292 sub gen_id { sprintf "%U", $_[1] }
1034              
1035             sub multiref_object {
1036 152     152   210 my ($self, $object) = @_;
1037 152         319 my $id = $self->gen_id($object);
1038 152 100       415 if (! exists $self->{ _seen }->{ $id }) {
1039 150         809 $self->{ _seen }->{ $id } = {
1040             count => 1,
1041             multiref => 0,
1042             value => $object,
1043             recursive => 0
1044             };
1045             }
1046             else {
1047 2         6 my $id_seen = $self->{ _seen }->{ $id };
1048 2         3 $id_seen->{count}++;
1049 2         5 $id_seen->{multiref} = 1;
1050 2         4 $id_seen->{value} = $object;
1051 2   100     11 $id_seen->{recursive} ||= 0;
1052             }
1053 152         331 return $id;
1054             }
1055              
1056             sub recursive_object {
1057 0     0   0 my $self = shift;
1058 0         0 $self->seen->{$self->gen_id(shift)}->{recursive} = 1;
1059             }
1060              
1061             sub is_href {
1062 52     52   76 my $self = shift;
1063 52 50 50     178 my $seen = $self->seen->{shift || return} or return;
1064 52 100       150 return 1 if $seen->{id};
1065 51   66     293 return $seen->{multiref}
1066             && !($seen->{id} = (shift
1067             || $seen->{recursive}
1068             || $seen->{multiref} && $self->multirefinplace));
1069             }
1070              
1071             sub multiref_anchor {
1072 2     2   6 my ($self, $id) = @_;
1073 25     25   222 no warnings qw(uninitialized);
  25         77  
  25         18843  
1074 2 50       8 if ($self->{ _seen }->{ $id }->{multiref}) {
1075 2         13 return "ref-$id"
1076             }
1077             else {
1078 0         0 return undef;
1079             }
1080             }
1081              
1082             sub encode_multirefs {
1083 21     21   42 my $self = shift;
1084 21 50       95 return if $self->multirefinplace();
1085              
1086 21         54 my $seen = $self->{ _seen };
1087 0         0 map { $_->[1]->{_id} = 1; $_ }
  0         0  
  0         0  
1088 149 100       409 map { $self->encode_object($seen->{$_}->{value}) }
1089 21         89 grep { $seen->{$_}->{multiref} && !$seen->{$_}->{recursive} }
1090             keys %$seen;
1091             }
1092              
1093             sub maptypetouri {
1094 52     52   83 my($self, $type, $simple) = @_;
1095              
1096 52 100       651 return $type unless defined $type;
1097 1         5 my($prefix, $name) = SOAP::Utils::splitqname($type);
1098              
1099 1 50       5 unless (defined $prefix) {
1100 0         0 $name =~ s/__|\./::/g;
1101 0 0       0 $self->maptype->{$name} = $simple
    0          
1102             ? die "Schema/namespace for type '$type' is not specified\n"
1103             : $SOAP::Constants::NS_SL_PERLTYPE
1104             unless exists $self->maptype->{$name};
1105 0 0 0     0 $type = $self->maptype->{$name}
1106             ? SOAP::Utils::qualify($self->namespaces->{$self->maptype->{$name}} ||= gen_ns, $type)
1107             : undef;
1108             }
1109 1         8 return $type;
1110             }
1111              
1112             sub encode_object {
1113 176     176   323 my($self, $object, $name, $type, $attr) = @_;
1114              
1115 176   100     590 $attr ||= {};
1116 176 100       468 return $self->encode_scalar($object, $name, $type, $attr)
1117             unless ref $object;
1118              
1119 152         358 my $id = $self->multiref_object($object);
1120              
1121 25     25   173 use vars '%objectstack'; # we'll play with symbol table
  25         90  
  25         5933  
1122 152         859 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 152 100       538 if (++$objectstack{ $id } > 1) {
1128 2         6 $self->{ _seen }->{ $id }->{recursive} = 1
1129             }
1130              
1131             # return if we already saw it twice. It should be already properly serialized
1132 152 100       356 return if $objectstack{$id} > 2;
1133              
1134 151 100       634 if (UNIVERSAL::isa($object => 'SOAP::Data')) {
1135             # use $object->SOAP::Data:: to enable overriding name() and others in inherited classes
1136 99 100       326 $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 99         269 my($name, $attr) = $self->fixattrs($object);
1142 99         325 $attr = $self->attrstoqname($attr);
1143              
1144 99         1296 my @realvalues = $object->SOAP::Data::value;
1145 99 50 0     252 return [$name || gen_name, $attr] unless @realvalues;
1146              
1147 99   50     308 my $method = "as_" . ($object->SOAP::Data::type || '-'); # dummy type if not defined
1148             # try to call method specified for this type
1149 25     25   143 no strict qw(refs);
  25         49  
  25         8563  
1150 106 100       255 my @values = map {
1151             # store null/nil attribute if value is undef
1152 99         164 local $attr->{SOAP::Utils::qualify(xsi => $self->xmlschemaclass->nilValue)} = $self->xmlschemaclass->as_undef(1)
1153             unless defined;
1154 106 100 0     1141 $self->can($method) && $self->$method($_, $name || gen_name, $object->SOAP::Data::type, $attr)
      33        
      66        
      66        
1155             || $self->typecast($_, $name || gen_name, $object->SOAP::Data::type, $attr)
1156             || $self->encode_object($_, $name, $object->SOAP::Data::type, $attr)
1157             } @realvalues;
1158 99 50 100     470 $object->SOAP::Data::signature([map {join $;, $_->[0], SOAP::Utils::disqualify($_->[1]->{'xsi:type'} || '')} @values]) if @values;
  106         1446  
1159 99 50       1008 return wantarray ? @values : $values[0];
1160             }
1161              
1162 52         103 my $class = ref $object;
1163              
1164 52 50       293 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 0         0 $class =~ s/::/__/g;
1168              
1169 0 0       0 $name = $class if !defined $name;
1170 0 0 0     0 $type = $class if !defined $type && $self->autotype;
1171              
1172 0         0 my $method = 'as_' . $class;
1173 0 0       0 if ($self->can($method)) {
1174 25     25   157 no strict qw(refs);
  25         54  
  25         11642  
1175 0         0 my $encoded = $self->$method($object, $name, $type, $attr);
1176 0 0       0 return $encoded if ref $encoded;
1177             # return only if handled, otherwise handle with default handlers
1178             }
1179             }
1180              
1181 52 100 100     232 if (UNIVERSAL::isa($object => 'REF') || UNIVERSAL::isa($object => 'SCALAR')) {
    100          
    50          
1182 50         248 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 1 50 33     6 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 1         6 return $self->encode_hash($object, $name, $type, $attr);
1193             }
1194             else {
1195 0         0 return $self->on_nonserialized->($object);
1196             }
1197             }
1198              
1199             sub encode_scalar {
1200 89     89   773 my($self, $value, $name, $type, $attr) = @_;
1201 89   66     203 $name ||= gen_name;
1202              
1203 89         291 my $schemaclass = $self->xmlschemaclass;
1204              
1205             # null reference
1206 89 100       274 return [$name, {%$attr, SOAP::Utils::qualify(xsi => $schemaclass->nilValue) => $schemaclass->as_undef(1)}] unless defined $value;
1207              
1208             # object reference
1209 78 100       302 return [$name, {'xsi:type' => $self->maptypetouri($type), %$attr}, [$self->encode_object($$value)], $self->gen_id($value)] if ref $value;
1210              
1211             # autodefined type
1212 28 50       62 if ($self->{ _autotype}) {
1213 28         47 my $lookup = $self->{_typelookup};
1214 25     25   159 no strict qw(refs);
  25         62  
  25         142361  
1215             #for (sort {$lookup->{$a}->[0] <=> $lookup->{$b}->[0]} keys %$lookup) {
1216 28         30 for (@{ $self->{ _typelookup_order } }) {
  28         62  
1217 217         289 my $method = $lookup->{$_}->[2];
1218 217 100 33     359 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 0         0 return [$name, $attr, $value];
1226             }
1227              
1228             sub encode_array {
1229 0     0   0 my ($self, $array, $name, $type, $attr) = @_;
1230 0         0 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 0 0       0 if (!$self->autotype) {
1236 0   0     0 $name ||= gen_name;
1237 0         0 return map {$self->encode_object($_, $name)} @$array;
  0         0  
1238             }
1239              
1240             # TODO: add support for multidimensional, partially transmitted and sparse arrays
1241 0         0 my @items = map {$self->encode_object($_, $items)} @$array;
  0         0  
1242 0         0 my $num = @items;
1243 0         0 my($arraytype, %types) = '-';
1244 0   0     0 for (@items) { $arraytype = $_->[1]->{'xsi:type'} || '-'; $types{$arraytype}++ }
  0         0  
  0         0  
1245 0 0 0     0 $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 0 0       0 $type = qualify($self->encprefix => 'Array') if !defined $type;
1249 0   0     0 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
1260             sub encode_literal_array {
1261 1     1   3 my($self, $array, $name, $type, $attr) = @_;
1262              
1263 1 50       4 if ($self->autotype) {
1264 1         3 my $items = 'item';
1265              
1266             # TODO: add support for multidimensional, partially transmitted and sparse arrays
1267 1         3 my @items = map {$self->encode_object($_, $items)} @$array;
  2         6  
1268              
1269              
1270 1         2 my $num = @items;
1271 1         3 my($arraytype, %types) = '-';
1272 1         2 for (@items) {
1273 2   50     7 $arraytype = $_->[1]->{'xsi:type'} || '-';
1274 2         6 $types{$arraytype}++
1275             }
1276 1 50 33     16 $arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-'
1277             ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue)
1278             : $arraytype;
1279              
1280 1 50       7 $type = SOAP::Utils::qualify($self->encprefix => 'Array')
1281             if !defined $type;
1282              
1283 1   33     8 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 56
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             # 12
1300             #
1301              
1302 0         0 my $literal = undef;
1303             my @items = map {
1304 0         0 ref $_
1305             ? $self->encode_object($_)
1306 0 0       0 : do {
1307 0         0 $literal++;
1308 0         0 $_
1309             }
1310              
1311             } @$array;
1312              
1313 0 0       0 if ($literal) {
1314 0         0 return map { [ $name , $attr , $_, $self->gen_id($array) ] } @items;
  0         0  
1315             }
1316             else {
1317 0   0     0 return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
1318             $attr,
1319             [ @items ],
1320             $self->gen_id($array)
1321             ];
1322             }
1323             }
1324             }
1325              
1326             sub encode_hash {
1327 1     1   4 my($self, $hash, $name, $type, $attr) = @_;
1328              
1329 1 50 33     4 if ($self->autotype && grep {!/$SOAP::Constants::ELMASK/o} keys %$hash) {
  1         101  
1330 0 0       0 warn qq!Cannot encode @{[$name ? "'$name'" : 'unnamed']} element as 'hash'. Will be encoded as 'map' instead\n! if $^W;
  0 0       0  
1331 0   0     0 return $self->as_map($hash, $name || gen_name, $type, $attr);
1332             }
1333              
1334 1 50 33     6 $type = 'SOAPStruct'
      33        
1335             if $self->autotype && !defined($type) && exists $self->maptype->{SOAPStruct};
1336 1         5 return [$name || gen_name,
1337             $self->autotype ? {'xsi:type' => $self->maptypetouri($type), %$attr} : { %$attr },
1338 1 50 33     6 [map {$self->encode_object($hash->{$_}, $_)} keys %$hash],
1339             $self->gen_id($hash)
1340             ];
1341             }
1342              
1343             sub as_ordered_hash {
1344 0     0   0 my ($self, $value, $name, $type, $attr) = @_;
1345 0 0       0 die "Not an ARRAY reference for 'ordered_hash' type" unless UNIVERSAL::isa($value => 'ARRAY');
1346 0         0 return [ $name, $attr,
1347 0         0 [map{$self->encode_object(@{$value}[2*$_+1,2*$_])} 0..$#$value/2 ],
  0         0  
1348             $self->gen_id($value)
1349             ];
1350             }
1351              
1352             sub as_map {
1353 0     0   0 my ($self, $value, $name, $type, $attr) = @_;
1354 0 0       0 die "Not a HASH reference for 'map' type" unless UNIVERSAL::isa($value => 'HASH');
1355 0   0     0 my $prefix = ($self->namespaces->{$SOAP::Constants::NS_APS} ||= 'apachens');
1356 0         0 my @items = map {
1357 0         0 $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 0         0 $name,
1369             {'xsi:type' => "$prefix:Map", %$attr},
1370             [@items],
1371             $self->gen_id($value)
1372             ];
1373             }
1374              
1375             sub as_xml {
1376 0     0   0 my $self = shift;
1377 0         0 my($value, $name, $type, $attr) = @_;
1378 0         0 return [$name, {'_xml' => 1}, $value];
1379             }
1380              
1381             sub typecast {
1382 106     106   134 my $self = shift;
1383 106         236 my($value, $name, $type, $attr) = @_;
1384 106 100       670 return if ref $value; # skip complex object, caller knows how to deal with it
1385 25 100 66     103 return if $self->autotype && !defined $type; # we don't know, autotype knows
1386 5 50 33     66 return [$name,
1387             {(defined $type && $type gt '' ? ('xsi:type' => $self->maptypetouri($type, 'simple type')) : ()), %$attr},
1388             $value
1389             ];
1390             }
1391              
1392             sub register_ns {
1393 68     68   250 my $self = shift->new();
1394 68         142 my ($ns,$prefix) = @_;
1395 68 100       185 $prefix = gen_ns if !$prefix;
1396 68 100       275 $self->{'_namespaces'}->{$ns} = $prefix if $ns;
1397             }
1398              
1399             sub find_prefix {
1400 5     5   8 my ($self, $ns) = @_;
1401 5 100       28 return (exists $self->{'_namespaces'}->{$ns})
1402             ? $self->{'_namespaces'}->{$ns}
1403             : ();
1404             }
1405              
1406             sub fixattrs {
1407 99     99   146 my ($self, $data) = @_;
1408 99         279 my ($name, $attr) = ($data->SOAP::Data::name, {%{$data->SOAP::Data::attr}});
  99         283  
1409 99         265 my ($xmlns, $prefix) = ($data->uri, $data->prefix);
1410 99 100 66     493 unless (defined($xmlns) || defined($prefix)) {
1411 56 100       180 $self->register_ns($xmlns,$prefix) unless ($self->use_default_ns);
1412 56         168 return ($name, $attr);
1413             }
1414 43   33     125 $name ||= gen_name(); # local name
1415 43 50 33     204 $prefix = gen_ns() if !defined $prefix && $xmlns gt '';
1416 43 50 33     598 $prefix = ''
      33        
      33        
1417             if defined $xmlns && $xmlns eq ''
1418             || defined $prefix && $prefix eq '';
1419              
1420 43 50 0     112 $attr->{join ':', xmlns => $prefix || ()} = $xmlns if defined $xmlns;
1421 43 50       154 $name = join ':', $prefix, $name if $prefix;
1422              
1423 43 100       147 $self->register_ns($xmlns,$prefix) unless ($self->use_default_ns);
1424              
1425 43         136 return ($name, $attr);
1426              
1427             }
1428              
1429             sub toqname {
1430 21     21   46 my $self = shift;
1431 21         42 my $long = shift;
1432              
1433 21 50       126 return $long unless $long =~ /^\{(.*)\}(.+)$/;
1434 21   33     252 return SOAP::Utils::qualify $self->namespaces->{$1} ||= gen_ns, $2;
1435             }
1436              
1437             sub attrstoqname {
1438 99     99   133 my $self = shift;
1439 99         128 my $attrs = shift;
1440              
1441             return {
1442 99 50 33     260 map { /^\{(.*)\}(.+)$/
  34 100       363  
1443             ? ($self->toqname($_) => $2 eq 'type'
1444             || $2 eq 'arrayType'
1445             ? $self->toqname($attrs->{$_})
1446             : $attrs->{$_})
1447             : ($_ => $attrs->{$_})
1448             } keys %$attrs
1449             };
1450             }
1451              
1452             sub tag {
1453 81     81   190 my ($self, $tag, $attrs, @values) = @_;
1454              
1455 81         153 my $readable = $self->{ _readable };
1456              
1457 81         175 my $value = join '', @values;
1458 81 50       209 my $indent = $readable ? ' ' x (($self->{ _level }-1)*2) : '';
1459              
1460             # check for special attribute
1461 81 50 33     260 return "$indent$value" if exists $attrs->{_xml} && delete $attrs->{_xml};
1462              
1463 81 50       1364 die "Element '$tag' can't be allowed in valid XML message. Died."
1464             if $tag !~ /^$SOAP::Constants::NSMASK$/o;
1465              
1466 81 50       318 warn "Element '$tag' uses the reserved prefix 'XML' (in any case)"
1467             if $tag !~ /^(?![Xx][Mm][Ll])/;
1468              
1469 81 50       239 my $prolog = $readable ? "\n" : "";
1470 81 50       217 my $epilog = $readable ? "\n" : "";
1471 81         98 my $tagjoiner = " ";
1472 81 100       225 if ($self->{ _level } == 1) {
1473 22         89 my $namespaces = $self->namespaces;
1474 22         93 foreach (keys %$namespaces) {
1475 87         213 $attrs->{SOAP::Utils::qualify(xmlns => $namespaces->{$_})} = $_
1476             }
1477 22 50       113 $prolog = qq!encoding]}"?>!
  22         81  
1478             if defined $self->encoding;
1479 22 50       97 $prolog .= "\n" if $readable;
1480 22 50       118 $tagjoiner = " \n".(' ' x 4 ) if $readable;
1481             }
1482 149         328 my $tagattrs = join($tagjoiner, '',
1483 200 100 66     1337 map { sprintf '%s="%s"', $_, SOAP::Utils::encode_attribute($attrs->{$_}) }
      66        
1484 81         352 grep { $_ && defined $attrs->{$_} && ($_ ne 'xsi:type' || $attrs->{$_} ne '') }
1485             sort keys %$attrs);
1486              
1487 81 100       345 if ($value gt '') {
1488 69 100       1015 return sprintf("$prolog$indent<%s%s>%s%s$epilog",$tag,$tagattrs,$value,($value =~ /^\s*
1489             }
1490             else {
1491 12         117 return sprintf("$prolog$indent<%s%s />$epilog$indent",$tag,$tagattrs);
1492             }
1493             }
1494              
1495             sub xmlize {
1496 81     81   128 my $self = shift;
1497 81         87 my($name, $attrs, $values, $id) = @{$_[0]};
  81         204  
1498 81   50     198 $attrs ||= {};
1499              
1500 81         341 local $self->{_level} = $self->{_level} + 1;
1501              
1502 81 100       213 return $self->tag($name, $attrs)
1503             unless defined $values;
1504              
1505 70 100       245 return $self->tag($name, $attrs, $values)
1506             unless ref $values eq "ARRAY";
1507              
1508 52 100       201 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 51 100 66     306 if (defined $id && $self->{ _seen }->{ $id }->{ multiref}) {
1513 1         3 return $self->tag($name,
1514             {
1515             %$attrs, id => $self->multiref_anchor($id)
1516             },
1517 1         6 map {$self->xmlize($_)} @$values
1518             );
1519             }
1520             else {
1521 50         94 return $self->tag($name, $attrs, map {$self->xmlize($_)} @$values);
  58         309  
1522             }
1523             }
1524              
1525             sub uriformethod {
1526 12     12   34 my $self = shift;
1527              
1528 12   33     75 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 12 50       252 my($prefix, $method) = $method_is_data
1532             ? ($_[0]->prefix, $_[0]->name)
1533             : SOAP::Utils::splitqname($_[0]);
1534              
1535 12         33 my $attr = {reverse %{$self->namespaces}};
  12         74  
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 12 50 0     155 my $uri = $method_is_data
1545             ? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri)
1546             : $self->uri;
1547              
1548 12 50 0     57 defined $uri or $uri = $attr->{$prefix || ''};
1549              
1550 12 0 0     69 defined $uri or $uri = !$prefix || $prefix eq $self->envprefix
    50 0        
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 12         89 return ($uri, $method);
1561             }
1562              
1563 3     3   12 sub serialize { SOAP::Trace::trace('()');
1564 3         12 my $self = shift->new;
1565 3 50       11 @_ == 1 or Carp::croak "serialize() method accepts one parameter";
1566              
1567 3         15 $self->seen({}); # reinitialize multiref table
1568 3         13 my($encoded) = $self->encode_object($_[0]);
1569              
1570             # now encode multirefs if any
1571             # v -------------- subelements of Envelope
1572 3 100       15 push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2];
  2         8  
1573 3         12 return $self->xmlize($encoded);
1574             }
1575              
1576             sub envelope {
1577 19     19   80 SOAP::Trace::trace('()');
1578 19         71 my $self = shift->new;
1579 19         48 my $type = shift;
1580 19         34 my(@parameters, @header);
1581 19         61 for (@_) {
1582             # Find all the SOAP Headers
1583 31 50 100     824 if (defined($_) && ref($_) && UNIVERSAL::isa($_ => 'SOAP::Header')) {
    50 66        
      100        
      100        
      66        
1584 0         0 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 0         0 $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 31         105 push(@parameters, $_);
1596             # push (@parameters, SOAP::Utils::encode_data($_));
1597             }
1598             }
1599 19 50       104 my $header = @header ? SOAP::Data->set_value(@header) : undef;
1600 19         53 my($body,$parameters);
1601 19 100 66     135 if ($type eq 'method' || $type eq 'response') {
    50          
    0          
    0          
1602 17         69 SOAP::Trace::method(@parameters);
1603              
1604 17         38 my $method = shift(@parameters);
1605             # or die "Unspecified method for SOAP call\n";
1606              
1607 17 100       72 $parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
1608 17 50       282 if (!defined($method)) {}
    50          
    100          
1609             elsif (UNIVERSAL::isa($method => 'SOAP::Data')) {
1610 0         0 $body = $method;
1611             }
1612             elsif ($self->use_default_ns) {
1613 14 100       89 if ($self->{'_ns_uri'}) {
1614 13         105 $body = SOAP::Data->name($method)
1615             ->attr({'xmlns' => $self->{'_ns_uri'} } );
1616             }
1617             else {
1618 1         3 $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 3         15 $body = SOAP::Data->name($method);
1630 3         15 my $pre = $self->find_prefix($self->{'_ns_uri'});
1631 3 50       17 $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 17 100       163 $body->set_value($parameters ? \$parameters : SOAP::Utils::encode_data()) if $body;
    50          
1641             }
1642             elsif ($type eq 'fault') {
1643 2         12 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 2 100       9 ? SOAP::Data->name(detail => do{
    100          
1655 1         2 my $detail = $parameters[2];
1656 1 50       4 ref $detail
1657             ? \$detail
1658             : SOAP::Utils::encode_data($detail)
1659             })
1660             : (),
1661             ));
1662             }
1663             elsif ($type eq 'freeform') {
1664 0         0 SOAP::Trace::freeform(@parameters);
1665 0         0 $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 0         0 die "Wrong type of envelope ($type) for SOAP call\n";
1673             }
1674              
1675 19         73 $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 19 50       122 my($encoded) = $self->encode_object(
    50          
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 19 100       120 $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 19 50       107 push(@{$encoded->[2]->[-1]->[2]}, $self->encode_multirefs) if ref $encoded->[2]->[-1]->[2];
  19         101  
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 19 100 66     94 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 19         93 return $self->xmlize($encoded);
1713             }
1714              
1715             # ======================================================================
1716              
1717             package SOAP::Parser;
1718              
1719 15     15   51 sub DESTROY { SOAP::Trace::objects('()') }
1720              
1721             sub xmlparser {
1722 18     18   64 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 18   50     53 || 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              
1734             sub parser {
1735 18     18   78 my $self = shift->new;
1736              
1737             # set the parser if passed
1738 18 50       83 if (my $parser = shift) {
1739 0         0 $self->{'_parser'} = shift;
1740 0         0 return $self;
1741             }
1742              
1743             # else return the parser or use XML::Parser::Lite
1744 18   33     241 return ($self->{'_parser'} ||= $self->xmlparser);
1745             }
1746              
1747             sub new {
1748 39     39   89 my $self = shift;
1749 39 100       152 return $self if ref $self;
1750 21         42 my $class = $self;
1751 21         67 SOAP::Trace::objects('()');
1752 21         151 return bless {_parser => shift}, $class;
1753             }
1754              
1755 18     18   226 sub decode { SOAP::Trace::trace('()');
1756 18         37 my $self = shift;
1757              
1758             $self->parser->setHandlers(
1759 0     0   0 Final => sub { shift; $self->final(@_) },
  0         0  
1760 0     0   0 Start => sub { shift; $self->start(@_) },
  0         0  
1761 0     0   0 End => sub { shift; $self->end(@_) },
  0         0  
1762 0     0   0 Char => sub { shift; $self->char(@_) },
  0         0  
1763 0     0   0 ExternEnt => sub { shift; die "External entity (pointing to '$_[1]') is not allowed" },
  0         0  
1764 18         97 );
1765             # my $parsed = $self->parser->parse($_[0]);
1766             # return $parsed;
1767             #
1768 0         0 my $ret = undef;
1769 0         0 eval {
1770 0         0 $ret = $self->parser->parse($_[0]);
1771             };
1772 0 0       0 if ($@) {
1773 0         0 $self->final; # Clean up in the event of an error
1774 0         0 die $@; # Pass back the error
1775             }
1776 0         0 return $ret;
1777             }
1778              
1779             sub final {
1780 0     0   0 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
1785             # and Craig Johnston
1786             # checked by number of tests in t/02-payload.t
1787              
1788 0         0 undef $self->{_values};
1789 0         0 $self->parser->setHandlers(
1790             Final => undef,
1791             Start => undef,
1792             End => undef,
1793             Char => undef,
1794             ExternEnt => undef,
1795             );
1796 0         0 $self->{_done};
1797             }
1798              
1799 0     0   0 sub start { push @{shift->{_values}}, [shift, {@_}] }
  0         0  
1800              
1801             # string concatenation changed to arrays which should improve performance
1802             # for strings with many entity-encoded elements.
1803             # Thanks to Mathieu Longtin
1804 0     0   0 sub char { push @{shift->{_values}->[-1]->[3]}, shift }
  0         0  
1805              
1806             sub end {
1807 0     0   0 my $self = shift;
1808 0         0 my $done = pop @{$self->{_values}};
  0         0  
1809 0         0 $done->[2] = defined $done->[3]
1810 0 0       0 ? join('',@{$done->[3]})
    0          
1811             : '' unless ref $done->[2];
1812 0         0 undef $done->[3];
1813 0         0 @{$self->{_values}}
  0         0  
1814 0 0       0 ? (push @{$self->{_values}->[-1]->[2]}, $done)
1815             : ($self->{_done} = $done);
1816             }
1817              
1818             # ======================================================================
1819              
1820             package SOAP::SOM;
1821              
1822 25     25   275 use Carp ();
  25         59  
  25         607  
1823 25     25   164 use SOAP::Lite::Utils;
  25         51  
  25         215  
1824              
1825             sub BEGIN {
1826 25     25   146 no strict 'refs';
  25         52  
  25         12402  
1827 25     25   430 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 25         174 for my $method (keys %path) {
1840             *$method = sub {
1841 0     0   0 my $self = shift;
1842 0 0       0 ref $self or return $path{$method};
1843 0 0       0 Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
1844 0         0 return $self->valueof($path{$method});
1845 250         1671 };
1846             }
1847 25         198 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 25         100 for my $method (keys %results) {
1856             *$method = sub {
1857 0     0   0 my $self = shift;
1858 0 0       0 ref $self or return $results{$method};
1859 0 0       0 Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
1860 0 0       0 defined $self->fault ? return : return $self->valueof($results{$method});
1861 150         995 };
1862             }
1863              
1864 25         79 for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils
1865 125         152 *$method = \&{'SOAP::Utils::'.$method};
  125         689  
1866             }
1867              
1868 25         186 __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';
1874 25     25   174 use overload fallback => 1, 'bool' => sub { @{shift->{_current}} > 0 };
  25     0   51  
  25         324  
  0         0  
  0         0  
1875              
1876 0     0   0 sub DESTROY { SOAP::Trace::objects('()') }
1877              
1878             sub new {
1879 0     0   0 my $self = shift;
1880 0   0     0 my $class = ref($self) || $self;
1881 0         0 my $content = shift;
1882 0         0 SOAP::Trace::objects('()');
1883 0         0 return bless { _content => $content, _current => [$content] } => $class;
1884             }
1885              
1886             sub parts {
1887 0     0   0 my $self = shift;
1888 0 0       0 if (@_) {
1889 0         0 $self->context->packager->parts(@_);
1890 0         0 return $self;
1891             }
1892             else {
1893 0         0 return $self->context->packager->parts;
1894             }
1895             }
1896              
1897             sub is_multipart {
1898 0     0   0 my $self = shift;
1899 0         0 return defined($self->parts);
1900             }
1901              
1902             sub current {
1903 0     0   0 my $self = shift;
1904 0 0       0 $self->{_current} = [@_], return $self if @_;
1905 0 0       0 return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
  0         0  
1906             }
1907              
1908             sub valueof {
1909 0     0   0 my $self = shift;
1910 0         0 local $self->{_current} = $self->{_current};
1911 0 0       0 $self->match(shift) if @_;
1912             return wantarray
1913 0         0 ? map {o_value($_)} @{$self->{_current}}
  0         0  
  0         0  
1914 0 0       0 : @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef;
    0          
1915             }
1916              
1917             sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
1918             wantarray
1919 0         0 ? map { bless $_ => 'SOAP::Header' } shift->dataof(@_)
1920 0 0   0   0 : do { # header returned by ->dataof can be undef in scalar context
1921 0         0 my $header = shift->dataof(@_);
1922 0 0       0 ref $header ? bless($header => 'SOAP::Header') : undef;
1923             };
1924             }
1925              
1926             sub dataof {
1927 0     0   0 my $self = shift;
1928 0         0 local $self->{_current} = $self->{_current};
1929 0 0       0 $self->match(shift) if @_;
1930             return wantarray
1931 0         0 ? map {$self->_as_data($_)} @{$self->{_current}}
  0         0  
  0         0  
1932 0 0       0 : @{$self->{_current}}
    0          
1933             ? $self->_as_data($self->{_current}->[0])
1934             : undef;
1935             }
1936              
1937             sub namespaceuriof {
1938 0     0   0 my $self = shift;
1939 0         0 local $self->{_current} = $self->{_current};
1940 0 0       0 $self->match(shift) if @_;
1941             return wantarray
1942 0         0 ? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}}
  0         0  
  0         0  
1943 0 0       0 : @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef;
    0          
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              
1955             sub _as_data {
1956 0     0   0 my $self = shift;
1957 0         0 my $node = shift;
1958              
1959 0         0 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 0 0       0 if ( defined o_child($node) ) {
1966 0         0 my @children;
1967 0         0 foreach my $child ( @{ o_child($node) } ) {
  0         0  
1968 0         0 push( @children, $self->_as_data($child) );
1969             }
1970 0         0 $data->set_value( \SOAP::Data->value(@children) );
1971             }
1972             else {
1973 0         0 $data->set_value( o_value($node) );
1974             }
1975              
1976 0         0 return $data;
1977             }
1978              
1979              
1980             sub match {
1981 0     0   0 my $self = shift;
1982 0         0 my $path = shift;
1983             $self->{_current} = [
1984 0         0 $path =~ s!^/!! || !@{$self->{_current}}
1985             ? $self->_traverse($self->{_content}, 1 => split '/' => $path)
1986 0 0 0     0 : map {$self->_traverse_tree(o_child($_), split '/' => $path)} @{$self->{_current}}
  0         0  
1987             ];
1988 0         0 return $self;
1989             }
1990              
1991             sub _traverse {
1992 0     0   0 my ($self, $pointer, $itself, $path, @path) = @_;
1993              
1994 0 0       0 die "Incorrect parameter" unless $itself =~/^\d+$/;
1995              
1996 0 0 0     0 if ($path && substr($path, 0, 1) eq '{') {
1997 0   0     0 $path = join '/', $path, shift @path while @path && $path !~ /}/;
1998             }
1999              
2000 0 0       0 my($op, $num) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/ if defined $path;
2001              
2002 0 0       0 return $pointer unless defined $path;
2003              
2004 0 0 0     0 if (! $op) {
    0          
2005 0         0 $op = '==';
2006             }
2007             elsif ($op eq '=' || $op eq '!') {
2008 0         0 $op .= '=';
2009             }
2010 0   0     0 my $numok = defined $num && eval "$itself $op $num";
2011 0 0 0     0 my $nameok = (o_lname($pointer) || '') =~ /(?:^|\})$path$/ if defined $path; # name can be with namespace
2012              
2013 0         0 my $anynode = $path eq '';
2014 0 0       0 unless ($anynode) {
2015 0 0       0 if (@path) {
2016 0 0 0     0 return if defined $num && !$numok || !defined $num && !$nameok;
      0        
      0        
2017             }
2018             else {
2019 0 0 0     0 return $pointer if defined $num && $numok || !defined $num && $nameok;
      0        
      0        
2020 0         0 return;
2021             }
2022             }
2023              
2024 0         0 my @walk;
2025 0 0       0 push @walk, $self->_traverse_tree([$pointer], @path) if $anynode;
2026 0 0       0 push @walk, $self->_traverse_tree(o_child($pointer), $anynode ? ($path, @path) : @path);
2027 0         0 return @walk;
2028             }
2029              
2030             sub _traverse_tree {
2031 0     0   0 my ($self, $pointer, @path) = @_;
2032              
2033             # can be list of children or value itself. Traverse only children
2034 0 0       0 return unless ref $pointer eq 'ARRAY';
2035              
2036 0         0 my $itself = 1;
2037              
2038 0         0 grep {defined}
  0         0  
2039 0 0 0     0 map {$self->_traverse($_, $itself++, @path)}
2040 0         0 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              
2048             package SOAP::Deserializer;
2049              
2050 25     25   45383 use vars qw(@ISA);
  25         64  
  25         1574  
2051 25     25   224 use SOAP::Lite::Utils;
  25         50  
  25         177  
2052 25     25   396 use Class::Inspector;
  25         178  
  25         804  
2053 25     25   26983 use URI::Escape qw{uri_unescape};
  25         58409  
  25         5523  
2054              
2055             @ISA = qw(SOAP::Cloneable);
2056              
2057 21     21   79 sub DESTROY { SOAP::Trace::objects('()') }
2058              
2059             sub BEGIN {
2060 25     25   195 __PACKAGE__->__mk_accessors( qw(ids hrefs parts parser
2061             base xmlschemas xmlschema context) );
2062             }
2063              
2064             # Cache (slow) Class::Inspector results
2065             my %_class_loaded=();
2066              
2067             sub new {
2068 54     54   1429 my $self = shift;
2069 54 100       205 return $self if ref $self;
2070 21         54 my $class = $self;
2071 21         73 SOAP::Trace::objects('()');
2072 84         560 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 21         181 $_ => 'SOAP::Lite::Deserializer::' . $SOAP::Constants::XML_SCHEMA_OF{$_}
2083             } keys %SOAP::Constants::XML_SCHEMA_OF
2084              
2085             },
2086             }, $class;
2087             }
2088              
2089             sub is_xml {
2090             # Added check for envelope delivery. Fairly standard with MMDF and sendmail
2091             # Thanks to Chris Davies
2092 19 100   19   327 $_[1] =~ /^\s*
2093             }
2094              
2095             sub baselocation {
2096 0     0   0 my $self = shift;
2097 0         0 my $location = shift;
2098 0 0       0 if ($location) {
2099 0         0 my $uri = URI->new($location);
2100             # make absolute location if relative
2101 0 0 0     0 $location = $uri->abs($self->base || 'thismessage:/')->as_string unless $uri->scheme;
2102             }
2103 0         0 return $location;
2104             }
2105              
2106             # Returns the envelope and populates SOAP::Packager with parts
2107             sub decode_parts {
2108 1     1   2 my $self = shift;
2109 1         6 my $env = $self->context->packager->unpackage($_[0],$self->context);
2110 0         0 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 0         0 foreach (@{$self->context->packager->parts}) {
  0         0  
2115 0         0 my $data = $_->bodyhandle->as_string;
2116 0         0 my $type = $_->head->mime_attr('Content-Type');
2117 0         0 my $location = $_->head->mime_attr('Content-Location');
2118 0         0 my $id = $_->head->mime_attr('Content-Id');
2119 0         0 $location = $self->baselocation($location);
2120 0 0 0     0 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 0 0 0     0 $self->ids->{$1} = $part if ($id && $id =~ m/^<([^>]+)>$/); # strip any leading and trailing brackets
2126 0 0       0 $self->ids->{$location} = $part if $location;
2127             }
2128 0         0 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
2133             sub decode {
2134 19     19   67 my $self = shift->new; # this actually is important
2135 19 100       107 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
2142             sub deserialize {
2143 19     19   1694 SOAP::Trace::trace('()');
2144 19         101 my $self = shift->new;
2145              
2146             # initialize
2147 19         314 $self->hrefs({});
2148 19         95 $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 19         103 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 0 0       0 if (keys %{$self->ids()}) {
  0         0  
2157 0         0 $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 0         0 $self->ids($parsed);
2163             }
2164 0         0 $self->decode_object($parsed);
2165 0         0 my $som = SOAP::SOM->new($parsed);
2166 0         0 $som->context($self->context); # TODO - try removing this and see if it works!
2167 0         0 return $som;
2168             }
2169              
2170             sub traverse_ids {
2171 0     0   0 my $self = shift;
2172 0         0 my $ref = shift;
2173 0         0 my($undef, $attrs, $children) = @$ref;
2174             # ^^^^^^ to fix nasty error on Mac platform (Carl K. Cunningham)
2175 0 0       0 $self->ids->{$attrs->{'id'}} = $ref if exists $attrs->{'id'};
2176 0 0       0 return unless ref $children;
2177 0         0 for (@$children) {
2178 0         0 $self->traverse_ids($_)
2179             };
2180             }
2181              
2182 25     25   466 use constant _ATTRS => 6;
  25         54  
  25         6622  
2183 25     25   154 use constant _NAME => 5;
  25         1454  
  25         3180  
2184              
2185             sub decode_object {
2186 0     0   0 my $self = shift;
2187 0         0 my $ref = shift;
2188 0         0 my($name, $attrs_ref, $children, $value) = @$ref;
2189              
2190 0         0 my %attrs = %{ $attrs_ref };
  0         0  
2191              
2192 0         0 $ref->[ _ATTRS ] = \%attrs; # make a copy for long attributes
2193              
2194 25     25   1652 use vars qw(%uris);
  25         101  
  25         20144  
2195             local %uris = (%uris, map {
2196 0         0 do { (my $ns = $_) =~ s/^xmlns:?//; $ns } => delete $attrs{$_}
  0         0  
  0         0  
  0         0  
2197 0         0 } grep {/^xmlns(:|$)/} keys %attrs);
2198              
2199 0         0 foreach (keys %attrs) {
2200 0 0       0 next unless m/^($SOAP::Constants::NSMASK?):($SOAP::Constants::NSMASK)$/;
2201              
2202             $1 =~ /^[xX][mM][lL]/ ||
2203             $uris{$1} &&
2204 0 0 0     0 do {
      0        
2205 0         0 $attrs{SOAP::Utils::longname($uris{$1}, $2)} = do {
2206 0         0 my $value = $attrs{$_};
2207 0 0 0     0 $2 ne 'type' && $2 ne 'arrayType'
    0 0        
      0        
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 0         0 1;
2215             }
2216             || die "Unresolved prefix '$1' for attribute '$_'\n";
2217             }
2218              
2219             # and now check the element
2220 0 0       0 my $ns = ($name =~ s/^($SOAP::Constants::NSMASK?):// ? $1 : '');
2221 0 0 0     0 $ref->[ _NAME ] = SOAP::Utils::longname(
    0          
2222             $ns
2223             ? ($uris{$ns} || die "Unresolved prefix '$ns' for element '$name'\n")
2224             : (defined $uris{''} ? $uris{''} : undef),
2225             $name
2226             );
2227              
2228 0 0       0 ($children, $value) = (undef, $children) unless ref $children;
2229              
2230 0         0 return $name => ($ref->[4] = $self->decode_value(
2231             [$ref->[ _NAME ], \%attrs, $children, $value]
2232             ));
2233             }
2234              
2235             sub decode_value {
2236 0     0   0 my $self = shift;
2237 0         0 my($name, $attrs, $children, $value) = @{ $_[0] };
  0         0  
2238              
2239             # check SOAP version if applicable
2240 25   0 25   171 use vars '$level'; local $level = $level || 0;
  25         53  
  25         17753  
  0         0  
2241 0 0       0 if (++$level == 1) {
2242 0         0 my($namespace, $envelope) = SOAP::Utils::splitlongname($name);
2243 0 0 0     0 SOAP::Lite->soapversion($namespace) if $envelope eq 'Envelope' && $namespace;
2244             }
2245              
2246 0 0       0 if (exists $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}) {
2247             # check encodingStyle
2248             # future versions may bind deserializer to encodingStyle
2249 0         0 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 0 0 0     0 if (defined $encodingStyle && length($encodingStyle)) {
2254 0         0 my %styles = map { $_ => undef } @SOAP::Constants::SUPPORTED_ENCODING_STYLES;
  0         0  
2255 0         0 my $found = 0;
2256 0         0 foreach my $e (split(/ +/,$encodingStyle)) {
2257 0 0       0 if (exists $styles{$e}) {
2258 0         0 $found ++;
2259             }
2260             }
2261 0 0 0     0 die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'"
      0        
2262             if (! $found) && !(SOAP::Lite->soapversion == 1.1 && $encodingStyle =~ /(?:^|\b)$SOAP::Constants::NS_ENC/);
2263             }
2264             }
2265 25     25   404 use vars '$arraytype'; # type of Array element specified on Array itself
  25         1335  
  25         6145  
2266             # either specified with xsi:type, or or array element
2267 0         0 my ($type) = grep { defined }
  0         0  
2268 0 0       0 map($attrs->{$_}, sort grep {/^\{$SOAP::Constants::NS_XSI_ALL\}type$/o} keys %$attrs),
2269             $name =~ /^\{$SOAP::Constants::NS_ENC\}/ ? $name : $arraytype;
2270 0         0 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 0 0       0 my ($schema, $class) = SOAP::Utils::splitlongname($type) if $type;
2274 0   0     0 my $schemaclass = defined($schema) && $self->{ _xmlschemas }->{$schema}
2275             || $self;
2276              
2277 0 0       0 if (! exists $_class_loaded{$schemaclass}) {
2278 25     25   160 no strict qw(refs);
  25         49  
  25         49925  
2279 0 0       0 if (! Class::Inspector->loaded($schemaclass) ) {
2280 0 0 0     0 eval "require $schemaclass" or die $@ if not ref $schemaclass;
2281             }
2282 0         0 $_class_loaded{$schemaclass} = undef;
2283             }
2284              
2285             # store schema that is used in parsed message
2286 0 0 0     0 $self->{ _xmlschema } = $schema if ($schema) && $schema =~ /XMLSchema/;
2287              
2288             # don't use class/type if anyType/ur-type is specified on wire
2289 0 0 0     0 undef $class
2290             if $schemaclass->can('anyTypeValue')
2291             && $schemaclass->anyTypeValue eq $class;
2292              
2293 0   0     0 my $method = 'as_' . ($class || '-'); # dummy type if not defined
2294 0 0       0 $class =~ s/__|\./::/g if $class;
2295              
2296 0         0 my $id = $attrs->{id};
2297 0 0 0     0 if (defined $id && exists $self->hrefs->{$id}) {
    0          
2298 0         0 return $self->hrefs->{$id};
2299             }
2300             elsif (exists $attrs->{href}) {
2301 0         0 (my $id = delete $attrs->{href}) =~ s/^(#|cid:|uuid:)?//;
2302 0         0 my $type=$1;
2303 0 0 0     0 $id=uri_unescape($id) if (defined($type) and $type eq 'cid:');
2304             # convert to absolute if not internal '#' or 'cid:'
2305 0 0       0 $id = $self->baselocation($id) unless $type;
2306 0 0       0 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 0         0 my $ids = $self->ids;
2312 0 0       0 if (ref($ids) ne 'HASH') {
2313 0         0 $self->ids({}); # reset list of ids first time through
2314 0         0 $self->traverse_ids($ids);
2315             }
2316 0 0       0 if (exists($self->ids->{$id})) {
2317 0         0 my $obj = ($self->decode_object(delete($self->ids->{$id})))[1];
2318 0         0 return $self->hrefs->{$id} = $obj;
2319             }
2320             else {
2321 0         0 die "Unresolved (wrong?) href ($id) in element '$name'\n";
2322             }
2323             }
2324              
2325             return undef if grep {
2326 0 0       0 /^$SOAP::Constants::NS_XSI_NILS$/ && do {
  0 0       0  
2327 0   0     0 my $class = $self->xmlschemas->{ $1 || $2 };
2328 0 0       0 eval "require $class" or die @$;;
2329 0         0 $class->as_undef($attrs->{$_})
2330             }
2331             } keys %$attrs;
2332              
2333             # try to handle with typecasting
2334 0         0 my $res = $self->typecast($value, $name, $attrs, $children, $type);
2335 0 0       0 return $res if defined $res;
2336              
2337             # ok, continue with others
2338 0 0 0     0 if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) {
    0 0        
      0        
2339 0         0 my $res = [];
2340 0 0       0 $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 0 0       0 my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}
2345             =~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/
2346 0         0 or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!;
2347              
2348 0 0       0 my @dimensions = map { $_ || undef } split /,/, $multisize;
  0         0  
2349 0         0 my $size = 1;
2350 0   0     0 foreach (@dimensions) { $size *= $_ || 0 }
  0         0  
2351              
2352             # TODO ähm, shouldn't this local be my?
2353 0         0 local $arraytype = $type;
2354              
2355             # multidimensional
2356 0 0       0 if ($multisize =~ /,/) {
2357 0         0 @$res = splitarray(
2358             [@dimensions],
2359 0 0       0 [map { scalar(($self->decode_object($_))[1]) } @{$children || []}]
  0         0  
2360             );
2361             }
2362             # normal
2363             else {
2364 0 0       0 @$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []};
  0         0  
  0         0  
2365             }
2366              
2367             # sparse (position)
2368 0 0 0     0 if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) {
2369 0         0 my @new;
2370 0         0 for (my $pos = 0; $pos < @$children; $pos++) {
2371             # TBD implement position in multidimensional array
2372 0 0       0 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 0         0 $new[$position] = $res->[$pos];
2375             }
2376 0         0 @$res = @new;
2377             }
2378              
2379             # partially transmitted (offset)
2380             # TBD implement offset in multidimensional array
2381 0 0       0 my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/
2382             if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"};
2383 0 0       0 unshift(@$res, (undef) x $offset) if $offset;
2384              
2385 0 0 0     0 die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n"
  0         0  
2386             if $multisize && $size < @$res;
2387              
2388             # extend the array if number of elements is specified
2389 0 0 0     0 $#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0];
2390              
2391 0 0 0     0 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 0         0 my $res = {};
2398 0 0       0 $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 0         0 my %child_count_of = ();
2403 0 0       0 foreach my $child (@{$children || []}) {
  0         0  
2404 0         0 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 0 0       0 if (not $child_count_of{$child_name}) {
    0          
2409             # first time to see this value: use scalar
2410 0         0 $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 0         0 $res->{$child_name} = [ $res->{$child_name}, $child_value ];
2415             }
2416             else {
2417             # already have an array: append to it
2418 0         0 push @{$res->{$child_name}}, $child_value;
  0         0  
2419             }
2420 0         0 $child_count_of{$child_name}++;
2421             }
2422             # End patch code
2423              
2424 0 0 0     0 return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res;
2425             }
2426             else {
2427 0         0 my $res;
2428 0 0       0 if (my $method_ref = $schemaclass->can($method)) {
2429 0         0 $res = $method_ref->($self, $value, $name, $attrs, $children, $type);
2430             }
2431             else {
2432 0         0 $res = $self->typecast($value, $name, $attrs, $children, $type);
2433 0 0       0 $res = $class ? die "Unrecognized type '$type'\n" : $value
    0          
2434             unless defined $res;
2435             }
2436 0 0       0 $self->hrefs->{$id} = $res if defined $id;
2437 0         0 return $res;
2438             }
2439             }
2440              
2441             sub splitarray {
2442 0     0   0 my @sizes = @{+shift};
  0         0  
2443 0         0 my $size = shift @sizes;
2444 0         0 my $array = shift;
2445              
2446 0 0       0 return splice(@$array, 0, $size) unless @sizes;
2447 0         0 my @array = ();
2448 0   0     0 push @array, [
      0        
2449             splitarray([@sizes], $array)
2450             ] while @$array && (!defined $size || $size--);
2451 0         0 return @array;
2452             }
2453              
2454 0     0   0 sub 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              
2460             package SOAP::Client;
2461              
2462              
2463 25     25   206 use SOAP::Lite::Utils;
  25         62  
  25         295  
2464              
2465             $VERSION = $SOAP::Lite::VERSION;
2466             sub BEGIN {
2467 25     25   174 __PACKAGE__->__mk_accessors(qw(endpoint code message
2468             is_success status options));
2469             }
2470              
2471             # ======================================================================
2472              
2473             package SOAP::Server::Object;
2474              
2475             sub gen_id; *gen_id = \&SOAP::Serializer::gen_id;
2476              
2477             my %alive;
2478             my %objects;
2479              
2480             sub objects_by_reference {
2481 0     0   0 shift;
2482 0         0 while (@_) {
2483             @alive{shift()} = ref $_[0]
2484             ? shift
2485             : sub {
2486 0 0   0   0 $_[1]-$_[$_[5] ? 5 : 4] > $SOAP::Constants::OBJS_BY_REF_KEEPALIVE
2487             }
2488 0 0       0 }
2489 0         0 keys %alive;
2490             }
2491              
2492             sub reference {
2493 0     0   0 my $self = shift;
2494 0         0 my $stamp = time;
2495 0         0 my $object = shift;
2496 0         0 my $id = $stamp . $self->gen_id($object);
2497              
2498             # this is code for garbage collection
2499 0         0 my $time = time;
2500 0         0 my $type = ref $object;
2501 0         0 my @objects = grep { $objects{$_}->[1] eq $type } keys %objects;
  0         0  
2502 0         0 for (grep { $alive{$type}->(scalar @objects, $time, @{$objects{$_}}) } @objects) {
  0         0  
  0         0  
2503 0         0 delete $objects{$_};
2504             }
2505              
2506 0         0 $objects{$id} = [$object, $type, $stamp];
2507 0         0 bless { id => $id } => ref $object;
2508             }
2509              
2510             sub references {
2511 0     0   0 my $self = shift;
2512 0 0       0 return @_ unless %alive; # small optimization
2513 0 0 0     0 return map {
2514 0         0 ref($_) && exists $alive{ref $_}
2515             ? $self->reference($_)
2516             : $_
2517             } @_;
2518             }
2519              
2520             sub object {
2521 0     0   0 my $self = shift;
2522 0   0     0 my $class = ref($self) || $self;
2523 0         0 my $object = shift;
2524 0 0 0     0 return $object unless ref($object) && $alive{ref $object} && exists $object->{id};
      0        
2525              
2526 0         0 my $reference = $objects{$object->{id}};
2527 0 0       0 die "Object with specified id couldn't be found\n" unless ref $reference->[0];
2528              
2529 0         0 $reference->[3] = time; # last access time
2530 0         0 return $reference->[0]; # reference to actual object
2531             }
2532              
2533             sub objects {
2534 0     0   0 my $self = shift;
2535 0 0       0 return @_ unless %alive; # small optimization
2536 0 0 0     0 return map {
2537 0         0 ref($_) && exists $alive{ref $_} && exists $_->{id}
2538             ? $self->object($_)
2539             : $_
2540             } @_;
2541             }
2542              
2543             # ======================================================================
2544              
2545             package SOAP::Server::Parameters;
2546              
2547             sub byNameOrOrder {
2548 0 0   0   0 unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
2549 0 0       0 warn "Last parameter is expected to be envelope\n" if $^W;
2550 0         0 pop;
2551 0         0 return @_;
2552             }
2553 0         0 my $params = pop->method;
2554 0         0 my @mandatory = ref $_[0] eq 'ARRAY'
2555 0 0       0 ? @{shift()}
2556             : die "list of parameters expected as the first parameter for byName";
2557 0         0 my $byname = 0;
2558 0         0 my @res = map { $byname += exists $params->{$_}; $params->{$_} } @mandatory;
  0         0  
  0         0  
2559 0 0       0 return $byname
2560             ? @res
2561             : @_;
2562             }
2563              
2564             sub byName {
2565 0 0   0   0 unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
2566 0 0       0 warn "Last parameter is expected to be envelope\n" if $^W;
2567 0         0 pop;
2568 0         0 return @_;
2569             }
2570 0 0       0 return @{pop->method}{ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName"};
  0         0  
  0         0  
2571             }
2572              
2573             # ======================================================================
2574              
2575             package SOAP::Server;
2576              
2577 25     25   1117 use Carp ();
  25         60  
  25         557  
2578 25     25   142 use Scalar::Util qw(weaken);
  25         44  
  25         9994  
2579 1     1   3 sub DESTROY { SOAP::Trace::objects('()') }
2580              
2581             sub 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 0     0   0 on_action => sub { ; },
2588             on_dispatch => sub {
2589 0     0   0 return;
2590             },
2591 1     1   5 );
2592             }
2593              
2594             sub new {
2595 13     13   17 my $self = shift;
2596 13 100       42 return $self if ref $self;
2597              
2598 1 50       3 unless (ref $self) {
2599 1         4 my $class = $self;
2600 1         2 my(@params, @methods);
2601              
2602 1         6 while (@_) {
2603 0         0 my($method, $params) = splice(@_,0,2);
2604 0 0 0     0 $class->can($method)
2605             ? push(@methods, $method, $params)
2606             : $^W && Carp::carp "Unrecognized parameter '$method' in new()";
2607             }
2608              
2609 1         11 $self = bless {
2610             _dispatch_to => [],
2611             _dispatch_with => {},
2612             _dispatched => [],
2613             _action => '',
2614             _options => {},
2615             } => $class;
2616 1         5 unshift(@methods, $self->initialize);
2617 25     25   149 no strict qw(refs);
  25         65  
  25         2833  
2618 1         7 while (@methods) {
2619 6         14 my($method, $params) = splice(@methods,0,2);
2620 6 50       30 $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
2621             }
2622 1         3 SOAP::Trace::objects('()');
2623             }
2624              
2625 1 50 33     6 Carp::carp "Odd (wrong?) number of parameters in new()"
2626             if $^W && (@_ & 1);
2627              
2628 25     25   132 no strict qw(refs);
  25         44  
  25         6766  
2629 1         6 while (@_) {
2630 0         0 my($method, $params) = splice(@_,0,2);
2631 0 0 0     0 $self->can($method)
    0          
2632             ? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
2633             : $^W && Carp::carp "Unrecognized parameter '$method' in new()"
2634             }
2635              
2636 1         3 return $self;
2637             }
2638              
2639             sub init_context {
2640 1     1   2 my $self = shift;
2641 1         3 $self->{'_deserializer'}->{'_context'} = $self;
2642             # weaken circular reference to avoid a memory hole
2643 1         7 weaken($self->{'_deserializer'}->{'_context'});
2644              
2645 1         2 $self->{'_serializer'}->{'_context'} = $self;
2646             # weaken circular reference to avoid a memory hole
2647 1         5 weaken($self->{'_serializer'}->{'_context'});
2648             }
2649              
2650             sub BEGIN {
2651 25     25   171 no strict 'refs';
  25         44  
  25         11513  
2652 25     25   1508 for my $method (qw(serializer deserializer transport)) {
2653 75         1607 my $field = '_' . $method;
2654             *$method = sub {
2655 6     6   15 my $self = shift->new();
2656 6 100       13 if (@_) {
2657 3         10 my $context = $self->{$field}->{'_context'}; # save the old context
2658 3         6 $self->{$field} = shift;
2659 3         15 $self->{$field}->{'_context'} = $context; # restore the old context
2660 3         8 return $self;
2661             }
2662             else {
2663 3         18 return $self->{$field};
2664             }
2665             }
2666 75         609 }
2667              
2668 25         67 for my $method (qw(action myuri options dispatch_with packager)) {
2669 125         1650 my $field = '_' . $method;
2670             *$method = sub {
2671 4     4   14 my $self = shift->new();
2672             (@_)
2673 4 100       27 ? do {
2674 1         8 $self->{$field} = shift;
2675 1         4 return $self;
2676             }
2677             : return $self->{$field};
2678             }
2679 125         2312 }
2680 25         66 for my $method (qw(on_action on_dispatch)) {
2681 50         115 my $field = '_' . $method;
2682             *$method = sub {
2683 2     2   5 my $self = shift->new;
2684             # my $self = shift;
2685 2 50       7 return $self->{$field} unless @_;
2686 2         1 local $@;
2687             # commented out because that 'eval' was unsecure
2688             # > ref $_[0] eq 'CODE' ? shift : eval shift;
2689             # Am I paranoid enough?
2690 2         6 $self->{$field} = shift;
2691 2 50       5 Carp::croak $@ if $@;
2692 2 50       8 Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)"
2693             unless ref $self->{$field} eq 'CODE';
2694 2         6 return $self;
2695             }
2696 50         313 }
2697              
2698             # __PACKAGE__->__mk_accessors( qw(dispatch_to) );
2699 25         55 for my $method (qw(dispatch_to)) {
2700 25         55 my $field = '_' . $method;
2701             *$method = sub {
2702 1     1   460 my $self = shift->new;
2703             # my $self = shift;
2704             (@_)
2705 0         0 ? do {
2706 1         5 $self->{$field} = [@_];
2707 1         4 return $self;
2708             }
2709 1 50       5 : return @{ $self->{$field} };
2710             }
2711 25         22972 }
2712             }
2713              
2714             sub objects_by_reference {
2715 0     0   0 my $self = shift;
2716 0 0       0 $self = $self->new() if not ref $self;
2717             @_
2718 0 0       0 ? (SOAP::Server::Object->objects_by_reference(@_), return $self)
2719             : SOAP::Server::Object->objects_by_reference;
2720             }
2721              
2722             sub dispatched {
2723 0     0   0 my $self = shift;
2724 0 0       0 $self = $self->new() if not ref $self;
2725             @_
2726 0         0 ? (push(@{$self->{_dispatched}}, @_), return $self)
  0         0  
2727 0 0       0 : return @{$self->{_dispatched}};
2728             }
2729              
2730             sub find_target {
2731 0     0   0 my $self = shift;
2732 0         0 my $request = shift;
2733              
2734             # try to find URI/method from on_dispatch call first
2735 0         0 my($method_uri, $method_name) = $self->on_dispatch->($request);
2736              
2737             # if nothing there, then get it from envelope itself
2738 0         0 $request->match((ref $request)->method);
2739 0 0 0     0 ($method_uri, $method_name) = ($request->namespaceuriof || '', $request->dataof->name)
2740             unless $method_name;
2741              
2742 0         0 $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 0 0       0 die "Denied access to method ($method_name)\n" unless $method_name =~ /^\w+$/;
2747              
2748 0         0 my ($class, $static);
2749             # try to bind directly
2750 0 0 0     0 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 0 0       0 return ($class, $method_uri, $method_name) if ref $class;
2757 0         0 $static = 1;
2758             }
2759             else {
2760 0 0       0 die "URI path shall map to class" unless defined ($class = URI->new($method_uri)->path);
2761              
2762 0         0 for ($class) { s!^/|/$!!g; s!/!::!g; s/^$/main/; }
  0         0  
  0         0  
  0         0  
2763 0 0       0 die "Failed to access class ($class)" unless $class =~ /^(\w[\w:]*)$/;
2764              
2765 0         0 my $fullname = "$class\::$method_name";
2766 0         0 foreach ($self->dispatch_to) {
2767 0 0       0 return ($_, $method_uri, $method_name) if ref eq $class; # $OBJECT
2768 0 0       0 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 0         0 eval {
2772 0   0     0 $static ||= $class =~ /^$_$/ # MODULE
      0        
2773             || $fullname =~ /^$_$/ # MODULE::method
2774             || $method_name =~ /^$_$/ && ($class eq 'main'); # method ('main' assumed)
2775             };
2776             }
2777             }
2778              
2779 25     25   170 no strict 'refs';
  25         1333  
  25         21785  
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 0 0 0     0 unless (($class eq 'main') || $class->can($method_name)
      0        
2799             || exists($INC{join '/', split /::/, $class . '.pm'})) {
2800              
2801             # allow all for static and only specified path for dynamic bindings
2802 0 0       0 local @INC = (($static ? @INC : ()), grep {!ref && m![/\\.]!} $self->dispatch_to());
  0 0       0  
2803 0         0 eval 'local $^W; ' . "require $class";
2804 0 0       0 die "Failed to access class ($class): $@" if $@;
2805 0 0       0 $self->dispatched($class) unless $static;
2806             }
2807              
2808 0         0 die "Denied access to method ($method_name) in class ($class)"
2809 0 0 0     0 unless $static || grep {/^$class$/} $self->dispatched;
2810              
2811 0         0 return ($class, $method_uri, $method_name);
2812             }
2813              
2814             sub handle {
2815 1     1   15 SOAP::Trace::trace('()');
2816 1         1 my $self = shift;
2817 1 50       6 $self = $self->new if !ref $self; # inits the server when called in a static context
2818 1         4 $self->init_context();
2819             # we want to restore it when we are done
2820 1         3 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 1         2 my $result = eval {
2827 1         4 local $SIG{__DIE__};
2828             # why is this here:
2829 1         3 $self->serializer->soapversion(1.1);
2830 1         3 my $request = eval { $self->deserializer->deserialize($_[0]) };
  1         3  
2831              
2832 1 50 33     23 die SOAP::Fault
2833             ->faultcode($SOAP::Constants::FAULT_VERSION_MISMATCH)
2834             ->faultstring($@)
2835             if $@ && $@ =~ /^$SOAP::Constants::WRONG_VERSION/;
2836              
2837 1 50       11 die "Application failed during request deserialization: $@" if $@;
2838 0         0 my $som = ref $request;
2839 0 0       0 die "Can't find root element in the message"
2840             unless $request->match($som->envelope);
2841 0         0 $self->serializer->soapversion(SOAP::Lite->soapversion);
2842 0 0       0 $self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA
2843             = $self->deserializer->xmlschema)
2844             if $self->deserializer->xmlschema;
2845              
2846 0 0 0     0 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 0 0 0     0 $_->mustUnderstand
2852             && (!$_->actor || $_->actor eq $SOAP::Constants::NEXT_ACTOR)
2853             } $request->dataof($som->headers);
2854              
2855 0 0       0 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 0         0 my($class, $method_uri, $method_name) = $self->find_target($request);
2860 0         0 my @results = eval {
2861 0         0 local $^W;
2862 0         0 my @parameters = $request->paramsin;
2863              
2864             # SOAP::Trace::dispatch($fullname);
2865 0         0 SOAP::Trace::parameters(@parameters);
2866              
2867 0 0       0 push @parameters, $request
2868             if UNIVERSAL::isa($class => 'SOAP::Server::Parameters');
2869              
2870 25     25   161 no strict qw(refs);
  25         52  
  25         27483  
2871             SOAP::Server::Object->references(
2872             defined $parameters[0]
2873             && ref $parameters[0]
2874             && UNIVERSAL::isa($parameters[0] => $class)
2875 0 0 0     0 ? do {
2876 0         0 my $object = shift @parameters;
2877 0 0       0 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 0         0 SOAP::Trace::result(@results);
2894              
2895             # let application errors pass through with 'Server' code
2896 0 0       0 die ref $@
    0          
    0          
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 0         0 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 0         0 return $result;
2908             };
2909              
2910             # void context
2911 1 50       5 return unless defined wantarray;
2912              
2913             # normal result
2914 1 50       8 return $result unless $@;
2915              
2916             # check fails, something wrong with message
2917 1 50       8 return $self->make_fault($SOAP::Constants::FAULT_CLIENT, $@) unless ref $@;
2918              
2919             # died with SOAP::Fault
2920 0 0 0     0 return $self->make_fault($@->faultcode || $SOAP::Constants::FAULT_SERVER,
      0        
2921             $@->faultstring || 'Application error',
2922             $@->faultdetail, $@->faultactor)
2923             if UNIVERSAL::isa($@ => 'SOAP::Fault');
2924              
2925             # died with complex detail
2926 0         0 return $self->make_fault($SOAP::Constants::FAULT_SERVER, 'Application error' => $@);
2927              
2928             } # end of handle()
2929              
2930             sub make_fault {
2931 1     1   2 my $self = shift;
2932 1         3 my($code, $string, $detail, $actor) = @_;
2933 1   33     4 $self->serializer->fault($code, $string, $detail, $actor || $self->myuri);
2934             }
2935              
2936             # ======================================================================
2937              
2938             package SOAP::Trace;
2939              
2940 25     25   174 use Carp ();
  25         46  
  25         1021  
2941              
2942             my @list = qw(
2943             transport dispatch result
2944             parameters headers objects
2945             method fault freeform
2946             trace debug);
2947             {
2948 25     25   132 no strict 'refs';
  25         56  
  25         4643  
2949             for (@list) {
2950 551     551   12100 *$_ = sub {}
2951             }
2952             }
2953              
2954             sub defaultlog {
2955 0     0   0 my $caller = (caller(1))[3]; # the 4th element returned by caller is the subroutine name
2956 0 0       0 $caller = (caller(2))[3] if $caller =~ /eval/;
2957 0         0 chomp(my $msg = join ' ', @_);
2958 0         0 printf STDERR "%s: %s\n", $caller, $msg;
2959             }
2960              
2961             sub import {
2962 25     25   138 no strict 'refs';
  25         52  
  25         893  
2963 25     25   142 no warnings qw{ redefine }; # suppress warnings about redefining
  25         62  
  25         9827  
2964 0     0   0 my $pack = shift;
2965 0         0 my(@notrace, @symbols);
2966 0         0 for (@_) {
2967 0 0       0 if (ref eq 'CODE') {
2968 0         0 my $call = $_;
2969 0     0   0 foreach (@symbols) { *$_ = sub { $call->(@_) } }
  0         0  
  0         0  
2970 0         0 @symbols = ();
2971             }
2972             else {
2973 0         0 local $_ = $_;
2974 0         0 my $minus = s/^-//;
2975 0         0 my $all = $_ eq 'all';
2976 0 0 0     0 Carp::carp "Illegal symbol for tracing ($_)" unless $all || $pack->can($_);
2977 0 0       0 $minus ? push(@notrace, $all ? @list : $_) : push(@symbols, $all ? @list : $_);
    0          
    0          
2978             }
2979             }
2980 0         0 foreach (@symbols) { *$_ = \&defaultlog }
  0         0  
2981 0     0   0 foreach (@notrace) { *$_ = sub {} }
  0         0  
  0         0  
2982             }
2983              
2984             # ======================================================================
2985              
2986             package SOAP::Custom::XML::Data;
2987              
2988 25     25   148 use vars qw(@ISA $AUTOLOAD);
  25         45  
  25         2468  
2989             @ISA = qw(SOAP::Data);
2990              
2991 25     25   147 use overload fallback => 1, '""' => sub { shift->value };
  25     0   60  
  25         392  
  0         0  
2992              
2993             sub _compileit {
2994 25     25   2524 no strict 'refs';
  25         52  
  25         5001  
2995 100     100   150 my $method = shift;
2996             *$method = sub {
2997 1 50   1   13 return __PACKAGE__->SUPER::name($method => $_[0]->attr->{$method})
2998             if exists $_[0]->attr->{$method};
2999 0 0 0     0 my @elems = grep {
3000 1         10 ref $_ && UNIVERSAL::isa($_ => __PACKAGE__)
3001             && $_->SUPER::name =~ /(^|:)$method$/
3002             } $_[0]->value;
3003 1 50       6 return wantarray? @elems : $elems[0];
3004 100         7747 };
3005             }
3006              
3007 25     25   69 sub BEGIN { foreach (qw(name type import use)) { _compileit($_) } }
  100         205  
3008              
3009             sub AUTOLOAD {
3010 0     0   0 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
3011 0 0       0 return if $method eq 'DESTROY';
3012              
3013 0         0 _compileit($method);
3014 0         0 goto &$AUTOLOAD;
3015             }
3016              
3017             # ======================================================================
3018              
3019             package SOAP::Custom::XML::Deserializer;
3020              
3021 25     25   260 use vars qw(@ISA);
  25         56  
  25         4582  
3022             @ISA = qw(SOAP::Deserializer);
3023              
3024             sub decode_value {
3025 0     0   0 my $self = shift;
3026 0         0 my $ref = shift;
3027 0         0 my($name, $attrs, $children, $value) = @$ref;
3028             # base class knows what to do with it
3029 0 0       0 return $self->SUPER::decode_value($ref) if exists $attrs->{href};
3030              
3031 0 0 0     0 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              
3041             package SOAP::Schema::Deserializer;
3042              
3043 25     25   147 use vars qw(@ISA);
  25         61  
  25         2509  
3044             @ISA = qw(SOAP::Custom::XML::Deserializer);
3045              
3046             # ======================================================================
3047              
3048             package SOAP::Schema::WSDL;
3049              
3050 25     25   126 use vars qw(%imported @ISA);
  25         43  
  25         46695  
3051             @ISA = qw(SOAP::Schema);
3052              
3053             sub new {
3054 0     0   0 my $self = shift;
3055              
3056 0 0       0 unless (ref $self) {
3057 0         0 my $class = $self;
3058 0         0 $self = $class->SUPER::new(@_);
3059             }
3060 0         0 return $self;
3061             }
3062              
3063             sub base {
3064 0     0   0 my $self = shift->new;
3065             @_
3066 0 0       0 ? ($self->{_base} = shift, return $self)
3067             : return $self->{_base};
3068             }
3069              
3070             sub import {
3071 0     0   0 my $self = shift->new;
3072 0         0 my $s = shift;
3073 0   0     0 my $base = shift || $self->base || die "Missing base argument for ", __PACKAGE__, "\n";
3074              
3075 0         0 my @a = $s->import;
3076 0         0 local %imported = %imported;
3077 0         0 foreach (@a) {
3078 0 0       0 next unless $_->location;
3079 0         0 my $location = URI->new_abs($_->location->value, $base)->as_string;
3080 0 0       0 if ($imported{$location}++) {
3081 0 0       0 warn "Recursion loop detected in service description from '$location'. Ignored\n" if $^W;
3082 0         0 return $s;
3083             }
3084 0         0 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 0 0       0 $root->SOAP::Data::name eq 'schema' ? do { # add element if there is no one
    0          
3091 0 0       0 $s->set_value($s->value, $self->deserializer->deserialize('')->root) unless $s->types;
3092 0         0 $s->types->set_value($s->types->value, $root) } :
3093 0         0 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 0         0 $s;
3098             }
3099              
3100             # TODO - This is woefully incomplete!
3101             sub parse_schema_element {
3102 0     0   0 my $element = shift;
3103             # Current element is a complex type
3104 0 0       0 if (defined($element->complexType)) {
    0          
3105 0         0 my @elements = ();
3106 0 0       0 if (defined($element->complexType->sequence)) {
3107              
3108 0         0 foreach my $e ($element->complexType->sequence->element) {
3109 0         0 push @elements,parse_schema_element($e);
3110             }
3111             }
3112 0         0 return @elements;
3113             }
3114             elsif ($element->simpleType) {
3115             }
3116             else {
3117 0         0 return $element;
3118             }
3119             }
3120              
3121             sub parse {
3122 0     0   0 my $self = shift->new;
3123 0         0 my($s, $service, $port) = @_;
3124 0         0 my @result;
3125              
3126             # handle imports
3127 0         0 $self->import($s);
3128              
3129             # handle descriptions without , aka tModel-type descriptions
3130 0         0 my @services = $s->service;
3131 0         0 my $tns = $s->{'_attr'}->{'targetNamespace'};
3132             # if there is no element we'll provide it
3133 0 0       0 @services = $self->deserializer->deserialize(<<"FAKE")->root->service unless @services;
3134            
3135 0   0     0
  0   0     0  
3136 0         0
3137            
3138            
3139             FAKE
3140              
3141 0         0 my $has_warned = 0;
3142 0         0 foreach (@services) {
3143 0         0 my $name = $_->name;
3144 0 0 0     0 next if $service && $service ne $name;
3145 0         0 my %services;
3146 0         0 foreach ($_->port) {
3147 0 0 0     0 next if $port && $port ne $_->name;
3148 0         0 my $binding = SOAP::Utils::disqualify($_->binding);
3149 0 0       0 my $endpoint = ref $_->address ? $_->address->location : undef;
3150 0         0 foreach ($s->binding) {
3151             # is this a SOAP binding?
3152 0 0       0 next unless grep { $_->uri eq 'http://schemas.xmlsoap.org/wsdl/soap/' } $_->binding;
  0         0  
3153 0 0       0 next unless $_->name eq $binding;
3154 0         0 my $default_style = $_->binding->style;
3155 0         0 my $porttype = SOAP::Utils::disqualify($_->type);
3156 0         0 foreach ($_->operation) {
3157 0         0 my $opername = $_->name;
3158 0         0 $services{$opername} = {}; # should be initialized in 5.7 and after
3159 0         0 my $soapaction = $_->operation->soapAction;
3160 0   0     0 my $invocationStyle = $_->operation->style || $default_style || "rpc";
3161 0   0     0 my $encodingStyle = $_->input->body->use || "encoded";
3162 0   0     0 my $namespace = $_->input->body->namespace || $tns;
3163 0         0 my @parts;
3164 0         0 foreach ($s->portType) {
3165 0 0       0 next unless $_->name eq $porttype;
3166 0         0 foreach ($_->operation) {
3167 0 0       0 next unless $_->name eq $opername;
3168 0         0 my $inputmessage = SOAP::Utils::disqualify($_->input->message);
3169 0         0 foreach my $msg ($s->message) {
3170 0 0       0 next unless $msg->name eq $inputmessage;
3171 0 0 0     0 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 0         0 my ($input_ns,$input_name) = SOAP::Utils::splitqname($msg->part->element);
3175 0         0 foreach my $schema ($s->types->schema) {
3176 0         0 foreach my $element ($schema->element) {
3177 0 0       0 next unless $element->name eq $input_name;
3178 0         0 push @parts,parse_schema_element($element);
3179             }
3180 0         0 $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 0         0 @parts = $msg->part;
3187 0         0 $services{$opername}->{parameters} = [ @parts ];
3188             }
3189             }
3190             }
3191              
3192 0         0 for ($services{$opername}) {
3193 0         0 $_->{endpoint} = $endpoint;
3194 0         0 $_->{soapaction} = $soapaction;
3195 0         0 $_->{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 0         0 for ($name) { s/\W+/_/g; s/^(\d)/s$1/ }
  0         0  
  0         0  
3204 0         0 push @result, $name => \%services;
3205             }
3206 0         0 return @result;
3207             }
3208              
3209             # ======================================================================
3210              
3211             # Naming? SOAP::Service::Schema?
3212             package SOAP::Schema;
3213              
3214 25     25   177 use Carp ();
  25         51  
  25         4185  
3215              
3216 0     0   0 sub DESTROY { SOAP::Trace::objects('()') }
3217              
3218             sub new {
3219 0     0   0 my $self = shift;
3220 0 0       0 return $self if ref $self;
3221 0 0       0 unless (ref $self) {
3222 0         0 my $class = $self;
3223 0         0 require LWP::UserAgent;
3224 0         0 $self = bless {
3225             '_deserializer' => SOAP::Schema::Deserializer->new,
3226             '_useragent' => LWP::UserAgent->new,
3227             }, $class;
3228              
3229 0         0 SOAP::Trace::objects('()');
3230             }
3231              
3232 0 0 0     0 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
3233 25     25   139 no strict qw(refs);
  25         45  
  25         3581  
3234 0         0 while (@_) {
3235 0         0 my $method = shift;
3236 0 0       0 $self->$method(shift) if $self->can($method)
3237             }
3238              
3239 0         0 return $self;
3240             }
3241              
3242             sub schema {
3243 0     0   0 warn "SOAP::Schema->schema has been deprecated. "
3244             . "Please use SOAP::Schema->schema_url instead.";
3245 0         0 return shift->schema_url(@_);
3246             }
3247              
3248             sub BEGIN {
3249 25     25   150 no strict 'refs';
  25         48  
  25         2646  
3250 25     25   74 for my $method (qw(deserializer schema_url services useragent stub cache_dir cache_ttl)) {
3251 175         356 my $field = '_' . $method;
3252             *$method = sub {
3253 0     0   0 my $self = shift->new;
3254 0 0       0 @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
3255             }
3256 175         35652 }
3257             }
3258              
3259             sub parse {
3260 0     0   0 my $self = shift;
3261 0         0 my $s = $self->deserializer->deserialize($self->access)->root;
3262             # here should be something that defines what schema description we want to use
3263 0         0 $self->services({SOAP::Schema::WSDL->base($self->schema_url)->useragent($self->useragent)->parse($s, @_)});
3264              
3265             }
3266              
3267             sub refresh_cache {
3268 0     0   0 my $self = shift;
3269 0         0 my ($filename,$contents) = @_;
3270 0 0       0 open CACHE,">$filename" or Carp::croak "Could not open cache file for writing: $!";
3271 0         0 print CACHE $contents;
3272 0         0 close CACHE;
3273             }
3274              
3275             sub load {
3276 0     0   0 my $self = shift->new;
3277 0         0 local $^W; # suppress warnings about redefining
3278 0 0       0 foreach (keys %{$self->services || Carp::croak 'Nothing to load. Schema is not specified'}) {
  0         0  
3279             # TODO - check age of cached file, and delete if older than configured amount
3280 0 0       0 if ($self->cache_dir) {
3281 0         0 my $cached_file = File::Spec->catfile($self->cache_dir,$_.".pm");
3282 0   0     0 my $ttl = $self->cache_ttl || $SOAP::Constants::DEFAULT_CACHE_TTL;
3283 0         0 open (CACHE, "<$cached_file");
3284 0 0       0 my @stat = stat($cached_file) unless eof(CACHE);
3285 0         0 close CACHE;
3286 0 0       0 if (@stat) {
3287             # Cache exists
3288 0         0 my $cache_lived = time() - $stat[9];
3289 0 0 0     0 if ($ttl > 0 && $cache_lived > $ttl) {
3290 0         0 $self->refresh_cache($cached_file,$self->generate_stub($_));
3291             }
3292             }
3293             else {
3294             # Cache doesn't exist
3295 0         0 $self->refresh_cache($cached_file,$self->generate_stub($_));
3296             }
3297 0         0 push @INC,$self->cache_dir;
3298 0 0       0 eval "require $_" or Carp::croak "Could not load cached file: $@";
3299             }
3300             else {
3301 0 0       0 eval $self->generate_stub($_) or Carp::croak "Bad stub: $@";
3302             }
3303             }
3304 0         0 $self;
3305             }
3306              
3307             sub access {
3308 0     0   0 my $self = shift->new;
3309 0   0     0 my $url = shift || $self->schema_url || Carp::croak 'Nothing to access. URL is not specified';
3310 0 0       0 $self->useragent->env_proxy if $ENV{'HTTP_proxy'};
3311              
3312 0         0 my $req = HTTP::Request->new(GET => $url);
3313 0 0 0     0 $req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'})
3314             if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'});
3315              
3316 0         0 my $resp = $self->useragent->request($req);
3317 0 0       0 $resp->is_success ? $resp->content : die "Service description '$url' can't be loaded: ", $resp->status_line, "\n";
3318             }
3319              
3320             sub generate_stub {
3321 0     0   0 my $self = shift->new;
3322 0         0 my $package = shift;
3323 0         0 my $services = $self->services->{$package};
3324 0         0 my $schema_url = $self->schema_url;
3325              
3326 0         0 $self->{'_stub'} = <<"EOP";
3327 0         0 package $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]}]
3331             EOP
3332 0 0       0 $self->{'_stub'} .= "# -- generated from $schema_url\n" if $schema_url;
3333 0         0 $self->{'_stub'} .= 'my %methods = ('."\n";
3334 0         0 foreach my $service (keys %$services) {
3335 0         0 $self->{'_stub'} .= "'$service' => {\n";
3336 0         0 foreach (qw(endpoint soapaction namespace)) {
3337 0         0 $self->{'_stub'} .= " $_ => '".$services->{$service}{$_}."',\n";
3338             }
3339 0         0 $self->{'_stub'} .= " parameters => [\n";
3340 0         0 foreach (@{$services->{$service}{parameters}}) {
  0         0  
3341             # This is a workaround for https://sourceforge.net/tracker/index.php?func=detail&aid=2001592&group_id=66000&atid=513017
3342 0 0       0 next unless ref $_;
3343 0         0 $self->{'_stub'} .= " SOAP::Data->new(name => '".$_->name."', type => '".$_->type."', attr => {";
3344 0         0 $self->{'_stub'} .= do {
3345 0         0 my %attr = %{$_->attr};
  0         0  
3346 0         0 join(', ', map {"'$_' => '$attr{$_}'"}
  0         0  
3347 0         0 grep {/^xmlns:(?!-)/}
3348             keys %attr);
3349             };
3350 0         0 $self->{'_stub'} .= "}),\n";
3351             }
3352 0         0 $self->{'_stub'} .= " ], # end parameters\n";
3353 0         0 $self->{'_stub'} .= " }, # end $service\n";
3354             }
3355 0         0 $self->{'_stub'} .= "); # end my %methods\n";
3356 0         0 $self->{'_stub'} .= <<'EOP';
3357              
3358             use SOAP::Lite;
3359             use Exporter;
3360             use Carp ();
3361              
3362             use 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              
3367             sub _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}"!});
3391             EOP
3392 0         0 my $namespaces = $self->deserializer->ids->[1];
3393 0         0 foreach my $key (keys %{$namespaces}) {
  0         0  
3394 0         0 my ($ns,$prefix) = SOAP::Utils::splitqname($key);
3395 0 0 0     0 $self->{'_stub'} .= ' $self->serializer->register_ns("'.$namespaces->{$key}.'","'.$prefix.'");'."\n"
3396             if (defined $ns && ($ns eq "xmlns"));
3397             }
3398 0         0 $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              
3406             sub 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             }
3416             no strict 'refs';
3417             for 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              
3431             sub 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              
3437             1;
3438             EOP
3439 0         0 return $self->stub;
3440             }
3441              
3442             # ======================================================================
3443              
3444             package SOAP;
3445              
3446 25     25   264 use vars qw($AUTOLOAD);
  25         60  
  25         1485  
3447             require URI;
3448              
3449             my $soap; # shared between SOAP and SOAP::Lite packages
3450              
3451             {
3452 25     25   146 no strict 'refs';
  25         43  
  25         13347  
3453             *AUTOLOAD = sub {
3454 0     0   0 local($1,$2);
3455 0         0 my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
3456 0 0       0 return if $method eq 'DESTROY';
3457              
3458 0 0 0     0 my $soap = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite')
      0        
3459             ? $_[0]
3460             : $soap
3461             || die "SOAP:: prefix shall only be used in combination with +autodispatch option\n";
3462              
3463 0         0 my $uri = URI->new($soap->uri);
3464 0         0 my $currenturi = $uri->path;
3465 0 0 0     0 $package = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite')
    0 0        
    0 0        
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 0         0 my $pack = $package;
  0         0  
3478 0         0 for ($pack) { s!^/!!; s!/!::!g; }
  0         0  
  0         0  
3479 0 0 0     0 shift @_ if @_ && !ref $_[0] && ($_[0] eq $pack || $_[0] eq 'SOAP')
      0        
      0        
      0        
      0        
3480             || ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite');
3481             }
3482              
3483 0         0 for ($package) { s!::!/!g; s!^/?!/!; }
  0         0  
  0         0  
3484 0         0 $uri->path($package);
3485              
3486 0         0 my $som = $soap->uri($uri->as_string)->call($method => @_);
3487 0 0       0 UNIVERSAL::isa($som => 'SOAP::SOM')
    0          
3488             ? wantarray
3489             ? $som->paramsall
3490             : $som->result
3491             : $som;
3492             };
3493             }
3494              
3495             # ======================================================================
3496              
3497             package SOAP::Lite;
3498              
3499 25     25   159 use vars qw($AUTOLOAD @ISA);
  25         65  
  25         1373  
3500 25     25   144 use Carp ();
  25         58  
  25         513  
3501              
3502 25     25   167 use SOAP::Lite::Utils;
  25         48  
  25         222  
3503 25     25   31353 use SOAP::Constants;
  25         85  
  25         1038  
3504 25     25   24562 use SOAP::Packager;
  25         88  
  25         982  
3505              
3506 25     25   169 use Scalar::Util qw(weaken blessed);
  25         163  
  25         11600  
3507              
3508             @ISA = qw(SOAP::Cloneable);
3509              
3510             # provide access to global/autodispatched object
3511             sub self {
3512 0 0   0 1 0 @_ > 1
3513             ? $soap = $_[1]
3514             : $soap
3515             }
3516              
3517             # no more warnings about "used only once"
3518             *UNIVERSAL::AUTOLOAD if 0;
3519              
3520 0     0 0 0 sub autodispatched { \&{*UNIVERSAL::AUTOLOAD} eq \&{*SOAP::AUTOLOAD} };
  0         0  
  0         0  
3521              
3522             sub soapversion {
3523 51     51 1 124 my $self = shift;
3524 51 100       674 my $version = shift or return $SOAP::Constants::SOAP_VERSION;
3525              
3526 0         0 ($version) = grep {
3527 25 50       445 $SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV} eq $version
3528             } keys %SOAP::Constants::SOAP_VERSIONS
3529             unless exists $SOAP::Constants::SOAP_VERSIONS{$version};
3530              
3531 25 50 33     372 die qq!$SOAP::Constants::WRONG_VERSION Supported versions:\n@{[
  0         0  
3532 0         0 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 25         150 foreach (keys %$def) {
3537 125         7184 eval "\$SOAP::Constants::$_ = '$SOAP::Constants::SOAP_VERSIONS{$version}->{$_}'";
3538             }
3539              
3540 25         258 $SOAP::Constants::SOAP_VERSION = $version;
3541              
3542 25         1066 return $self;
3543             }
3544              
3545 25     25   165 BEGIN { SOAP::Lite->soapversion(1.1) }
3546              
3547             sub import {
3548 44     44   287 my $pkg = shift;
3549 44         224 my $caller = caller;
3550 25     25   140 no strict 'refs';
  25         46  
  25         3868  
3551             # emulate 'use SOAP::Lite 0.99' behavior
3552 44 50 66     335 $pkg->require_version(shift) if defined $_[0] && $_[0] =~ /^\d/;
3553              
3554 44         75199 while (@_) {
3555 8         17 my $command = shift;
3556              
3557 0         0 my @parameters = UNIVERSAL::isa($_[0] => 'ARRAY')
3558 8 50 66     105 ? @{shift()}
    100          
3559             : shift
3560             if @_ && $command ne 'autodispatch';
3561              
3562 8 100 66     140 if ($command eq 'autodispatch' || $command eq 'dispatch_from') {
    50 33        
    50          
    50          
3563 1   33     9 $soap = ($soap||$pkg)->new;
3564 25     25   145 no strict 'refs';
  25         46  
  25         16641  
3565 1 50       6 foreach ($command eq 'autodispatch'
3566             ? 'UNIVERSAL'
3567             : @parameters
3568             ) {
3569 1         2 my $sub = "${_}::AUTOLOAD";
3570 1         13 defined &{*$sub}
  0         0  
3571 1 0       3 ? (\&{*$sub} eq \&{*SOAP::AUTOLOAD}
  0 50       0  
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 0         0 foreach (keys %{SOAP::Schema->schema_url(shift(@parameters))->parse(@parameters)->load->services}) {
  0         0  
3579 0         0 $_->export_to_level(1, undef, ':all');
3580             }
3581             }
3582             elsif ($command eq 'debug' || $command eq 'trace') {
3583 0 0       0 SOAP::Trace->import(@parameters ? @parameters : 'all');
3584             }
3585             elsif ($command eq 'import') {
3586 0         0 local $^W; # suppress warnings about redefining
3587 0         0 my $package = shift(@parameters);
3588 0 0       0 $package->export_to_level(1, undef, @parameters ? @parameters : ':all') if $package;
    0          
3589             }
3590             else {
3591 7 50 66     42 Carp::carp "Odd (wrong?) number of parameters in import(), still continue" if $^W && !(@parameters & 1);
3592 7   66     129 $soap = ($soap||$pkg)->$command(@parameters);
3593             }
3594             }
3595             }
3596              
3597 14     14   526 sub DESTROY { SOAP::Trace::objects('()') }
3598              
3599             sub new {
3600 208     208 1 3271 my $self = shift;
3601 208 100       702 return $self if ref $self;
3602 19 50       80 unless (ref $self) {
3603 19         79 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 12   100 12   181 _on_action => sub { sprintf '"%s#%s"', shift || '', shift },
3613 1 50   1   7 _on_fault => sub {ref $_[1] ? return $_[1] : Carp::croak $_[0]->transport->is_success ? $_[1] : $_[0]->transport->status},
    50          
3614 19 100       251 };
3615 19         73 bless $self => $class;
3616 19   66     96 $self->on_nonserialized($self->on_nonserialized || $self->serializer->on_nonserialized);
3617 19         113 SOAP::Trace::objects('()');
3618             }
3619              
3620 19 50 66     105 Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
3621 25     25   185 no strict qw(refs);
  25         57  
  25         8393  
3622 19         81 while (@_) {
3623 3         10 my($method, $params) = splice(@_,0,2);
3624 3 50 0     38 $self->can($method)
    50          
3625             ? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
3626             : $^W && Carp::carp "Unrecognized parameter '$method' in new()"
3627             }
3628              
3629 19         55 return $self;
3630             }
3631              
3632             sub init_context {
3633 12     12 0 54 my $self = shift->new;
3634 12         101 $self->{'_deserializer'}->{'_context'} = $self;
3635             # weaken circular reference to avoid a memory hole
3636 12         87 weaken $self->{'_deserializer'}->{'_context'};
3637              
3638 12         41 $self->{'_serializer'}->{'_context'} = $self;
3639             # weaken circular reference to avoid a memory hole
3640 12         71 weaken $self->{'_serializer'}->{'_context'};
3641             }
3642              
3643             # Naming? wsdl_parser
3644             sub schema {
3645 0     0 0 0 my $self = shift;
3646 0 0       0 if (@_) {
3647 0         0 $self->{'_schema'} = shift;
3648 0         0 return $self;
3649             }
3650             else {
3651 0 0       0 if (!defined $self->{'_schema'}) {
3652 0         0 $self->{'_schema'} = SOAP::Schema->new;
3653             }
3654 0         0 return $self->{'_schema'};
3655             }
3656             }
3657              
3658             sub BEGIN {
3659 25     25   150 no strict 'refs';
  25         163  
  25         8066  
3660 25     25   77 for my $method (qw(serializer deserializer)) {
3661 50         128 my $field = '_' . $method;
3662             *$method = sub {
3663 52     52   190 my $self = shift->new;
3664 52 50       164 if (@_) {
3665 0         0 my $context = $self->{$field}->{'_context'}; # save the old context
3666 0         0 $self->{$field} = shift;
3667 0         0 $self->{$field}->{'_context'} = $context; # restore the old context
3668 0         0 return $self;
3669             }
3670             else {
3671 52         339 return $self->{$field};
3672             }
3673             }
3674 50         532 }
3675              
3676             __PACKAGE__->__mk_accessors(
3677 25         192 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 25         70 for my $method (qw(on_action on_fault on_nonserialized)) {
3687 75         154 my $field = '_' . $method;
3688             *$method = sub {
3689 90     90   325 my $self = shift->new;
3690 90 100       629 return $self->{$field} unless @_;
3691 35         74 local $@;
3692             # commented out because that 'eval' was unsecure
3693             # > ref $_[0] eq 'CODE' ? shift : eval shift;
3694             # Am I paranoid enough?
3695 35         92 $self->{$field} = shift;
3696 35 50       166 Carp::croak $@ if $@;
3697 35 50       153 Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)"
3698             unless ref $self->{$field} eq 'CODE';
3699 35         356 return $self;
3700             }
3701 75         718 }
3702             # SOAP::Transport Shortcuts
3703             # TODO - deprecate proxy() in favor of new language endpoint_url()
3704 25     25   196 no strict qw(refs);
  25         49  
  25         7004  
3705 25         58 for my $method (qw(proxy)) {
3706             *$method = sub {
3707 37     37   297 my $self = shift->new;
3708 37 100       223 @_ ? ($self->transport->$method(@_), return $self) : return $self->transport->$method();
3709             }
3710 25         186 }
3711              
3712             # SOAP::Seriailizer Shortcuts
3713 25         65 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 14     14   145 my $self = shift->new;
3720 14 100       94 @_ ? ($self->serializer->$method(@_), return $self) : return $self->serializer->$method();
3721             }
3722 450         3048 }
3723              
3724             # SOAP::Schema Shortcuts
3725 25         59 for my $method (qw(cache_dir cache_ttl)) {
3726             *$method = sub {
3727 0     0   0 my $self = shift->new;
3728 0 0       0 @_ ? ($self->schema->$method(@_), return $self) : return $self->schema->$method();
3729             }
3730 50         7352 }
3731             }
3732              
3733             sub parts {
3734 0     0 1 0 my $self = shift;
3735 0         0 $self->packager->parts(@_);
3736 0         0 return $self;
3737             }
3738              
3739             # Naming? wsdl
3740             sub service {
3741 0     0 1 0 my $self = shift->new;
3742 0 0       0 return $self->{'_service'} unless @_;
3743 0         0 $self->schema->schema_url($self->{'_service'} = shift);
3744 0         0 my %services = %{$self->schema->parse(@_)->load->services};
  0         0  
3745              
3746 0 0       0 Carp::croak "More than one service in service description. Service and port names have to be specified\n"
3747             if keys %services > 1;
3748 0         0 my $service = (keys %services)[0]->new;
3749 0         0 return $service;
3750             }
3751              
3752             sub AUTOLOAD {
3753 11     11   219 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
3754 11 50       64 return if $method eq 'DESTROY';
3755              
3756 11 50       62 ref $_[0] or Carp::croak qq!Can\'t locate class method "$method" via package \"! . __PACKAGE__ .'\"';
3757              
3758 25     25   151 no strict 'refs';
  25         43  
  25         33040  
3759             *$AUTOLOAD = sub {
3760 11     11   36 my $self = shift;
3761 11         87 my $som = $self->call($method => @_);
3762 11 0 33     127 return $self->autoresult && UNIVERSAL::isa($som => 'SOAP::SOM')
    50          
3763             ? wantarray ? $som->paramsall : $som->result
3764             : $som;
3765 11         94 };
3766 11         46 goto &$AUTOLOAD;
3767             }
3768              
3769             sub call {
3770 12     12 1 76 SOAP::Trace::trace('()');
3771 12         26 my $self = shift;
3772              
3773 12 50 33     56 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 12         74 $self->init_context();
3777              
3778 12         63 my $serializer = $self->serializer;
3779 12         74 $serializer->on_nonserialized($self->on_nonserialized);
3780              
3781 12         57 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 12 50       58 parts => @{$self->packager->parts} ? $self->packager->parts : undef,
3789             );
3790              
3791 12 50       647 return $response if $self->outputxml;
3792              
3793 12 50       73 my $result = eval { $self->deserializer->deserialize($response) }
  12         64  
3794             if $response;
3795              
3796 12 50 66     124 if (!$self->transport->is_success || # transport fault
      0        
      33        
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 12   33     240 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 0 0         return unless $response; # nothing to do for one-ways
3810              
3811             # little bit tricky part that binds in/out parameters
3812 0 0 0       if (UNIVERSAL::isa($result => 'SOAP::SOM')
      0        
      0        
3813             && ($result->paramsout || $result->headers)
3814             && $serializer->signature) {
3815 0           my $num = 0;
3816 0           my %signatures = map {$_ => $num++} @{$serializer->signature};
  0            
  0            
3817 0           for ($result->dataof(SOAP::SOM::paramsout), $result->dataof(SOAP::SOM::headers)) {
3818 0   0       my $signature = join $;, $_->name, $_->type || '';
3819 0 0         if (exists $signatures{$signature}) {
3820 0           my $param = $signatures{$signature};
3821 0           my($value) = $_->value; # take first value
3822              
3823             # fillup parameters
3824 0           UNIVERSAL::isa($_[$param] => 'SOAP::Data')
3825             ? $_[$param]->SOAP::Data::value($value)
3826             : UNIVERSAL::isa($_[$param] => 'ARRAY')
3827 0           ? (@{$_[$param]} = @$value)
3828             : UNIVERSAL::isa($_[$param] => 'HASH')
3829 0           ? (%{$_[$param]} = %$value)
3830             : UNIVERSAL::isa($_[$param] => 'SCALAR')
3831 0 0         ? (${$_[$param]} = $$value)
    0          
    0          
    0          
3832             : ($_[$param] = $value)
3833             }
3834             }
3835             }
3836 0           return $result;
3837             } # end of call()
3838              
3839             # ======================================================================
3840              
3841             package SOAP::Lite::COM;
3842              
3843             require SOAP::Lite;
3844              
3845             sub required {
3846 0     0     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 0           eval join ';', 'local $SIG{__DIE__}', "require $_";
3853             }
3854             }
3855              
3856 0     0     sub new { required; SOAP::Lite->new(@_) }
  0            
3857              
3858             sub create; *create = \&new; # make alias. Somewhere 'new' is registered keyword
3859              
3860             sub soap; *soap = \&new; # also alias. Just to be consistent with .xmlrpc call
3861              
3862 0     0     sub xmlrpc { required; XMLRPC::Lite->new(@_) }
  0            
3863              
3864 0     0     sub server { required; shift->new(@_) }
  0            
3865              
3866 0     0     sub data { SOAP::Data->new(@_) }
3867              
3868 0     0     sub header { SOAP::Header->new(@_) }
3869              
3870 0     0     sub hash { +{@_} }
3871              
3872             sub instanceof {
3873 0     0     my $class = shift;
3874 0 0         die "Incorrect class name" unless $class =~ /^(\w[\w:]*)$/;
3875 0           eval "require $class";
3876 0           $class->new(@_);
3877             }
3878              
3879             # ======================================================================
3880              
3881             1;
3882              
3883             __END__