File Coverage

lib/XML/Compile/SOAP12/Operation.pm
Criterion Covered Total %
statement 36 223 16.1
branch 0 98 0.0
condition 0 82 0.0
subroutine 12 27 44.4
pod 8 9 88.8
total 56 439 12.7


line stmt bran cond sub pod time code
1             # Copyrights 2009-2018 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-SOAP12. 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             ### Much of the code below looks like a copy of ::SOAP11::Operation,
10             ### but be warned: there are subtile differences.
11              
12             package XML::Compile::SOAP12::Operation;
13 1     1   7 use vars '$VERSION';
  1         2  
  1         52  
14             $VERSION = '3.06';
15              
16 1     1   6 use base 'XML::Compile::SOAP::Operation';
  1         2  
  1         478  
17              
18 1     1   2149 use warnings;
  1         3  
  1         23  
19 1     1   5 use strict;
  1         1  
  1         20  
20              
21 1     1   5 use Log::Report 'xml-compile-soap';
  1         2  
  1         4  
22              
23 1     1   225 use List::Util 'first';
  1         2  
  1         52  
24              
25 1     1   6 use XML::Compile::Util qw/pack_type unpack_type/;
  1         2  
  1         39  
26 1     1   6 use XML::Compile::SOAP12::Util qw/:soap12/;
  1         2  
  1         106  
27 1     1   382 use XML::Compile::SOAP12::Client;
  1         3  
  1         36  
28 1     1   405 use XML::Compile::SOAP12::Server;
  1         2  
  1         38  
29 1     1   461 use XML::Compile::SOAP::Extension;
  1         845  
  1         32  
30              
31 1     1   7 use vars '$VERSION'; # OODoc adds $VERSION to the script
  1         2  
  1         2924  
32             $VERSION ||= '(devel)';
33              
34             # client/server object per schema class, because initiation options
35             # can be different. Class reference is key.
36             my (%soap12_client, %soap12_server);
37              
38              
39             sub init($)
40 0     0 0   { my ($self, $args) = @_;
41              
42 0           $self->SUPER::init($args);
43              
44             $self->{$_} = $args->{$_} || {}
45 0   0       for qw/input_def output_def fault_def/;
46              
47 0   0       $self->{style} = $args->{style} || 'document';
48              
49 0           XML::Compile::SOAP::Extension->soap12OperationInit($self, $args);
50 0           $self->addHeader(OUTPUT => Upgrade => 'env12:Upgrade');
51 0           $self->addHeader(OUTPUT => NotUnderstood => 'env12:NotUnderstood');
52 0           $self;
53             }
54              
55             sub _fromWSDL11(@)
56 0     0     { my ($class, %args) = @_;
57              
58             # Extract the SOAP12 specific information from a WSDL11 file. There are
59             # half a zillion parameters.
60             my ($p_op, $b_op, $wsdl)
61 0           = @args{ qw/port_op bind_op wsdl/ };
62              
63 0           $args{schemas} = $wsdl;
64 0           $args{endpoints} = $args{serv_port}{soap12_address}{location};
65              
66 0   0       my $sop = $b_op->{soap12_operation} || {};
67 0   0       $args{action} ||= $sop->{soapAction};
68              
69 0   0       my $sb = $args{binding}{soap12_binding} || {};
70 0   0       $args{transport} = $sb->{transport} || 'HTTP';
71 0   0       $args{style} = $sb->{style} || 'document';
72              
73             $args{input_def} = $class->_msg_parts($wsdl, $args{name}, $args{style}
74 0           , $p_op->{wsdl_input}, $b_op->{wsdl_input});
75              
76             $args{output_def} = $class->_msg_parts($wsdl, $args{name}.'Response'
77 0           , $args{style}, $p_op->{wsdl_output}, $b_op->{wsdl_output});
78              
79             $args{fault_def}
80 0           = $class->_fault_parts($wsdl, $p_op->{wsdl_fault}, $b_op->{wsdl_fault});
81              
82 0           $class->SUPER::new(%args);
83             }
84              
85             sub _msg_parts($$$$$)
86 0     0     { my ($class, $wsdl, $opname, $style, $port_op, $bind_op) = @_;
87 0           my %parts;
88              
89 0 0         defined $port_op # communication not in two directions
90             or return ({}, {});
91              
92 0 0         if(my $body = $bind_op->{soap12_body})
    0          
93 0           { my $msgname = $port_op->{message};
94 0           my @parts = $class->_select_parts($wsdl, $msgname, $body->{parts});
95              
96 0           my ($ns, $local) = unpack_type $msgname;
97 0           my $rpc_ns = $body->{namespace};
98 0 0 0       $wsdl->addPrefixes(call => $rpc_ns) # hopefully no-one uses "call"
99             if defined $rpc_ns && !$wsdl->prefixFor($rpc_ns);
100              
101             my $procedure
102             = $style eq 'rpc' ? pack_type($rpc_ns, $opname)
103 0 0 0       : @parts==1 && $parts[0]{type} ? $msgname
    0          
104             : $local;
105              
106 0           $parts{body} = {procedure => $procedure, %$port_op, use => 'literal',
107             %$body, parts => \@parts};
108             }
109             elsif($port_op->{message})
110             { # missing in or :output
111 0           error __x"operation {opname} has a message in its portType but no encoding in the binding", opname => $opname;
112             }
113              
114 0   0       my $bsh = $bind_op->{soap12_header} || [];
115 0 0         foreach my $header (ref $bsh eq 'ARRAY' ? @$bsh : $bsh)
116 0           { my $msgname = $header->{message};
117 0           my @parts = $class->_select_parts($wsdl, $msgname, $header->{part});
118 0           push @{$parts{header}}, +{ %$header, parts => \@parts };
  0            
119             }
120 0           \%parts;
121             }
122              
123             sub _select_parts($$$)
124 0     0     { my ($class, $wsdl, $msgname, $need_parts) = @_;
125 0 0         my $msg = $wsdl->findDef(message => $msgname)
126             or error __x"cannot find message {name}", name => $msgname;
127              
128             my @need
129 0 0         = ref $need_parts ? @$need_parts
    0          
130             : defined $need_parts ? $need_parts
131             : ();
132              
133 0   0       my $parts = $msg->{wsdl_part} || [];
134 0 0         @need or return @$parts;
135              
136 0           my @sel;
137 0           my %parts = map +($_->{name} => $_), @$parts;
138 0           foreach my $name (@need)
139             { my $part = $parts{$name}
140             or error __x"message {msg} does not have a part named {part}"
141 0 0         , msg => $msg->{name}, part => $name;
142              
143 0           push @sel, $part;
144             }
145              
146 0           @sel;
147             }
148              
149             sub _fault_parts($$$)
150 0     0     { my ($class, $wsdl, $portop, $bind) = @_;
151              
152 0   0       my $port_faults = $portop || [];
153 0           my %faults;
154              
155 0           foreach my $fault (@$bind)
156 0 0         { $fault or next;
157 0           my $name = $fault->{name};
158              
159 0     0     my $port = first {$_->{name} eq $name} @$port_faults;
  0            
160 0 0         defined $port
161             or error __x"cannot find port for fault {name}", name => $name;
162              
163             my $msgname = $port->{message}
164 0 0         or error __x"no fault message name in portOperation";
165              
166 0 0         my $message = $wsdl->findDef(message => $msgname)
167             or error __x"cannot find fault message {name}", name => $msgname;
168              
169 0 0         @{$message->{wsdl_part} || []}==1
  0 0          
170             or error __x"fault message {name} must have one part exactly"
171             , name => $msgname;
172              
173             $faults{$name} =
174             { part => $message->{wsdl_part}[0]
175 0   0       , use => ($fault->{use} || 'literal')
176             };
177             }
178              
179 0           +{ faults => \%faults };
180             }
181              
182             #-------------------------------------------
183              
184              
185 0     0 1   sub style() {shift->{style}}
186              
187             sub version() { 'SOAP12' }
188 0     0 1   sub serverClass { 'XML::Compile::SOAP12::Server' }
189 0     0 1   sub clientClass { 'XML::Compile::SOAP12::Client' }
190              
191             #-------------------------------------------
192              
193              
194             sub addHeader($$$%)
195 0     0 1   { my ($self, $dir, $label, $el, %opts) = @_;
196 0           my $elem = $self->schemas->findName($el);
197 0 0         my $defs
    0          
    0          
198             = $dir eq 'INPUT' ? 'input_def'
199             : $dir eq 'OUTPUT' ? 'output_def'
200             : $dir eq 'FAULT' ? 'fault_def'
201             : panic "addHeader $dir";
202 0   0       my $headers = $self->{$defs}{header} ||= [];
203              
204 0 0   0     if(my $already = first {$_->{part} eq $label} @$headers)
  0            
205             { # the header is already defined, ignore second declaration
206 0           my $other_type = $already->{parts}[0]{element};
207 0 0         $other_type eq $elem
208             or error __x"header {label} already defined with type {type}"
209             , label => $label, type => $other_type;
210 0           return $already;
211             }
212              
213             my %part =
214             ( part => $label, use => 'literal'
215             , parts => [
216             { name => $label, element => $elem
217             , mustUnderstand => $opts{mustUnderstand}
218             , destination => $opts{destination}
219 0           } ]);
220              
221 0           push @$headers, \%part;
222 0           \%part;
223             }
224              
225             #-------------------------------------------
226              
227              
228             sub compileHandler(@)
229 0     0 1   { my ($self, %args) = @_;
230              
231             my $soap = $soap12_server{$self->{schemas}}
232 0   0       ||= XML::Compile::SOAP12::Server->new(schemas => $self->{schemas});
233 0   0       my $style = $args{style} ||= $self->style;
234              
235 0           my @ro = (%{$self->{input_def}}, %{$self->{fault_def}});
  0            
  0            
236 0           my @so = (%{$self->{output_def}}, %{$self->{fault_def}});
  0            
  0            
237              
238 0   0       $args{encode} ||= $soap->_sender(@so, %args);
239 0   0       $args{decode} ||= $soap->_receiver(@ro, %args);
240 0   0       $args{selector} ||= $soap->compileFilter(%{$self->{input_def}});
  0            
241 0   0       $args{kind} ||= $self->kind;
242 0           $args{name} = $self->name;
243              
244             $args{callback} = XML::Compile::SOAP::Extension
245 0           ->soap12HandlerWrapper($self, $args{callback}, \%args);
246              
247 0           $soap->compileHandler(%args);
248             }
249              
250              
251             sub compileClient(@)
252 0     0 1   { my ($self, %args) = @_;
253              
254             my $client = $soap12_client{$self->{schemas}}
255 0   0       ||= XML::Compile::SOAP12::Client->new(schemas => $self->{schemas});
256 0   0       my $style = $args{style} ||= $self->style;
257 0   0       my $kind = $args{kind} ||= $self->kind;
258              
259 0           my @so = (%{$self->{input_def}}, %{$self->{fault_def}});
  0            
  0            
260 0           my @ro = (%{$self->{output_def}}, %{$self->{fault_def}});
  0            
  0            
261              
262             my $call = $client->compileClient
263             ( name => $self->name
264             , kind => $kind
265             , encode => $client->_sender(@so, %args)
266             , decode => $client->_receiver(@ro, %args)
267             , transport => $self->compileTransporter(%args, soap => 'SOAP12')
268             , async => $args{async}
269             , soap => $args{soap}
270 0           );
271              
272 0           XML::Compile::SOAP::Extension->soap12ClientWrapper($self, $call, \%args);
273             }
274              
275             #--------------------------
276              
277              
278             my $sep = '#--------------------------------------------------------------';
279              
280             sub explain($$$@)
281 0     0 1   { my ($self, $schema, $format, $dir, %args) = @_;
282              
283             # $schema has to be passed as argument, because we do not want operation
284             # objects to be glued to a schema object after compile time.
285              
286 0 0         UNIVERSAL::isa($schema, 'XML::Compile::Schema')
287             or error __x"explain() requires first element to be a schema";
288              
289 0 0         $format eq 'PERL'
290             or error __x"only PERL template supported for the moment, not {got}"
291             , got => $format;
292              
293 0           my $style = $self->style;
294 0           my $opname = $self->name;
295 0   0       my $skip_header = delete $args{skip_header} || 0;
296 0   0       my $recurse = delete $args{recurse} || 0;
297              
298 0 0         my $def = $dir eq 'INPUT' ? $self->{input_def} : $self->{output_def};
299 0           my $faults = $self->{fault_def}{faults};
300              
301 0           my (@struct, @postproc, @attach);
302 0 0         my @main = $recurse
303             ? "# The details of the types and elements are attached below."
304             : "# To explore the HASHes for each part, use recurse option.";
305              
306             HEAD_PART:
307 0 0         foreach my $header ( @{$def->{header} || []} )
  0            
308 0 0         { foreach my $part ( @{$header->{parts} || []} )
  0            
309 0           { my $name = $part->{name};
310             my ($kind, $value) = $part->{type} ? (type => $part->{type})
311 0 0         : (element => $part->{element});
312            
313 0   0       my $type = $schema->prefixed($value) || $value;
314 0 0 0       push @main, ''
315             , "# Header part '$name' is $kind $type"
316             , ($kind eq 'type' && $recurse ? "# See fake element '$name'" : ())
317             , "my \$$name = {};";
318 0           push @struct, " $name => \$$name,";
319            
320 0 0         $recurse or next HEAD_PART;
321            
322 0           my $elem = $value;
323 0 0         if($kind eq 'type')
324             { # generate element with part name, because template requires elem
325 0           $schema->compileType(READER => $value, element => $name);
326 0           $elem = $name;
327             }
328            
329 0           push @attach, '', $sep, "\$$name ="
330             , $schema->template(PERL => $elem, skip_header => 1, %args), ';';
331             }
332             }
333              
334             BODY_PART:
335 0 0         foreach my $part ( @{$def->{body}{parts} || []} )
  0            
336 0           { my $name = $part->{name};
337             my ($kind, $value) = $part->{type} ? (type => $part->{type})
338 0 0         : (element => $part->{element});
339              
340 0   0       my $type = $schema->prefixed($value) || $value;
341 0 0 0       push @main, ''
342             , "# Body part '$name' is $kind $type"
343             , ($kind eq 'type' && $recurse ? "# See fake element '$name'" : ())
344             , "my \$$name = {};";
345 0           push @struct, " $name => \$$name,";
346              
347 0 0         $recurse or next BODY_PART;
348              
349 0           my $elem = $value;
350 0 0         if($kind eq 'type')
351             { # generate element with part name, because template requires elem
352 0           $schema->compileType(READER => $value, element => $name);
353 0           $elem = $name;
354             }
355              
356 0           push @attach, '', $sep, "\$$name ="
357             , $schema->template(PERL => $elem, skip_header => 1, %args), ';';
358             }
359              
360 0           foreach my $fault (sort keys %$faults)
361 0           { my $part = $faults->{$fault}{part}; # fault msgs have only one part
362             my ($kind, $value) = $part->{type} ? (type => $part->{type})
363 0 0         : (element => $part->{element});
364              
365 0 0         my $type = $schema->prefixFor($value)
366             ? $schema->prefixed($value) : $value;
367              
368 0 0         if($dir eq 'OUTPUT')
369 0 0 0       { push @main, ''
370             , "# ... or fault $fault is $kind"
371             , "my \$$fault = {}; # $type"
372             , ($kind eq 'type' && $recurse ? "# See fake element '$fault'" : ())
373             , "my \$fault ="
374             , " { code => pack_type(\$myns, 'Open.NoSuchFile')"
375             , " , reason => 'because I can'"
376             , " , detail => \$$fault"
377             , ' };';
378 0           push @struct, " $fault => \$fault,";
379             }
380             else
381 0   0       { my $nice = $schema->prefixed($type) || $type;
382 0           push @postproc
383             , " elsif(\$errname eq '$fault')"
384             , " { # \$details is a $nice"
385             , " }";
386             }
387              
388 0 0         $recurse or next;
389              
390 0           my $elem = $value;
391 0 0         if($kind eq 'type')
392             { # generate element with part name, because template requires elem
393 0           $schema->compileType(READER => $value, element => $fault);
394 0           $elem = $fault;
395             }
396              
397 0           push @attach, '', $sep, "# FAULT", "\$$fault ="
398             , $schema->template(PERL => $elem, skip_header => 1, %args), ';';
399             }
400              
401 0 0         if($dir eq 'INPUT')
    0          
402 0           { push @main, ''
403             , '# Call with the combination of parts.'
404             , 'my @params = (', @struct, ');'
405             , 'my ($answer, $trace) = $call->(@params);', ''
406             , '# @params will become %$data_in in the server handler.'
407             , '# $answer is a HASH, an operation OUTPUT or Fault.'
408             , '# $trace is an XML::Compile::SOAP::Trace object.';
409              
410 0           unshift @postproc, ''
411             , '# You may get an error back from the server'
412             , 'if(my $f = $answer->{Fault})'
413             , '{ my $errname = $f->{_NAME};'
414             , ' my $error = $answer->{$errname};'
415             , ' print "$error->{code}\n";', ''
416             , ' my $details = $error->{detail};'
417             , ' if(not $details)'
418             , ' { # system error, no $details'
419             , ' }';
420            
421 0           push @postproc
422             , ' exit 1;'
423             , '}';
424             }
425             elsif($dir eq 'OUTPUT')
426 0           { s/^/ / for @main, @struct;
427 0           unshift @main, ''
428             , "sub handle_$opname(\$)"
429             , '{ my ($server, $data_in) = @_;'
430             , ' # process $data_in, structured as INPUT message.'
431             , ' # Hint: use "print Dumper $data_in"';
432              
433 0           push @main, ''
434             , ' # This will end-up as $answer at client-side'
435             , ' return # optional keyword'
436             , " +{", @struct, " };", "}";
437             }
438             else
439 0           { error __x"template for direction INPUT or OUTPUT, not {got}"
440             , got => $dir;
441             }
442              
443 0           my @header;
444 0 0         if(my $how = $def->{body})
445 0   0       { my $use = $how->{use} || 'literal';
446 0           push @header
447             , "# Operation $how->{procedure}"
448             , "# $dir, $style $use";
449             }
450             else
451 0           { push @header,
452             , "# Operation $opname has no $dir";
453             }
454              
455 0           foreach my $fault (sort keys %$faults)
456 0           { my $usage = $faults->{$fault};
457 0           push @header
458             , "# FAULT $fault, $style $usage->{use}" # $style?
459             }
460              
461             push @header
462             , "# Produced by ".__PACKAGE__." version $VERSION"
463             , "# on ".localtime()
464             , "#"
465             , "# The output below is only an example: it cannot be used"
466             , "# without interpretation, although very close to real code."
467             , ""
468 0 0         unless $args{skip_header};
469              
470 0 0         if($dir eq 'INPUT')
471 0           { push @header
472             , '# Compile only once in your code, usually during initiation:'
473             , "my \$call = \$wsdl->compileClient('$opname');"
474             , '# ... then call it as often as you need.';
475             }
476             else #OUTPUT
477 0           { push @header
478             , '# As part of the initiation phase of your server:'
479             , 'my $daemon = XML::Compile::SOAP::HTTPDaemon->new;'
480             , '$deamon->operationsFromWSDL'
481             , ' ( $wsdl'
482             , ' , callbacks =>'
483             , " { $opname => \\&handle_$opname}"
484             , ' );'
485             }
486              
487 0           join "\n", @header, @main, @postproc, @attach, '';
488             }
489              
490             sub parsedWSDL()
491 0     0 1   { my $self = shift;
492             +{ input => $self->{input_def}{body}
493             , output => $self->{output_def}{body}
494             , faults => $self->{fault_def}{faults}
495 0           , style => $self->style
496             };
497             }
498              
499             1;