File Coverage

lib/XML/Compile/SOAP11/Encoding.pm
Criterion Covered Total %
statement 161 407 39.5
branch 51 206 24.7
condition 11 53 20.7
subroutine 22 47 46.8
pod 0 11 0.0
total 245 724 33.8


line stmt bran cond sub pod time code
1             # Copyrights 2007-2022 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.03.
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 2     2   2211 use vars '$VERSION';
  2         3  
  2         101  
11             $VERSION = '3.28';
12             #!!!
13              
14 2     2   12 use warnings;
  2         4  
  2         46  
15 2     2   8 use strict;
  2         6  
  2         38  
16              
17 2     2   9 use Log::Report 'xml-compile-soap';
  2         2  
  2         15  
18              
19 2     2   441 use List::Util qw/first/;
  2         4  
  2         141  
20 2     2   11 use Scalar::Util qw/reftype/;
  2         4  
  2         94  
21             use XML::Compile::Util
22 2     2   11 qw/odd_elements SCHEMA2001 SCHEMA2001i pack_type unpack_type type_of_node/;
  2         3  
  2         130  
23 2     2   13 use XML::Compile::SOAP::Util qw/:soap11 WSDL11/;
  2         5  
  2         10134  
24              
25             my $simplify;
26              
27             sub XML::Compile::SOAP11::Encoding::import(@) #!!!
28 2     2   38 { my ($class, %args) = @_;
29 2         54 $simplify = $args{simplify};
30             }
31              
32              
33             sub _initRpcEnc11($$)
34 1     1   4 { my ($self, $schemas, $xsddir) = @_;
35              
36 1         3 $schemas->addPrefixes('SOAP-ENC' => SOAP11ENC);
37 1         48 $schemas->importDefinitions("$xsddir/soap-encoding.xsd");
38              
39 1         5365 $schemas->addCompileOptions( 'READERS'
40             , anyElement => 'TAKE_ALL'
41             , anyAttribute => 'TAKE_ALL'
42             , permit_href => 1
43             );
44              
45             # this will keep the soap11 compile object alive after compilation
46             $schemas->addHook
47             ( action => 'READER'
48             , extends => 'SOAP-ENC:Array'
49 0     0   0 , replace => sub { $self->_dec_array_hook(@_) }
50 1         24 );
51              
52             $schemas->addHook
53             ( action => 'WRITER'
54             , extends => 'SOAP-ENC:Array'
55 0     0   0 , replace => sub { $self->_enc_array_hook(@_) }
56 1         86 );
57              
58 1         35 $self;
59             }
60              
61             sub _reader_body_rpcenc_wrapper($$)
62 0     0   0 { my ($self, $procedure, $body) = @_;
63 0         0 my %trans = map +($_->[1] => [ $_->[0], $_->[2] ]), @$body;
64              
65             # this should use key_rewrite, but there is no $wsdl here
66             # my $label = $wsdl->prefixed($procedure);
67 0         0 my $label = (unpack_type $procedure)[1];
68              
69             my $code = sub
70 0 0   0   0 { my $opnode = shift or return {};
71 0         0 my @nodes = $opnode->childNodes;
72 0         0 my $parent = $opnode->parentNode; # href'd sometimes a level up
73 0 0       0 push @nodes, grep $_ ne $opnode, $parent->childNodes
74             if $parent;
75              
76 0         0 $self->rpcDecode(@nodes);
77 0         0 };
78              
79 0         0 [ [ $label => $procedure => $code ] ];
80             }
81              
82             sub _writer_body_rpcenc_hook($$$$$)
83 0     0   0 { my ($self, $type, $procedure, $params, $faults) = @_;
84 0         0 $self->_writer_body_rpclit_hook($type, $procedure, $params, $faults);
85             }
86              
87             #------------------
88              
89              
90             sub startEncoding(%)
91 1     1 0 1274 { my ($self, %args) = @_;
92 1   33     54 my $doc = $args{doc} || XML::LibXML::Document->new('1.0', 'UTF-8');
93 1         8 $self->{enc} = {doc => $doc};
94 1         2 $self;
95             }
96              
97             # Currently only support 1-dim arrays
98              
99             sub _enc_array_hook(@)
100 0     0   0 { my ($client, $doc, $val, $path, $tag, $r, $fulltype) = @_;
101 0         0 my $schema = $client->schemas;
102 0         0 my $nss = $schema->namespaces;
103              
104 0         0 my $elem = $doc->createElement($tag);
105 0         0 my $encns = $schema->prefixFor(SOAP11ENC);
106 0         0 $elem->setAttribute('xsi:type' => "$encns:Array");
107              
108 0         0 my ($label, $items) = %$val;
109 0 0       0 my @items = ref $items eq 'ARRAY' ? @$items : $items;
110              
111 0 0       0 my $def = $nss->find(complexType => $fulltype)
112             or error __x"cannot find {type} in rpc array writer hook"
113             , type => $fulltype;
114 0         0 my $defnode= $def->{node};
115 0         0 my $xpc = XML::LibXML::XPathContext->new;
116 0         0 $xpc->registerNs(wsdl => WSDL11);
117 0         0 my ($atattr) = $xpc->findnodes('.//@wsdl:arrayType', $def->{node});
118              
119 0         0 my $qname = $atattr->value;
120 0         0 $qname =~ s/\[.*//; # strip array notation
121              
122 0 0       0 my ($pref,$local) = $qname =~ /\:/ ? (split /\:/,$qname,2) : ('',$qname);
123 0         0 my $ns = $atattr->lookupNamespaceURI($pref);
124 0         0 my $eltype = pack_type $ns, $local;
125              
126 0         0 my @nodes;
127 0 0       0 if($nss->find(element => $eltype))
128 0         0 { my $w = $schema->writer($eltype);
129 0         0 @nodes = map $w->($doc, $_), @items;
130             }
131             else # type
132 0         0 { my $w = $schema->writer($eltype, is_type => 1, element => $label);
133 0         0 @nodes = map $w->($doc, $_), @items;
134             }
135              
136 0         0 $elem->appendChild($_) for @nodes;
137 0         0 $elem->setAttribute("$encns:arrayType" => $qname.'['.@nodes.']');
138 0         0 $elem;
139             }
140              
141              
142             sub prefixed($;$)
143 97     97 0 126 { my $self = shift;
144 97         161 $self->schemas->prefixed(@_);
145             }
146              
147              
148             sub enc($$$)
149 7     7 0 23102 { my ($self, $local, $value, $id) = @_;
150 7         24 my $type = pack_type SOAP11ENC, $local;
151             $self->schemas->writer($type, include_namespaces => 0)
152 7         72 ->($self->{enc}{doc}, {_ => $value, id => $id} );
153             }
154              
155              
156             sub typed($$$)
157 6     6 0 5927 { my ($self, $type, $name, $value) = @_;
158              
159 6         9 my $showtype;
160 6 50       22 if($type =~ s/^\{\}//)
161 0         0 { $showtype = $type;
162             }
163             else
164 6         16 { my ($tns, $tlocal) = unpack_type $type;
165 6 100       56 unless(length $tns)
166 1         3 { $tns = SCHEMA2001;
167 1         3 $type = pack_type $tns, $tlocal;
168             }
169 6         22 $showtype = $self->prefixed($tns, $tlocal);
170             }
171              
172 6         107 my $el = $self->element($type, $name, $value);
173 6         20 my $typedef = $self->prefixed(SCHEMA2001i, 'type');
174 6         100 $el->setAttribute($typedef, $showtype);
175 6         68 $el;
176             }
177              
178              
179             sub struct($@)
180 1     1 0 713 { my ($self, $type, @childs) = @_;
181 1         4 my $typedef = $self->prefixed($type);
182 1         13 my $doc = $self->{enc}{doc};
183 1         7 my $struct = $doc->createElement($typedef);
184 1         8 $struct->addChild($_) for @childs;
185 1         73 $struct;
186             }
187              
188              
189             sub element($$$)
190 26     26 0 13046 { my ($self, $type, $name, $value) = @_;
191              
192 26 50       104 return $value
193             if UNIVERSAL::isa($value, 'XML::LibXML::Element');
194              
195 26 50       86 $type = $self->prefixed(SCHEMA2001, $type)
196             if $type !~ m/^\{|\:/;
197              
198 26         42 my $doc = $self->{enc}{doc};
199 26         114 my $el = $doc->createElement($name);
200 26         58 my $child = $self->schemas->writer($type, include_namespaces => 0)
201             ->($doc, $value);
202 26 50       3821 $el->addChild($child) if $child;
203 26         219 $el;
204             }
205              
206              
207             my $id_count = 0;
208             sub href($$$)
209 6     6 0 4694 { my ($self, $name, $to, $prefid) = @_;
210 6         25 my $id = $to->getAttribute('id');
211 6 100       79 unless(defined $id)
212 2 100       7 { $id = defined $prefid ? $prefid : 'id-'.++$id_count;
213 2         7 $to->setAttribute(id => $id);
214             }
215              
216 6         27 my $ename = $self->prefixed($name);
217 6         111 my $el = $self->{enc}{doc}->createElement($ename);
218 6         26 $el->setAttribute(href => "#$id");
219 6         50 $el;
220             }
221              
222              
223             sub nil($;$)
224 3     3 0 2682 { my $self = shift;
225 3 100       11 my ($type, $name) = @_==2 ? @_ : (undef, $_[0]);
226 3         9 my ($ns, $local) = unpack_type $name;
227              
228 3         24 my $doc = $self->{enc}{doc};
229 3 100       25 my $el = $ns
230             ? $doc->createElementNS($ns, $local)
231             : $doc->createElement($local);
232              
233 3         8 $el->setAttribute($self->prefixed(SCHEMA2001i, 'nil'), 'true');
234 3 100       92 $el->setAttribute($self->prefixed(SCHEMA2001i, 'type')
235             , $self->prefixed($type)) if $type;
236              
237 3         89 $el;
238             }
239              
240              
241             sub array($$$@)
242 18     18 0 18546 { my ($self, $name, $itemtype, $array, %opts) = @_;
243              
244 18         37 my $enc = $self->{enc};
245 18         26 my $doc = $enc->{doc};
246              
247 18   100     69 my $offset = $opts{offset} || 0;
248 18         97 my $slice = $opts{slice};
249              
250 18         38 my ($min, $size) = ($offset, scalar @$array);
251 18   66     85 $min++ while $min <= $size && !defined $array->[$min];
252              
253 18 100 66     60 my $max = defined $slice && $min+$slice-1 < $size ? $min+$slice-1 : $size;
254 18   66     85 $max-- while $min <= $max && !defined $array->[$max];
255              
256 18         24 my $sparse = 0;
257 18         45 for(my $i = $min; $i < $max; $i++)
258 26 100       55 { next if defined $array->[$i];
259 2         3 $sparse = 1;
260 2         3 last;
261             }
262              
263 18 100       64 my $elname = $self->prefixed(defined $name ? $name : (SOAP11ENC, 'Array'));
264 18         365 my $el = $doc->createElement($elname);
265 18   100     61 my $nested = $opts{nested_array} || '';
266 18         38 my $type = $self->prefixed($itemtype)."$nested\[$size]";
267              
268 18 100       448 $el->setAttribute(id => $opts{id}) if defined $opts{id};
269             my $at = $opts{array_type} ? $opts{arrayType}
270 18 50       87 : $self->prefixed(SOAP11ENC, 'arrayType');
271 18 50       256 $el->setAttribute($at, $type) if defined $at;
272              
273 18 100       220 if($sparse)
274 2         5 { my $placeition = $self->prefixed(SOAP11ENC, 'position');
275 2         30 for(my $r = $min; $r <= $max; $r++)
276 6 100       48 { my $row = $array->[$r] or next;
277 4         39 my $node = $row->cloneNode(1);
278 4         13 $node->setAttribute($placeition, "[$r]");
279 4         40 $el->addChild($node);
280             }
281             }
282             else
283 16 100       39 { $el->setAttribute($self->prefixed(SOAP11ENC, 'offset'), "[$min]")
284             if $min > 0;
285 16         213 $el->addChild($array->[$_]) for $min..$max;
286             }
287              
288 18         431 $el;
289             }
290              
291              
292             sub multidim($$$@)
293 3     3 0 1211 { my ($self, $name, $itemtype, $array, %opts) = @_;
294 3         6 my $enc = $self->{enc};
295 3         4 my $doc = $enc->{doc};
296              
297             # determine dimensions
298 3         4 my @dims;
299 3         11 for(my $dim = $array; ref $dim eq 'ARRAY'; $dim = $dim->[0])
300 6         17 { push @dims, scalar @$dim;
301             }
302              
303 3         11 my $sparse = $self->_check_multidim($array, \@dims, '');
304 3 50       8 my $elname = $self->prefixed(defined $name ? $name : (SOAP11ENC, 'Array'));
305 3         57 my $el = $doc->createElement($elname);
306 3         16 my $type = $self->prefixed($itemtype) . '['.join(',', @dims).']';
307              
308 3 50       82 $el->setAttribute(id => $opts{id}) if defined $opts{id};
309 3         7 $el->setAttribute($self->prefixed(SOAP11ENC, 'arrayType'), $type);
310              
311 3         75 my @data = $self->_flatten_multidim($array, \@dims, '');
312 3 100       8 if($sparse)
313 2         6 { my $placeition = $self->prefixed(SOAP11ENC, 'position');
314 2         29 while(@data)
315 6         67 { my ($place, $field) = (shift @data, shift @data);
316 6         23 my $node = $field->cloneNode(1);
317 6         15 $node->setAttribute($placeition, "[$place]");
318 6         53 $el->addChild($node);
319             }
320             }
321             else
322 1         7 { $el->addChild($_) for odd_elements @data;
323             }
324              
325 3         110 $el;
326             }
327              
328             sub _check_multidim($$$)
329 10     10   13 { my ($self, $array, $dims, $loc) = @_;
330 10         14 my @dims = @$dims;
331              
332 10         12 my $expected = shift @dims;
333 10 50       17 @$array <= $expected
334             or error __x"dimension at ({location}) is {size}, larger than size {expect} of first row"
335             , location => $loc, size => scalar(@$array), expect => $expected;
336              
337 10         11 my $sparse = 0;
338 10         16 foreach (my $x = 0; $x < $expected; $x++)
339 56         54 { my $el = $array->[$x];
340 56 100       67 my $cell = length $loc ? "$loc,$x" : $x;
341              
342 56 100       74 if(!defined $el) { $sparse++ }
  37 100       47  
    50          
343             elsif(@dims==0) # bottom level
344 12 50       29 { UNIVERSAL::isa($el, 'XML::LibXML::Element')
345             or error __x"array element at ({location}) shall be a XML element or undef, is {value}"
346             , location => $cell, value => $el;
347             }
348             elsif(ref $el eq 'ARRAY')
349 7         14 { $sparse += $self->_check_multidim($el, \@dims, $cell);
350             }
351             else
352 0         0 { error __x"array at ({location}) expects ARRAY reference, is {value}"
353             , location => $cell, value => $el;
354             }
355             }
356              
357 10         17 $sparse;
358             }
359              
360             sub _flatten_multidim($$$)
361 10     10   15 { my ($self, $array, $dims, $loc) = @_;
362 10         14 my @dims = @$dims;
363              
364 10         14 my $expected = shift @dims;
365 10         25 my @data;
366 10         19 foreach (my $x = 0; $x < $expected; $x++)
367 56         48 { my $el = $array->[$x];
368 56 100       86 defined $el or next;
369              
370 19 100       32 my $cell = length $loc ? "$loc,$x" : $x;
371 19 100       37 push @data, @dims==0 ? ($cell, $el) # deepest dim
372             : $self->_flatten_multidim($el, \@dims, $cell);
373             }
374              
375 10         34 @data;
376             }
377              
378             #--------------------------------------------------
379              
380             sub rpcDecode(@)
381 0     0 0   { my $self = shift;
382 0           my @nodes = grep $_->isa('XML::LibXML::Element'), @_;
383 0           my $data = $self->_dec(\@nodes);
384              
385             #XXX MO: no idea why this is needed:
386 0           foreach my $d (@$data)
387 0 0         { next unless $d->{_NAME};
388 0           $d = { $d->{_NAME} => $d };
389             }
390            
391 0           my ($index, $hrefs) = ({}, []);
392 0           $self->_dec_find_ids_hrefs($index, $hrefs, \$data);
393 0           $self->_dec_resolve_hrefs($index, $hrefs);
394              
395 0 0         $data = $self->_dec_simplify_tree($data)
396             if $simplify;
397              
398 0 0         ref $data eq 'ARRAY'
399             or return $data;
400              
401 0 0         @$data > 1
402             or return $data->[0];
403              
404             # find the root element(s)
405 0           my @roots;
406 0   0       for(my $i = 0; $i < @_ && $i < @$data; $i++)
407 0           { my $root = $nodes[$i]->getAttributeNS(SOAP11ENC, 'root');
408 0 0 0       next if defined $root && $root==0;
409 0           push @roots, $data->[$i];
410             }
411              
412 0 0         my $root_type = @roots ? $roots[0]->{_TYPE} : undef;
413              
414             # address parameters by name
415             # On the top-level, we can strip on level. Some elements may appear
416             # more than once.
417 0           my %h;
418 0 0         foreach my $param (@roots ? @roots : @$data)
419 0           { delete $param->{_TYPE};
420 0           my ($k, $v) = %$param;
421 0 0         if(! exists $h{$k}) { $h{$k} = $v }
  0 0          
422 0           elsif(reftype $h{$k} eq 'ARRAY') { push @{$h{$k}}, $v }
  0            
423 0           else { $h{$k} = [ $h{$k}, $v ] }
424             }
425              
426 0 0         $h{_TYPE} = $root_type
427             if $root_type;
428              
429 0           \%h;
430             }
431              
432             sub _dec_reader($$@)
433 0     0     { my ($self, $node, $type) = splice @_, 0, 3;
434              
435             # We must decode the prefix from the $node context
436 0 0         if(substr($type, 0, 1) ne '{')
437 0 0         { my ($prefix, $local) = $type =~ m/^(.*?)\:(.*)/ ? ($1, $2) : ('',$type);
438 0   0       $type = pack_type $node->lookupNamespaceURI($prefix) // '', $local;
439             }
440              
441             my $r = try {
442 0     0     $self->schemas->reader($type
443             , element => type_of_node($node), is_type => 1, @_);
444 0           };
445 0 0   0     $r || sub { shift };
  0            
446             }
447              
448             sub _dec($;$$$)
449 0     0     { my ($self, $nodes, $basetype, $offset, $dims) = @_;
450 0           my $schemas = $self->schemas;
451 0           my $nss = $schemas->namespaces;
452              
453 0           my @res;
454 0 0         $#res = $offset-1 if defined $offset;
455              
456 0           foreach my $node (@$nodes)
457 0   0       { my $ns = $node->namespaceURI || '';
458              
459 0           my $label = type_of_node $node;
460 0           my $place;
461 0 0         if($dims)
462 0           { my $pos = $node->getAttributeNS(SOAP11ENC, 'position');
463 0 0 0       if($pos && $pos =~ m/^\[([\d,]+)\]/ )
464 0           { my @pos = split /\,/, $1;
465 0           $place = \$res[shift @pos];
466 0   0       $place = \(($$place ||= [])->[shift @pos]) while @pos;
467             }
468             }
469              
470 0 0         unless($place)
471 0           { push @res, undef;
472 0           $place = \$res[-1];
473             }
474              
475 0 0 0       if(my $href = $node->getAttribute('href') || '')
476 0           { $$place = { $label => { href => $href } };
477 0           next;
478             }
479              
480 0 0         if($ns ne SOAP11ENC)
481 0           { my $typedef = $node->getAttributeNS(SCHEMA2001i, 'type');
482 0 0         if($typedef)
483 0           { $$place = $self->_dec_typed($node, $typedef);
484 0           next;
485             }
486              
487 0           $$place = $self->_dec_other($node, $basetype);
488 0           next;
489             }
490              
491 0           my $local = $node->localName;
492 0 0         if($local eq 'Array')
493 0           { $$place = $self->_dec_other($node, $basetype);
494 0           next;
495             }
496              
497 0           $$place = $self->_dec_soapenc($node, pack_type($ns, $local));
498             }
499              
500 0           \@res;
501             }
502              
503             sub _dec_typed($$$)
504 0     0     { my ($self, $node, $type, $index) = @_;
505              
506 0           my $full = type_of_node $node;
507 0           my $read = $self->_dec_reader($node, $type);
508 0           my $child = $read->($node);
509 0 0         my $data = ref $child eq 'HASH' ? $child : { _ => $child };
510 0           $data->{_TYPE} = $type;
511 0           $data->{_NAME} = type_of_node $node;
512              
513 0           my $id = $node->getAttribute('id');
514 0 0         $data->{id} = $id if defined $id;
515              
516 0           $data;
517             }
518              
519             sub _dec_other($$)
520 0     0     { my ($self, $node, $basetype) = @_;
521 0           my $local = $node->localName;
522              
523 0           my $data;
524 0   0       my $type = $basetype || type_of_node $node;
525 0     0     my $read = try { $self->_dec_reader($node, $type) };
  0            
526 0 0         if($@)
527             { # warn $@->wasFatal->message; #--> element not found
528             # Element not known, so we must autodetect the type
529 0           my @childs = grep $_->isa('XML::LibXML::Element'), $node->childNodes;
530 0 0         if(@childs)
531 0           { my ($childbase, $dims);
532 0 0         if($type =~ m/(.+?)\s*\[([\d,]+)\]$/)
533 0           { $childbase = $1;
534 0           $dims = ($2 =~ tr/,//) + 1;
535             }
536 0           my $dec_childs = $self->_dec(\@childs, $childbase, 0, $dims);
537              
538 0           my $key = $local;
539 0 0         $key = '_' if $key eq 'Array'; # simplifies better
540 0 0         $data = { $key => $dec_childs } if $dec_childs;
541             }
542             else
543 0           { $data->{_} = $node->textContent;
544 0 0         $data->{_TYPE} = $basetype if $basetype;
545             }
546             }
547             else
548 0           { my @x = $read->($node);
549 0           $data = $x[0];
550 0 0         $data = { _ => $data } if ref $data ne 'HASH';
551 0 0         $data->{_TYPE} = $basetype if $basetype;
552             }
553              
554 0           $data->{_NAME} = type_of_node $node;
555              
556 0           my $id = $node->getAttribute('id');
557 0 0         $data->{id} = $id if defined $id;
558              
559 0           ($local => $data);
560             }
561              
562             sub _dec_soapenc($$)
563 0     0     { my ($self, $node, $type) = @_;
564 0 0         my $reader = $self->_dec_reader($node, $type)
565             or return $node;
566 0           my $data = $reader->($node);
567 0 0         $data = { _ => $data } if ref $data ne 'HASH';
568 0           $data->{_TYPE} = $type;
569 0           $data;
570             }
571              
572             sub _dec_find_ids_hrefs($$$)
573 0     0     { my ($self, $index, $hrefs, $node) = @_;
574 0 0         ref $$node or return;
575              
576 0 0         if(ref $$node eq 'ARRAY')
    0          
    0          
577 0           { foreach my $child (@$$node)
578 0           { $self->_dec_find_ids_hrefs($index, $hrefs, \$child);
579             }
580             }
581             elsif(ref $$node eq 'HASH')
582             { $index->{$$node->{id}} = $$node
583 0 0         if defined $$node->{id};
584              
585 0 0         if(my $href = $$node->{href})
586 0 0         { push @$hrefs, $href => $node if $href =~ s/^#//;
587             }
588              
589 0           foreach my $k (keys %$$node)
590 0           { $self->_dec_find_ids_hrefs($index, $hrefs, \( $$node->{$k} ));
591             }
592             }
593             elsif(UNIVERSAL::isa($$node, 'XML::LibXML::Element'))
594 0           { my $search = XML::LibXML::XPathContext->new($$node);
595             $index->{$_->value} = $_->getOwnerElement
596 0           for $search->findnodes('.//@id');
597              
598             # we cannot restore deep hrefs, so only top level
599 0 0         if(my $href = $$node->getAttribute('href'))
600 0 0         { push @$hrefs, $href => $node if $href =~ s/^#//;
601             }
602             }
603             }
604              
605             sub _dec_resolve_hrefs($$)
606 0     0     { my ($self, $index, $hrefs) = @_;
607              
608 0           while(@$hrefs)
609 0           { my ($to, $where) = (shift @$hrefs, shift @$hrefs);
610 0           my $dest = $index->{$to};
611 0 0         unless($dest)
612 0           { warning __x"cannot find id for href {name}", name => $to;
613 0           next;
614             }
615 0           $$where = $dest;
616             }
617             }
618              
619             sub _dec_array_hook($$$$$)
620 0     0     { my ($self, $node, $args, $where, $local, $r, $fulltype) = @_;
621              
622 0 0 0       my $at = $node->getAttributeNS(SOAP11ENC, 'arrayType')
623             || $node->getAttributeNS(WSDL11, 'arrayType')
624             or return $node;
625              
626 0 0         $at =~ m/^(.*) \s* \[ ([\d,]+)? \] $/x
627             or return $node;
628              
629 0           my ($preftype, $dims) = ($1, $2);
630 0 0         my @dims = defined $dims ? split /\,/, $dims : ();
631            
632 0           my $basetype;
633 0 0         if(index($preftype, ':') >= 0)
634 0           { my ($prefix, $local) = split /\:/, $preftype, 2;
635 0           $basetype = pack_type $node->lookupNamespaceURI($prefix), $local;
636             }
637             else
638 0           { $basetype = pack_type '', $preftype;
639             }
640              
641 0           my $table;
642 0 0         if(@dims < 2)
643 0           { $table = $self->_dec_array_one($node, $basetype, $dims[0]);
644             }
645             else
646 0     0     { my $first = first {$_->isa('XML::LibXML::Element')} $node->childNodes;
  0            
647 0 0 0       $table = $first && $first->getAttributeNS(SOAP11ENC, 'position')
648             ? $self->_dec_array_multisparse($node, $basetype, \@dims)
649             : $self->_dec_array_multi($node, $basetype, \@dims);
650             }
651              
652 0           (type_of_node($node) => $table);
653             }
654              
655             sub _dec_array_one($$;$)
656 0     0     { my ($self, $node, $basetype, $size) = @_;
657              
658 0   0       my $off = $node->getAttributeNS(SOAP11ENC, 'offset') || '[0]';
659 0 0         $off =~ m/^\[(\d+)\]$/ or return $node;
660              
661 0           my $offset = $1;
662 0           my @childs = grep $_->isa('XML::LibXML::Element'), $node->childNodes;
663 0           my $array = $self->_dec(\@childs, $basetype, $offset, 1);
664 0 0         $#$array = $size -1 if $size; # resize array to specified size
665 0           $array;
666             }
667              
668             sub _dec_array_multisparse($$$)
669 0     0     { my ($self, $node, $basetype, $dims) = @_;
670              
671 0           my @childs = grep $_->isa('XML::LibXML::Element'), $node->childNodes;
672 0           my $array = $self->_dec(\@childs, $basetype, 0, scalar(@$dims));
673 0           $array;
674             }
675              
676             sub _dec_array_multi($$$)
677 0     0     { my ($self, $node, $basetype, $dims) = @_;
678              
679 0           my @childs = grep $_->isa('XML::LibXML::Element'), $node->childNodes;
680 0           $self->_dec_array_multi_slice(\@childs, $basetype, $dims);
681             }
682              
683             sub _dec_array_multi_slice($$$)
684 0     0     { my ($self, $childs, $basetype, $dims) = @_;
685 0 0         if(@$dims==1)
686 0           { my @col = splice @$childs, 0, $dims->[0];
687 0           return $self->_dec(\@col, $basetype);
688             }
689 0           my ($rows, @dims) = @$dims;
690              
691 0           [map $self->_dec_array_multi_slice($childs, $basetype, \@dims), 1..$rows];
692             }
693              
694             sub _dec_simplify_tree($@)
695 0     0     { my ($self, $tree, %opts) = @_;
696 0 0         defined $tree or return ();
697 0           $self->{dec}{_simple_recurse} = {};
698 0           $self->_dec_simple($tree, \%opts);
699             }
700              
701             sub _dec_simple($$)
702 0     0     { my ($self, $tree, $opts) = @_;
703              
704 0 0         ref $tree
705             or return $tree;
706              
707             return $tree
708 0 0         if $self->{dec}{_simple_recurse}{$tree};
709              
710 0           $self->{dec}{_simple_recurse}{$tree}++;
711              
712 0 0         if(ref $tree eq 'ARRAY')
713 0           { my @a = map $self->_dec_simple($_, $opts), @$tree;
714 0 0         return $a[0] if @a==1;
715              
716             # array of hash with each one element becomes hash
717 0           my %out;
718 0           foreach my $hash (@a)
719 0 0 0       { ref $hash eq 'HASH' && keys %$hash==1
720             or return \@a;
721              
722 0           my ($name, $value) = each %$hash;
723 0 0         if(!exists $out{$name}) { $out{$name} = $value }
  0 0          
724             elsif(ref $out{$name} eq 'ARRAY')
725             { $out{$name} = [ $out{$name} ] # array of array: keep []
726 0 0 0       if ref $out{$name}[0] ne 'ARRAY' && ref $value eq 'ARRAY';
727 0           push @{$out{$name}}, $value;
  0            
728             }
729 0           else { $out{$name} = [ $out{$name}, $value ] }
730             }
731 0           return \%out;
732             }
733              
734 0 0         ref $tree eq 'HASH'
735             or return $tree;
736              
737 0           foreach my $k (keys %$tree)
738 0 0         { if($k =~ m/^(?:_NAME$|_TYPE$|id$)/) { delete $tree->{$k} }
  0 0          
739             elsif(ref $tree->{$k})
740 0           { $tree->{$k} = $self->_dec_simple($tree->{$k}, $opts);
741             }
742             }
743              
744 0           delete $self->{dec}{_simple_recurse}{$tree};
745              
746 0 0 0       keys(%$tree)==1 && exists $tree->{_} ? $tree->{_} : $tree;
747             }
748              
749             1;