File Coverage

lib/XML/Compile/SOAP/Client.pm
Criterion Covered Total %
statement 41 65 63.0
branch 12 38 31.5
condition 4 15 26.6
subroutine 10 13 76.9
pod 1 3 33.3
total 68 134 50.7


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::SOAP::Client;
10 7     7   1004 use vars '$VERSION';
  7         10  
  7         328  
11             $VERSION = '3.28';
12              
13              
14 7     7   36 use warnings;
  7         11  
  7         160  
15 7     7   30 use strict;
  7         24  
  7         139  
16              
17 7     7   28 use Log::Report 'xml-compile-soap';
  7         12  
  7         57  
18              
19 7     7   1752 use XML::Compile::Util qw/unpack_type/;
  7         18  
  7         342  
20 7     7   2111 use XML::Compile::SOAP::Trace;
  7         19  
  7         221  
21 7     7   76 use Time::HiRes qw/time/;
  7         14  
  7         52  
22              
23              
24 0     0 0 0 sub new(@) { panic __PACKAGE__." only secundary in multiple inheritance" }
25 0     0 0 0 sub init($) { shift }
26              
27             #--------------
28              
29             my $rr = 'request-response';
30              
31             sub compileClient(@)
32 1     1 1 13 { my ($self, %args) = @_;
33              
34 1         3 my $name = $args{name};
35 1   33     13 my $kind = $args{kind} || $rr;
36 1 50 33     4 $kind eq $rr || $kind eq 'one-way'
37             or error __x"operation direction `{kind}' not supported for {name}"
38             , rr => $rr, kind => $kind, name => $name;
39              
40             my $encode = $args{encode}
41 1 50       3 or error __x"encode for client {name} required", name => $name;
42              
43             my $decode = $args{decode}
44 1 50       3 or error __x"decode for client {name} required", name => $name;
45              
46             my $transport = $args{transport}
47 1 50       2 or error __x"transport for client {name} required", name => $name;
48              
49 1 50       10 if(ref $transport eq 'CODE') { ; }
    0          
50             elsif(UNIVERSAL::isa($transport, 'XML::Compile::Transport::SOAPHTTP'))
51 0         0 { $transport = $transport->compileClient(soap => $args{soap});
52             }
53             else
54 0   0     0 { error __x"transport for client {name} is code ref or {type} object, not {is}"
55             , name => $name, type => 'XML::Compile::Transport::SOAPHTTP'
56             , is => (ref $transport || $transport);
57             }
58              
59             my $output_handler = sub {
60 1     1   4 my ($ans, $trace, $xops) = @_;
61             wantarray or return
62 1 50       10 UNIVERSAL::isa($ans, 'XML::LibXML::Node') ? $decode->($ans) : $ans;
    50          
63              
64 0 0       0 if(UNIVERSAL::isa($ans, 'XML::LibXML::Node'))
65 0         0 { $ans = try { $decode->($ans) };
  0         0  
66 0 0       0 if($@)
67 0         0 { $trace->{decode_errors} = $@;
68 0         0 my $fatal = $@->wasFatal;
69 0         0 $trace->{errors} = [$fatal];
70 0         0 $fatal->message($fatal->message->concat('decode error: ', 1));
71             }
72              
73 0         0 my $end = time;
74 0         0 $trace->{decode_elapse} = $end - $trace->{transport_end};
75 0         0 $trace->{elapse} = $end - $trace->{start};
76             }
77             else
78             { $trace->{elapse} = $trace->{transport_end} - $trace->{start}
79 0 0       0 if defined $trace->{transport_end};
80             }
81 0         0 ($ans, XML::Compile::SOAP::Trace->new($trace), $xops);
82 1         12 };
83              
84             $args{async}
85             ? sub # Asynchronous call, f.i. X::C::Transfer::SOAPHTTP::AnyEvent
86 0 0   0   0 { my ($data, $charset)
    0          
87             = UNIVERSAL::isa($_[0], 'HASH') ? @_
88             : @_%2==0 ? ({@_}, undef)
89             : error __x"operation `{name}' called with odd length parameter list"
90             , name => $name;
91              
92             my $callback = delete $data->{_callback}
93 0 0       0 or error __x"operation `{name}' is async, so requires _callback";
94              
95 0         0 my $trace = {start => time};
96 0         0 my ($req, $mtom) = $encode->($data, $charset);
97 0         0 $trace->{encode_elapse} = time - $trace->{start};
98              
99             $transport->($req, $trace, $mtom
100 0         0 , sub { $callback->($output_handler->(@_)) }
101 0         0 );
102             }
103             : sub # Synchronous call, f.i. XML::Compile::Transfer::SOAPHTTP
104 1 50   1   289 { my ($data, $charset)
    50          
105             = UNIVERSAL::isa($_[0], 'HASH') ? @_
106             : @_%2==0 ? ({@_}, undef)
107             : panic(__x"operation `{name}' called with odd length parameter list"
108             , name => $name);
109              
110             $data->{_callback}
111 1 50       3 and error __x"operation `{name}' called with _callback, but "
112             . "compiled without async flag", name => $name;
113              
114 1         8 my $trace = {start => time};
115 1         4 my ($req, $mtom) = $encode->($data, $charset);
116 1         12 my ($ans, $xops) = $transport->($req, $trace, $mtom);
117 1 50 33     10 wantarray || !$xops || ! keys %$xops
      33        
118             or warning "loosing received XOPs";
119              
120 1         4 $trace->{encode_elapse} = $trace->{transport_start} - $trace->{start};
121 1         4 $output_handler->($ans, $trace, $xops);
122 1 50       13 };
123             }
124              
125             #------------------------------------------------
126              
127              
128             1;