line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyrights 2016-2020 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-Mojolicious. |
6
|
|
|
|
|
|
|
# Meta-POD processed 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::Transport::SOAPHTTP_MojoUA; |
10
|
2
|
|
|
2
|
|
1307160
|
use vars '$VERSION'; |
|
2
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
99
|
|
11
|
|
|
|
|
|
|
$VERSION = '0.06'; |
12
|
|
|
|
|
|
|
|
13
|
2
|
|
|
2
|
|
11
|
use base 'XML::Compile::Transport'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
569
|
|
14
|
|
|
|
|
|
|
|
15
|
2
|
|
|
2
|
|
2532
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
42
|
|
16
|
2
|
|
|
2
|
|
10
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
54
|
|
17
|
|
|
|
|
|
|
|
18
|
2
|
|
|
2
|
|
9
|
use Log::Report 'xml-compile-soap-mojolicious'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
9
|
|
19
|
|
|
|
|
|
|
|
20
|
2
|
|
|
2
|
|
1401
|
use XML::Compile::Transport::SOAPHTTP (); |
|
2
|
|
|
|
|
69462
|
|
|
2
|
|
|
|
|
64
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
BEGIN { |
23
|
|
|
|
|
|
|
# code mixin from XML::Compile::Transport::SOAPHTTP |
24
|
2
|
|
|
2
|
|
34
|
no strict 'refs'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
114
|
|
25
|
2
|
|
|
2
|
|
9
|
foreach (qw/_prepare_xop_call _prepare_simple_call _prepare_for_no_answer/) { |
26
|
6
|
|
|
|
|
8
|
*{ __PACKAGE__ . "::$_" } = \&{"XML::Compile::Transport::SOAPHTTP::$_"}; |
|
6
|
|
|
|
|
69
|
|
|
6
|
|
|
|
|
19
|
|
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
2
|
|
|
2
|
|
11
|
use XML::Compile::SOAP::Util qw/SOAP11ENV SOAP11HTTP/; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
98
|
|
31
|
2
|
|
|
2
|
|
10
|
use XML::Compile (); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
23
|
|
32
|
|
|
|
|
|
|
|
33
|
2
|
|
|
2
|
|
575
|
use Mojolicious (); # only for version info?! |
|
2
|
|
|
|
|
43572
|
|
|
2
|
|
|
|
|
89
|
|
34
|
2
|
|
|
2
|
|
13
|
use Mojo::UserAgent (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
25
|
|
35
|
2
|
|
|
2
|
|
9
|
use Mojo::IOLoop (); |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
19
|
|
36
|
2
|
|
|
2
|
|
8
|
use HTTP::Request (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
21
|
|
37
|
2
|
|
|
2
|
|
9
|
use HTTP::Response (); |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
30
|
|
38
|
2
|
|
|
2
|
|
16
|
use HTTP::Headers (); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
47
|
|
39
|
2
|
|
|
2
|
|
10
|
use Scalar::Util qw(blessed reftype); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
2752
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# (Microsofts HTTP Extension Framework) |
42
|
|
|
|
|
|
|
my $http_ext_id = SOAP11ENV; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
__PACKAGE__->register(SOAP11HTTP); |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub init($) { |
48
|
1
|
|
|
1
|
0
|
88605
|
my ($self, $args) = @_; |
49
|
1
|
50
|
|
|
|
10
|
if(my $cb = $self->{ua_start_cb} = delete $args->{ua_start_callback}) { |
50
|
0
|
0
|
|
|
|
0
|
panic "callback not a code" if reftype $cb ne 'CODE'; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
1
|
|
|
|
|
2
|
$self->{mojo_ua} = $args->{mojo_ua}; |
54
|
1
|
|
|
|
|
7
|
$self->SUPER::init($args); |
55
|
1
|
|
|
|
|
64
|
$self; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
sub initWSDL11($) { |
59
|
0
|
|
|
0
|
0
|
0
|
my ($class, $wsdl) = @_; |
60
|
0
|
|
|
|
|
0
|
trace "initialize SOAPHTTP-MojoUA transporter for WSDL11"; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
#------------------------------------------- |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
|
66
|
1
|
|
|
1
|
1
|
4
|
sub uaStartCallback { shift->{ua_start_cb} } |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
#------------------------------------------- |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub compileClient(@) { |
72
|
1
|
|
|
1
|
1
|
140260
|
my ( $self, %args ) = @_; |
73
|
1
|
|
|
|
|
6
|
my $call = $self->_prepare_call( \%args ); |
74
|
1
|
|
50
|
|
|
7
|
my $kind = $args{kind} || 'request-response'; |
75
|
1
|
|
|
|
|
8
|
my $parser = XML::LibXML->new; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub { |
78
|
1
|
|
|
1
|
|
37552
|
my ($xmlout, $trace, $mtom, $callback) = @_; |
79
|
1
|
|
|
|
|
3
|
my $start = time; |
80
|
1
|
50
|
|
|
|
14
|
my $textout = ref $xmlout ? $xmlout->toString : $xmlout; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
#warn $xmlout->toString(1); # show message sent |
83
|
|
|
|
|
|
|
|
84
|
1
|
|
|
|
|
57
|
my $stringify = time; |
85
|
1
|
|
|
|
|
4
|
$trace->{transport_start} = $start; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
my $handler = sub { |
88
|
1
|
|
|
|
|
3
|
my ($textin, $xops) = @_; |
89
|
1
|
|
|
|
|
2
|
my $connected = time; |
90
|
|
|
|
|
|
|
|
91
|
1
|
|
|
|
|
2
|
my $xmlin; |
92
|
1
|
50
|
|
|
|
3
|
if($textin) { |
93
|
0
|
|
|
|
|
0
|
$xmlin = eval { $parser->parse_string($$textin) }; |
|
0
|
|
|
|
|
0
|
|
94
|
0
|
0
|
|
|
|
0
|
$trace->{error} = $@ if $@; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
1
|
|
|
|
|
1
|
my $answer; |
98
|
1
|
50
|
|
|
|
7
|
if($kind eq 'one-way') { |
|
|
50
|
|
|
|
|
|
99
|
0
|
|
|
|
|
0
|
my $response = $trace->{http_response}; |
100
|
0
|
0
|
|
|
|
0
|
my $code = defined $response ? $response->code : -1; |
101
|
0
|
0
|
0
|
|
|
0
|
if($code == 202) { $answer = $xmlin || {} } |
|
0
|
|
|
|
|
0
|
|
102
|
0
|
|
|
|
|
0
|
else { $trace->{error} = "call failed with code $code" } |
103
|
|
|
|
|
|
|
} |
104
|
0
|
|
|
|
|
0
|
elsif($xmlin) { $answer = $xmlin } |
105
|
1
|
|
50
|
|
|
4
|
else { $trace->{error} ||= 'no xml as answer' } |
106
|
|
|
|
|
|
|
|
107
|
1
|
|
|
|
|
1029
|
my $end = $trace->{transport_end} = time; |
108
|
|
|
|
|
|
|
|
109
|
1
|
|
|
|
|
4
|
$trace->{stringify_elapse} = $stringify - $start; |
110
|
1
|
|
|
|
|
3
|
$trace->{connect_elapse} = $connected - $stringify; |
111
|
1
|
|
|
|
|
3
|
$trace->{parse_elapse} = $end - $connected; |
112
|
1
|
|
|
|
|
2
|
$trace->{transport_elapse} = $end - $start; |
113
|
|
|
|
|
|
|
|
114
|
1
|
|
|
|
|
6
|
return ( $answer, $trace, $xops ); |
115
|
1
|
|
|
|
|
8
|
}; |
116
|
|
|
|
|
|
|
|
117
|
1
|
|
|
|
|
6
|
$call->( \$textout, $trace, $mtom, sub { $callback->( $handler->(@_) ) } ); |
|
1
|
|
|
|
|
5
|
|
118
|
1
|
|
|
|
|
21
|
}; |
119
|
|
|
|
|
|
|
} ## end sub compileClient(@) |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub _prepare_call($) { |
123
|
1
|
|
|
1
|
|
3
|
my ($self, $args) = @_; |
124
|
1
|
|
50
|
|
|
7
|
my $method = $args->{method} || 'POST'; |
125
|
1
|
|
50
|
|
|
6
|
my $soap = $args->{soap} || 'SOAP11'; |
126
|
1
|
50
|
|
|
|
4
|
my $version = ref $soap ? $soap->version : $soap; |
127
|
1
|
|
50
|
|
|
4
|
my $mpost_id = $args->{mpost_id} || 42; |
128
|
1
|
|
|
|
|
2
|
my $action = $args->{action}; |
129
|
1
|
|
|
|
|
2
|
my $mime = $args->{mime}; |
130
|
1
|
|
50
|
|
|
4
|
my $kind = $args->{kind} || 'request-response'; |
131
|
1
|
|
33
|
|
|
4
|
my $expect = $kind ne 'one-way' && $kind ne 'notification-operation'; |
132
|
|
|
|
|
|
|
|
133
|
1
|
|
|
|
|
14
|
my $charset = $self->charset; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Prepare header |
136
|
1
|
|
33
|
|
|
18
|
my $header = $args->{header} || HTTP::Headers->new; |
137
|
1
|
|
|
|
|
18
|
$self->headerAddVersions($header); |
138
|
|
|
|
|
|
|
|
139
|
1
|
|
|
|
|
39
|
my $content_type; |
140
|
1
|
50
|
|
|
|
4
|
if($version eq 'SOAP11') { |
|
|
0
|
|
|
|
|
|
141
|
1
|
50
|
33
|
|
|
7
|
$mime ||= ref $soap ? $soap->mimeType : 'text/xml'; |
142
|
1
|
|
|
|
|
3
|
$content_type = qq{$mime; charset=$charset}; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
elsif($version eq 'SOAP12') { |
145
|
0
|
0
|
0
|
|
|
0
|
$mime ||= ref $soap ? $soap->mimeType : 'application/soap+xml'; |
146
|
0
|
0
|
|
|
|
0
|
my $sa = defined $action ? qq{; action="$action"} : ''; |
147
|
0
|
|
|
|
|
0
|
$content_type = qq{$mime; charset=$charset$sa}; |
148
|
0
|
|
|
|
|
0
|
$header->header( Accept => $mime ); # not the HTML answer |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
else { |
151
|
0
|
|
|
|
|
0
|
error __x"SOAP version {version} not implemented", version => $version; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
1
|
50
|
|
|
|
3
|
if($method eq 'POST') { |
|
|
0
|
|
|
|
|
|
155
|
1
|
50
|
|
|
|
3
|
$header->header( SOAPAction => qq{"$action"} ) |
156
|
|
|
|
|
|
|
if defined $action; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
elsif($method eq 'M-POST') { |
159
|
0
|
|
|
|
|
0
|
$header->header( Man => qq{"$http_ext_id"; ns=$mpost_id} ); |
160
|
0
|
0
|
|
|
|
0
|
$header->header( "$mpost_id-SOAPAction", qq{"$action"} ) |
161
|
|
|
|
|
|
|
if $version eq 'SOAP11'; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
else { |
164
|
0
|
|
|
|
|
0
|
error __x"SOAP method must be POST or M-POST, not {method}" |
165
|
|
|
|
|
|
|
, method => $method; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
# Prepare request |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Ideally, we should change server when one fails, and stick to that |
171
|
|
|
|
|
|
|
# one as long as possible. |
172
|
1
|
|
|
|
|
7
|
my $server = $self->address; |
173
|
1
|
|
|
|
|
13
|
my $request = HTTP::Request->new( |
174
|
|
|
|
|
|
|
$method => $server, |
175
|
|
|
|
|
|
|
$header |
176
|
|
|
|
|
|
|
); |
177
|
1
|
|
|
|
|
3917
|
$request->protocol('HTTP/1.1'); |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# Create handler |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
my ($create_message, $parse_message) |
182
|
1
|
50
|
|
|
|
19
|
= exists $INC{'XML/Compile/XOP.pm'} |
183
|
|
|
|
|
|
|
? $self->_prepare_xop_call($content_type) |
184
|
|
|
|
|
|
|
: $self->_prepare_simple_call($content_type); |
185
|
|
|
|
|
|
|
|
186
|
1
|
50
|
|
|
|
18
|
$parse_message = $self->_prepare_for_no_answer($parse_message) |
187
|
|
|
|
|
|
|
unless $expect; |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# Needs to be outside the sub so it does not go out of scope |
190
|
|
|
|
|
|
|
# when the sub is left (which would cause the termination of |
191
|
|
|
|
|
|
|
# the request) |
192
|
1
|
|
33
|
|
|
5
|
my $ua = $self->{mojo_ua} || Mojo::UserAgent->new; |
193
|
|
|
|
|
|
|
|
194
|
1
|
50
|
|
|
|
4
|
if(my $callback = $self->uaStartCallback) { |
195
|
0
|
|
|
|
|
0
|
$ua->on(start => $callback); |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# async call |
199
|
|
|
|
|
|
|
sub { |
200
|
1
|
|
|
1
|
|
3
|
my ( $content, $trace, $mtom, $callback ) = @_; |
201
|
1
|
|
|
|
|
6
|
$create_message->($request, $content, $mtom); |
202
|
|
|
|
|
|
|
|
203
|
1
|
|
|
|
|
216
|
$trace->{http_request} = $request; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
my $handler = sub { |
206
|
1
|
|
|
|
|
2
|
my $tx = shift; |
207
|
|
|
|
|
|
|
|
208
|
1
|
50
|
33
|
|
|
22
|
unless(blessed $tx && $tx->isa('Mojo::Transaction::HTTP')) { |
209
|
0
|
|
|
|
|
0
|
$trace->{error} = "Did not receive a transaction object"; |
210
|
0
|
|
|
|
|
0
|
return $callback->(undef, undef, $trace); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
1
|
|
|
|
|
4
|
my $res = $tx->res; |
214
|
1
|
|
|
|
|
6
|
my $headers = $res->headers->to_hash(1); |
215
|
1
|
|
|
|
|
37
|
foreach my $h ( keys %{$headers} ) { |
|
1
|
|
|
|
|
4
|
|
216
|
4
|
50
|
|
|
|
13
|
if ( reftype $headers->{$h} eq 'ARRAY') { |
217
|
4
|
|
|
|
|
5
|
$headers->{$h} = join ', ', @{$headers->{$h}}; |
|
4
|
|
|
|
|
10
|
|
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
1
|
|
|
|
|
4
|
my $err = $res->error; |
222
|
|
|
|
|
|
|
$headers->{'Client-Warning'} = 'Client side error: '.$err->{message} |
223
|
1
|
50
|
33
|
|
|
9
|
if $err && !$err->{code}; |
224
|
|
|
|
|
|
|
|
225
|
1
|
|
|
|
|
7
|
my $response = $trace->{http_response} = HTTP::Response->new( |
226
|
|
|
|
|
|
|
$res->code, $res->message, [%$headers], $res->body |
227
|
|
|
|
|
|
|
); |
228
|
|
|
|
|
|
|
|
229
|
1
|
50
|
|
|
|
231
|
if($response->header('Client-Warning')) { |
230
|
0
|
|
|
|
|
0
|
$trace->{error} = $response->message; |
231
|
0
|
|
|
|
|
0
|
return $callback->(undef, undef, $trace); |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
1
|
50
|
|
|
|
59
|
if($response->is_error) { |
235
|
1
|
|
|
|
|
13
|
$trace->{error} = $response->message; |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
# still try to parse the response for Fault blocks |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
1
|
|
|
|
|
18
|
my ($parsed, $mtom) = try { $parse_message->($response) }; |
|
1
|
|
|
|
|
313
|
|
241
|
1
|
50
|
|
|
|
443
|
if ($@) { |
242
|
1
|
|
|
|
|
15
|
$trace->{error} = $@->wasFatal->message; |
243
|
1
|
|
|
|
|
31
|
return $callback->(undef, undef, $trace); |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
0
|
|
|
|
|
0
|
try { $callback->($parsed, $mtom, $trace) }; |
|
0
|
|
|
|
|
0
|
|
247
|
1
|
|
|
|
|
8
|
}; |
248
|
|
|
|
|
|
|
|
249
|
1
|
|
|
|
|
5
|
my $tx = $ua->build_tx($request->method => $request->uri->as_string); |
250
|
|
|
|
|
|
|
|
251
|
1
|
|
|
|
|
338
|
foreach my $hdr_name ($request->headers->header_field_names) { |
252
|
7
|
100
|
|
|
|
253
|
next if $hdr_name eq "Content-Length"; |
253
|
|
|
|
|
|
|
|
254
|
6
|
|
|
|
|
15
|
foreach my $hdr ( $request->headers->header($hdr_name) ) { |
255
|
6
|
|
|
|
|
216
|
$tx->req->headers->append( $hdr_name => $hdr ); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
} |
258
|
1
|
|
|
|
|
32
|
$tx->req->body($request->content); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
$ua->start( |
261
|
|
|
|
|
|
|
$tx => sub { |
262
|
1
|
|
|
|
|
20974
|
my ($ua, $tx) = @_; |
263
|
1
|
|
|
|
|
4
|
$handler->($tx); |
264
|
|
|
|
|
|
|
}, |
265
|
1
|
|
|
|
|
76
|
); |
266
|
1
|
|
|
|
|
17
|
}; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
sub headerAddVersions($) { |
272
|
1
|
|
|
1
|
1
|
3
|
my ( $thing, $h ) = @_; |
273
|
1
|
|
|
|
|
3
|
foreach my $pkg ( |
274
|
|
|
|
|
|
|
qw/XML::Compile |
275
|
|
|
|
|
|
|
XML::Compile::Cache |
276
|
|
|
|
|
|
|
XML::Compile::SOAP |
277
|
|
|
|
|
|
|
XML::LibXML |
278
|
|
|
|
|
|
|
Mojolicious/ ) |
279
|
|
|
|
|
|
|
{ |
280
|
2
|
|
|
2
|
|
16
|
no strict 'refs'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
224
|
|
281
|
5
|
|
50
|
|
|
198
|
my $version = ${"${pkg}::VERSION"} || 'undef'; |
282
|
5
|
|
|
|
|
17
|
( my $field = "X-$pkg-Version" ) =~ s/\:\:/-/g; |
283
|
5
|
|
|
|
|
14
|
$h->header($field => $version); |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
1; |