File Coverage

lib/XML/Compile/SOAP11.pm
Criterion Covered Total %
statement 180 206 87.3
branch 57 92 61.9
condition 15 36 41.6
subroutine 30 33 90.9
pod 6 9 66.6
total 288 376 76.6


line stmt bran cond sub pod time code
1             # Copyrights 2007-2021 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution XML-Compile-SOAP. Meta-POD processed
6             # with OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package XML::Compile::SOAP11;
10 7     7   1058 use vars '$VERSION';
  7         13  
  7         335  
11             $VERSION = '3.27';
12              
13 7     7   39 use base 'XML::Compile::SOAP';
  7         9  
  7         2924  
14              
15 7     7   61 use warnings;
  7         24  
  7         210  
16 7     7   37 use strict;
  7         14  
  7         193  
17              
18 7     7   37 use Log::Report 'xml-compile-soap';
  7         10  
  7         58  
19              
20 7     7   1984 use XML::Compile::SOAP::Util qw/:soap11/;
  7         14  
  7         754  
21 7     7   45 use XML::Compile::Util qw/pack_type unpack_type type_of_node/;
  7         12  
  7         420  
22              
23             # publish interface to WSDL
24 7     7   3621 use XML::Compile::SOAP11::Operation ();
  7         22  
  7         18364  
25              
26             __PACKAGE__->register
27             ( WSDL11SOAP
28             , &SOAP11ENV => 'XML::Compile::SOAP11::Operation'
29             );
30              
31              
32             sub new($@)
33 6     6 1 869 { my $class = shift;
34 6 50       29 $class ne __PACKAGE__
35             or error __x"only instantiate a SOAP11::Client or ::Server";
36 6         63 $class->SUPER::new(@_);
37             }
38              
39             sub init($)
40 6     6 0 20 { my ($self, $args) = @_;
41 6   50     57 $args->{media_type} ||= 'text/xml';
42 6         52 $self->SUPER::init($args);
43 6         46 $self->_initSOAP11($self->schemas);
44             }
45              
46             sub _initSOAP11($)
47 6     6   18 { my ($self, $schemas) = @_;
48              
49             return $self
50 6 50       30 if $schemas->{did_init_SOAP11}++; # ugly
51              
52 6         43 $self->_initSOAP($schemas);
53              
54 6         48 (my $xsddir = __FILE__) =~ s!\.pm$!/xsd!;
55 6         29 $schemas->addPrefixes('SOAP-ENV' => SOAP11ENV);
56 6         296 $schemas->importDefinitions("$xsddir/soap-envelope.xsd");
57              
58 6 100       12597 $self->_initRpcEnc11($schemas, $xsddir)
59             if $self->can('_initRpcEnc11');
60              
61 6         43 $self;
62             }
63              
64             sub _initWSDL11($)
65 0     0   0 { my ($class, $wsdl) = @_;
66              
67             return $class
68 0 0       0 if $wsdl->{did_init_SOAP11_WSDL}++; # ugly
69              
70 0         0 trace "initialize SOAP11 for WSDL11";
71              
72 0         0 (my $xsddir = __FILE__) =~ s!SOAP11\.pm$!WSDL11/xsd!;
73 0         0 $wsdl->importDefinitions("$xsddir/wsdl-soap.xsd");
74 0         0 $wsdl->addPrefixes(soap => WSDL11SOAP);
75              
76 0         0 $wsdl->declare(READER =>
77             [ "soap:address", "soap:operation", "soap:binding"
78             , "soap:body", "soap:header", "soap:fault" ]);
79 0         0 $class;
80             }
81              
82 0     0 1 0 sub version { 'SOAP11' }
83 28     28 0 62 sub envelopeNS { SOAP11ENV }
84 33     33 0 91 sub envType($) { pack_type SOAP11ENV, $_[1] }
85              
86             #-----------------------------------
87              
88              
89             sub compileMessage($$)
90 11     11 1 6416 { my ($self, $direction, %args) = @_;
91 11   50     89 $args{style} ||= 'document';
92              
93 11 100       48 if(ref $args{body} eq 'ARRAY')
94 8         14 { my @h = @{$args{body}};
  8         91  
95 8         16 my @parts;
96 8         59 push @parts, +{name => shift @h, element => shift @h} while @h;
97 8         38 $args{body} = +{use => 'literal', parts => \@parts};
98             }
99              
100 11 100       44 if(ref $args{header} eq 'ARRAY')
101 4         9 { my @h = @{$args{header}};
  4         12  
102 4         8 my @o;
103 4         12 while(@h)
104 4         68 { my $part = +{name => shift @h, element => shift @h};
105 4         25 push @o, +{use => 'literal', parts => [$part]};
106             }
107 4         12 $args{header} = \@o;
108             }
109              
110 11         72 my $f = $args{faults};
111 11 100       49 if(ref $f eq 'ARRAY')
112 2         3 { $args{faults} = +{};
113 2         4 my @f = @$f;
114 2         3 while(@f)
115 2         4 { my $name = shift @f;
116 2         5 my $part = +{name => $name, element => shift @f};
117 2         7 $args{faults}{$name} = +{use => 'literal', part => $part};
118             }
119             }
120              
121 11         79 $self->SUPER::compileMessage($direction, %args);
122             }
123              
124             #------------------------------------------------
125             # Sender
126              
127             sub _sender(@)
128 5     5   18 { my ($self, %args) = @_;
129              
130             ### merge info into headers
131             # do not destroy original of args
132 5 100       12 my %destination = @{$args{destination} || []};
  5         29  
133              
134 5         13 my $understand = $args{mustUnderstand};
135 5 100       36 my %understand = map +($_ => 1),
    50          
136             ref $understand eq 'ARRAY' ? @$understand
137             : defined $understand ? $understand : ();
138              
139 5 100       19 foreach my $h ( @{$args{header} || []} )
  5         29  
140 2         6 { my $part = $h->{parts}[0];
141 2         5 my $label = $part->{name};
142 2   33     13 $part->{mustUnderstand} ||= delete $understand{$label};
143 2   66     15 $part->{destination} ||= delete $destination{$label};
144             }
145              
146 5 50       24 if(keys %understand)
147 0         0 { error __x"mustUnderstand for unknown header {headers}"
148             , headers => [keys %understand];
149             }
150              
151 5 50       19 if(keys %destination)
152 0         0 { error __x"destination for unknown header {headers}"
153             , headers => [keys %destination];
154             }
155              
156             # faults are always possible
157 5 100       10 my @bparts = @{$args{body}{parts} || []};
  5         31  
158             my $w = $self->schemas->writer('SOAP-ENV:Fault'
159 20 100   20   83218 , include_namespaces => sub {$_[0] ne SOAP11ENV && $_[2]}
160 5         20 );
161 5         231 push @bparts,
162             { name => 'Fault'
163             , element => pack_type(SOAP11ENV, 'Fault')
164             , writer => $w
165             };
166 5         72 local $args{body}{parts} = \@bparts;
167              
168 5         81 $self->SUPER::_sender(%args);
169             }
170              
171             sub _writer_header($)
172 5     5   49 { my ($self, $args) = @_;
173 5         40 my ($rules, $hlabels) = $self->SUPER::_writer_header($args);
174              
175 5         13 my $header = $args->{header};
176 5         9 my @rules;
177 5 100       8 foreach my $h (@{$header || []})
  5         26  
178 2         5 { my $part = $h->{parts}[0];
179 2         4 my $label = $part->{name};
180 2 50       7 $label eq shift @$rules or panic;
181 2         5 my $code = shift @$rules;
182              
183             # fixed in SOAP12, but SOAP11 only understands numeric boolean values
184             my $understand
185             = $part->{mustUnderstand} ? '1'
186 2 0       9 : defined $part->{mustUnderstand} ? '0' # explicit 0
    50          
187             : undef;
188              
189 2         5 my $actor = $part->{destination};
190 2 50       11 if(ref $actor eq 'ARRAY')
    100          
191 0         0 { $actor = join ' ', map $self->roleURI($_), @$actor }
192             elsif(defined $actor)
193 1         7 { $actor =~ s/\b(\S+)\b/$self->roleURI($1)/ge }
  2         10  
194              
195 2         9 my $envpref = $self->schemas->prefixFor(SOAP11ENV);
196             my $wcode = $understand || $actor
197             ? sub
198 3     3   7 { my ($doc, $v) = @_;
199 3         12 my $xml = $code->($doc, $v);
200 3 50       411 $xml->setAttribute("$envpref:mustUnderstand" => '1')
201             if defined $understand;
202 3 100       56 $xml->setAttribute("$envpref:actor" => $actor)
203             if $actor;
204 3         33 $xml;
205             }
206 2 50 33     52 : $code;
207              
208 2         8 push @rules, $label => $wcode;
209             }
210              
211 5         20 (\@rules, $hlabels);
212             }
213              
214             sub _writer_faults($)
215 5     5   23 { my ($self, $args) = @_;
216 5   100     75 my $faults = $args->{faults} ||= {};
217              
218 5         11 my (@rules, @flabels);
219              
220             # Include all namespaces in Fault, because we have no idea which namespace
221             # is used for the error code. It automatically defines everything
222             # which may be used in the detail block.
223             my $wrfault = $self->_writer('SOAP-ENV:Fault'
224 5     20   34 , include_namespaces => sub {$_[0] ne SOAP11ENV});
  20         22783  
225              
226 5         198 while(my ($name, $fault) = each %$faults)
227 1         2 { my $part = $fault->{part};
228 1         8 my ($elem, $details) = $self->_write_one_fault($args, $part);
229              
230             my $code = sub
231 1     1   2 { my ($doc, $data) = (shift, shift);
232 1         4 my %copy = %$data;
233 1         8 $copy{faultactor} = $self->roleURI($copy{faultactor});
234 1         2 my $det = delete $copy{detail};
235 1 50       4 my @det = !defined $det ? () : ref $det eq 'ARRAY' ? @$det : $det;
    50          
236 1         4 $copy{detail}{$elem} = [ map $details->($doc, $_), @det ];
237 1         127 $wrfault->($doc, \%copy);
238 1         63 };
239              
240 1         3 push @rules, $name => $code;
241 1         4 push @flabels, $name;
242             }
243              
244 5         529 (\@rules, \@flabels);
245             }
246              
247             sub _write_one_fault($$)
248 1     1   3 { my ($self, $args, $part) = @_;
249              
250             # spec says: details ALWAYS namespace qualified!
251 1 50       16 if(my $elem = $part->{element})
252             { my $writer = $self->{writer} ||=
253             $self->_writer($elem
254 1 100 33 5   12 , include_namespaces => sub {$_[0] ne SOAP11ENV && $_[2]});
  5         1710  
255 1         20 return ($elem, $writer);
256             }
257              
258 0 0       0 if(my $type = $part->{type})
259 0         0 { my $elem = $part->{name};
260             my $writer = $part->{writer} ||= $self->schemas->compileType
261             ( WRITER => $part->{type}, %$args
262             , element => $part->{name}
263 0 0   0   0 , include_namespaces => sub {$_[0] ne SOAP11ENV && $_[2]}
264 0   0     0 );
265 0         0 return ($elem, $writer);
266             }
267              
268             error __x"fault part {name} has neither `element' nor `type' specified"
269 0         0 , name => $part->{name};
270             }
271              
272             ##########
273             # Receiver
274              
275             sub _reader_fault_reader()
276 6     6   15 { my $self = shift;
277              
278             # Nasty, nasty: the spec requires name-space qualified on details,
279             # even when the schema does not specify that.
280 6         28 my $schemas = $self->schemas;
281             my $x = sub {
282 1     1   574 my ($xml, $reader, $path, $tag, $r) = @_;
283 1         3 my @childs = grep $_->isa('XML::LibXML::Element'), $xml->childNodes;
284 1 50       16 @childs or return ();
285              
286 1         2 my %h;
287 1         2 foreach my $node (@childs)
288 1         3 { my $type = type_of_node($node);
289 1         13 push @{$h{_ELEMENT_ORDER}}, $type;
  1         3  
290 1         7 my $dec = try { $schemas->reader($type)->($node) };
  1         338  
291 1   33     1946 $h{$type} = $dec // $node;
292             }
293 1         4 ($tag => \%h);
294 6         41 };
295              
296 6         31 [ Fault => pack_type(SOAP11ENV, 'Fault')
297             , $self->schemas->reader('SOAP-ENV:Fault'
298             , hooks => { type => 'SOAP-ENV:detail', replace => $x } )
299             ];
300             }
301              
302             sub _reader_faults($$)
303 6     6   30 { my ($self, $args, $faults) = @_;
304              
305 6         17 my %names;
306 6         44 while(my ($name, $def) = each %$faults)
307 1   33     13 { $names{$def->{part}{element} || $name} = $name;
308             }
309              
310             sub
311 9     9   16 { my $data = shift;
312 9 100       34 my $faults = $data->{Fault} or return;
313              
314 3         17 my ($code_ns, $code_err) = unpack_type $faults->{faultcode};
315 3         54 my ($err, @sub_err) = split /\./, $code_err;
316 3 100       14 $err = 'Receiver' if $err eq 'Server';
317 3 50       12 $err = 'Sender' if $err eq 'Client';
318              
319             my %nice =
320             ( code => $faults->{faultcode}
321             , class => [ $code_ns, $err, @sub_err ]
322             , reason => $faults->{faultstring}
323 3         16 );
324              
325             $nice{role} = $self->roleAbbreviation($faults->{faultactor})
326 3 100       17 if $faults->{faultactor};
327              
328 3         7 my $details = $faults->{detail};
329 3 100       9 my $dettype = $details ? delete $details->{_ELEMENT_ORDER} : undef;
330              
331 3         5 my $name;
332 3 100 33     14 if(!$details) { $name = 'error' }
  2 50       6  
    0          
333             elsif(@$dettype && $names{$dettype->[0]})
334             { # fault named in WSDL
335 1         3 $name = $names{$dettype->[0]};
336 1 50       4 if(keys %$details==1)
337 1         4 { my (undef, $v) = %$details;
338 1 50       4 if(ref $v eq 'HASH') { @nice{keys %$v} = values %$v }
  1         5  
339 0         0 else { $nice{details} = $v }
340             }
341             }
342             elsif(keys %$details==1)
343             { # simple generic fault, not in WSDL. Maybe internal server error
344 0         0 ($name) = keys %$details;
345 0         0 my $v = $details->{$name};
346 0 0       0 my @v = ref $v eq 'ARRAY' ? @$v : $v;
347 0 0       0 my @r = map { UNIVERSAL::isa($_, 'XML::LibXML::Node')
  0         0  
348             ? $_->textContent : $_} @v;
349 0 0       0 $nice{$name} = @r==1 ? $r[0] : \@r;
350             }
351             else
352             { # unknown complex generic error
353 0         0 $name = 'generic';
354             }
355              
356 3         8 $data->{$name} = \%nice;
357 3         9 $faults->{_NAME} = $name;
358 3         7 $data;
359 6         47 };
360             }
361              
362             sub replyMustUnderstandFault($)
363 1     1 1 36 { my ($self, $type) = @_;
364              
365 1         5 +{ Fault =>
366             { faultcode => pack_type(SOAP11ENV, 'MustUnderstand')
367             , faultstring => "SOAP mustUnderstand $type"
368             }
369             };
370             }
371              
372 3 100 66 3 1 21 sub roleURI($) { $_[1] && $_[1] eq 'NEXT' ? SOAP11NEXT : $_[1] }
373 1 50 33 1 1 7 sub roleAbbreviation($) { $_[1] && $_[1] eq SOAP11NEXT ? 'NEXT' : $_[1] }
374              
375             #-------------------------------------
376             # docs of ::SOAP11::Encoding inserted here
377              
378             #-------------------------------------
379              
380              
381             1;