line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ====================================================================== |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (C) 2000-2005 Paul Kulchenko (paulclinger@yahoo.com) |
4
|
|
|
|
|
|
|
# SOAP::Lite is free software; you can redistribute it |
5
|
|
|
|
|
|
|
# and/or modify it under the same terms as Perl itself. |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# ====================================================================== |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# Formatting hint: |
10
|
|
|
|
|
|
|
# Target is the source code format laid out in Perl Best Practices (4 spaces |
11
|
|
|
|
|
|
|
# indent, opening brace on condition line, no cuddled else). |
12
|
|
|
|
|
|
|
# |
13
|
|
|
|
|
|
|
# October 2007, Martin Kutter |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
package SOAP::Lite; |
16
|
|
|
|
|
|
|
|
17
|
25
|
|
|
25
|
|
221583
|
use strict; |
|
25
|
|
|
|
|
69
|
|
|
25
|
|
|
|
|
1267
|
|
18
|
25
|
|
|
25
|
|
140
|
use warnings; |
|
25
|
|
|
|
|
51
|
|
|
25
|
|
|
|
|
8841
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
our $VERSION = '1.11'; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
package SOAP::XMLSchemaApacheSOAP::Deserializer; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub as_map { |
25
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
26
|
|
|
|
|
|
|
return { |
27
|
0
|
|
|
|
|
0
|
map { |
28
|
0
|
0
|
|
|
|
0
|
my $hash = ($self->decode_object($_))[1]; |
29
|
0
|
|
|
|
|
0
|
($hash->{key} => $hash->{value}) |
30
|
0
|
|
|
|
|
0
|
} @{$_[3] || []} |
31
|
|
|
|
|
|
|
}; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
sub as_Map; *as_Map = \&as_map; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# Thank to Kenneth Draper for this contribution |
36
|
|
|
|
|
|
|
sub as_vector { |
37
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
38
|
0
|
0
|
|
|
|
0
|
return [ map { scalar(($self->decode_object($_))[1]) } @{$_[3] || []} ]; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
sub as_Vector; *as_Vector = \&as_vector; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
package SOAP::XMLSchema::Serializer; |
45
|
|
|
|
|
|
|
|
46
|
25
|
|
|
25
|
|
170
|
use vars qw(@ISA); |
|
25
|
|
|
|
|
54
|
|
|
25
|
|
|
|
|
2983
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub xmlschemaclass { |
49
|
136
|
|
|
136
|
|
197
|
my $self = shift; |
50
|
136
|
100
|
|
|
|
575
|
return $ISA[0] unless @_; |
51
|
25
|
|
|
|
|
787
|
@ISA = (shift); |
52
|
25
|
|
|
|
|
116
|
return $self; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
package SOAP::XMLSchema1999::Serializer; |
58
|
|
|
|
|
|
|
|
59
|
25
|
|
|
25
|
|
147
|
use vars qw(@EXPORT $AUTOLOAD); |
|
25
|
|
|
|
|
56
|
|
|
25
|
|
|
|
|
6215
|
|
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub AUTOLOAD { |
62
|
61
|
|
|
61
|
|
18618
|
local($1,$2); |
63
|
61
|
|
|
|
|
374
|
my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/; |
64
|
61
|
100
|
|
|
|
167
|
return if $method eq 'DESTROY'; |
65
|
25
|
|
|
25
|
|
142
|
no strict 'refs'; |
|
25
|
|
|
|
|
145
|
|
|
25
|
|
|
|
|
7911
|
|
66
|
|
|
|
|
|
|
|
67
|
60
|
|
|
|
|
104
|
my $export_var = $package . '::EXPORT'; |
68
|
60
|
|
|
|
|
398
|
my @export = @$export_var; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# Removed in 0.69 - this is a total hack. For some reason this is failing |
71
|
|
|
|
|
|
|
# despite not being a fatal error condition. |
72
|
|
|
|
|
|
|
# die "Type '$method' can't be found in a schema class '$package'\n" |
73
|
|
|
|
|
|
|
# unless $method =~ s/^as_// && grep {$_ eq $method} @{$export_var}; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# This was added in its place - it is still a hack, but it performs the |
76
|
|
|
|
|
|
|
# necessary substitution. It just does not die. |
77
|
60
|
100
|
66
|
|
|
280
|
if ($method =~ s/^as_// && grep {$_ eq $method} @{$export_var}) { |
|
2065
|
|
|
|
|
2851
|
|
|
58
|
|
|
|
|
173
|
|
78
|
|
|
|
|
|
|
# print STDERR "method is now '$method'\n"; |
79
|
|
|
|
|
|
|
} else { |
80
|
2
|
|
|
|
|
14
|
return; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
58
|
|
|
|
|
106
|
$method =~ s/_/-/; # fix ur-type |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
*$AUTOLOAD = sub { |
86
|
72
|
|
|
72
|
|
200
|
my $self = shift; |
87
|
72
|
|
|
|
|
128
|
my($value, $name, $type, $attr) = @_; |
88
|
72
|
|
|
|
|
503
|
return [$name, {'xsi:type' => "xsd:$method", %$attr}, $value]; |
89
|
58
|
|
|
|
|
420
|
}; |
90
|
58
|
|
|
|
|
352
|
goto &$AUTOLOAD; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
BEGIN { |
94
|
25
|
|
|
25
|
|
254
|
@EXPORT = qw(ur_type |
95
|
|
|
|
|
|
|
float double decimal timeDuration recurringDuration uriReference |
96
|
|
|
|
|
|
|
integer nonPositiveInteger negativeInteger long int short byte |
97
|
|
|
|
|
|
|
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte |
98
|
|
|
|
|
|
|
positiveInteger timeInstant time timePeriod date month year century |
99
|
|
|
|
|
|
|
recurringDate recurringDay language |
100
|
|
|
|
|
|
|
base64 hex string boolean |
101
|
|
|
|
|
|
|
); |
102
|
|
|
|
|
|
|
# TODO: replace by symbol table operations... |
103
|
|
|
|
|
|
|
# predeclare subs, so ->can check will be positive |
104
|
25
|
|
|
|
|
89
|
foreach (@EXPORT) { eval "sub as_$_" } |
|
850
|
|
|
|
|
47126
|
|
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
25
|
|
|
25
|
|
139
|
sub nilValue { 'null' } |
108
|
|
|
|
|
|
|
|
109
|
1
|
|
|
1
|
|
93
|
sub anyTypeValue { 'ur-type' } |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub as_base64 { |
112
|
2
|
|
|
2
|
|
98
|
my ($self, $value, $name, $type, $attr) = @_; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# Fixes #30271 for 5.8 and above. |
115
|
|
|
|
|
|
|
# Won't fix for 5.6 and below - perl can't handle unicode before |
116
|
|
|
|
|
|
|
# 5.8, and applying pack() to everything is just a slowdown. |
117
|
2
|
50
|
|
|
|
8
|
if ($SOAP::Constants::HAS_ENCODE) { |
118
|
2
|
50
|
|
|
|
22
|
if (Encode::is_utf8($value)) { |
119
|
0
|
0
|
|
|
|
0
|
if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions. |
120
|
0
|
|
|
|
|
0
|
Encode::_utf8_off($value); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
else { |
123
|
0
|
|
|
|
|
0
|
$value = pack('C*',unpack('C*',$value)); # the slow but safe way, |
124
|
|
|
|
|
|
|
# but this fallback works always. |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
2
|
|
|
|
|
17
|
require MIME::Base64; |
130
|
|
|
|
|
|
|
return [ |
131
|
2
|
|
|
|
|
20
|
$name, |
132
|
|
|
|
|
|
|
{ |
133
|
|
|
|
|
|
|
'xsi:type' => SOAP::Utils::qualify($self->encprefix => 'base64'), |
134
|
|
|
|
|
|
|
%$attr |
135
|
|
|
|
|
|
|
}, |
136
|
|
|
|
|
|
|
MIME::Base64::encode_base64($value,'') |
137
|
|
|
|
|
|
|
]; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub as_hex { |
141
|
1
|
|
|
1
|
|
4
|
my ($self, $value, $name, $type, $attr) = @_; |
142
|
|
|
|
|
|
|
return [ |
143
|
2
|
|
|
|
|
18
|
$name, |
144
|
|
|
|
|
|
|
{ |
145
|
|
|
|
|
|
|
'xsi:type' => 'xsd:hex', %$attr |
146
|
|
|
|
|
|
|
}, |
147
|
|
|
|
|
|
|
join '', map { |
148
|
1
|
|
|
|
|
6
|
uc sprintf "%02x", ord |
149
|
|
|
|
|
|
|
} split '', $value |
150
|
|
|
|
|
|
|
]; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub as_long { |
154
|
4
|
|
|
4
|
|
875
|
my($self, $value, $name, $type, $attr) = @_; |
155
|
|
|
|
|
|
|
return [ |
156
|
4
|
|
|
|
|
22
|
$name, |
157
|
|
|
|
|
|
|
{'xsi:type' => 'xsd:long', %$attr}, |
158
|
|
|
|
|
|
|
$value |
159
|
|
|
|
|
|
|
]; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub as_dateTime { |
163
|
1
|
|
|
1
|
|
36
|
my ($self, $value, $name, $type, $attr) = @_; |
164
|
1
|
|
|
|
|
6
|
return [$name, {'xsi:type' => 'xsd:dateTime', %$attr}, $value]; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub as_string { |
168
|
10
|
|
|
10
|
|
1247
|
my ($self, $value, $name, $type, $attr) = @_; |
169
|
10
|
100
|
|
|
|
30
|
die "String value expected instead of @{[ref $value]} reference\n" |
|
1
|
|
|
|
|
10
|
|
170
|
|
|
|
|
|
|
if ref $value; |
171
|
|
|
|
|
|
|
return [ |
172
|
9
|
|
|
|
|
36
|
$name, |
173
|
|
|
|
|
|
|
{'xsi:type' => 'xsd:string', %$attr}, |
174
|
|
|
|
|
|
|
SOAP::Utils::encode_data($value) |
175
|
|
|
|
|
|
|
]; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
sub as_anyURI { |
179
|
5
|
|
|
5
|
|
2256
|
my($self, $value, $name, $type, $attr) = @_; |
180
|
5
|
100
|
|
|
|
21
|
die "String value expected instead of @{[ref $value]} reference\n" if ref $value; |
|
1
|
|
|
|
|
8
|
|
181
|
|
|
|
|
|
|
return [ |
182
|
4
|
|
|
|
|
24
|
$name, |
183
|
|
|
|
|
|
|
{'xsi:type' => 'xsd:anyURI', %$attr}, |
184
|
|
|
|
|
|
|
SOAP::Utils::encode_data($value) |
185
|
|
|
|
|
|
|
]; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
2
|
100
|
|
2
|
|
81
|
sub as_undef { $_[1] ? '1' : '0' } |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub as_boolean { |
191
|
2
|
|
|
2
|
|
119
|
my $self = shift; |
192
|
2
|
|
|
|
|
7
|
my($value, $name, $type, $attr) = @_; |
193
|
|
|
|
|
|
|
# fix [ 1.05279 ] Boolean serialization error |
194
|
|
|
|
|
|
|
return [ |
195
|
2
|
100
|
66
|
|
|
25
|
$name, |
196
|
|
|
|
|
|
|
{'xsi:type' => 'xsd:boolean', %$attr}, |
197
|
|
|
|
|
|
|
( $value && $value ne 'false' ) ? 'true' : 'false' |
198
|
|
|
|
|
|
|
]; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub as_float { |
202
|
2
|
|
|
2
|
|
772
|
my($self, $value, $name, $type, $attr) = @_; |
203
|
|
|
|
|
|
|
return [ |
204
|
2
|
|
|
|
|
12
|
$name, |
205
|
|
|
|
|
|
|
{'xsi:type' => 'xsd:float', %$attr}, |
206
|
|
|
|
|
|
|
$value |
207
|
|
|
|
|
|
|
]; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# ---------------------------------------------------------------------- |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
package SOAP::XMLSchema2001::Serializer; |
213
|
|
|
|
|
|
|
|
214
|
25
|
|
|
25
|
|
203
|
use vars qw(@EXPORT); |
|
25
|
|
|
|
|
61
|
|
|
25
|
|
|
|
|
3728
|
|
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
# no more warnings about "used only once" |
217
|
|
|
|
|
|
|
*AUTOLOAD if 0; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
*AUTOLOAD = \&SOAP::XMLSchema1999::Serializer::AUTOLOAD; |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
BEGIN { |
222
|
25
|
|
|
25
|
|
212
|
@EXPORT = qw(anyType anySimpleType float double decimal dateTime |
223
|
|
|
|
|
|
|
timePeriod gMonth gYearMonth gYear century |
224
|
|
|
|
|
|
|
gMonthDay gDay duration recurringDuration anyURI |
225
|
|
|
|
|
|
|
language integer nonPositiveInteger negativeInteger |
226
|
|
|
|
|
|
|
long int short byte nonNegativeInteger unsignedLong |
227
|
|
|
|
|
|
|
unsignedInt unsignedShort unsignedByte positiveInteger |
228
|
|
|
|
|
|
|
date time string hex base64 boolean |
229
|
|
|
|
|
|
|
QName |
230
|
|
|
|
|
|
|
); |
231
|
|
|
|
|
|
|
# Add QName to @EXPORT |
232
|
|
|
|
|
|
|
# predeclare subs, so ->can check will be positive |
233
|
25
|
|
|
|
|
77
|
foreach (@EXPORT) { eval "sub as_$_" } |
|
925
|
|
|
|
|
69337
|
|
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
47
|
|
|
47
|
|
223
|
sub nilValue { 'nil' } |
237
|
|
|
|
|
|
|
|
238
|
0
|
|
|
0
|
|
0
|
sub anyTypeValue { 'anyType' } |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub as_long; *as_long = \&SOAP::XMLSchema1999::Serializer::as_long; |
241
|
|
|
|
|
|
|
sub as_float; *as_float = \&SOAP::XMLSchema1999::Serializer::as_float; |
242
|
|
|
|
|
|
|
sub as_string; *as_string = \&SOAP::XMLSchema1999::Serializer::as_string; |
243
|
|
|
|
|
|
|
sub as_anyURI; *as_anyURI = \&SOAP::XMLSchema1999::Serializer::as_anyURI; |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# TODO - QNames still don't work for 2001 schema! |
246
|
|
|
|
|
|
|
sub as_QName; *as_QName = \&SOAP::XMLSchema1999::Serializer::as_string; |
247
|
|
|
|
|
|
|
sub as_hex; *as_hex = \&as_hexBinary; |
248
|
|
|
|
|
|
|
sub as_base64; *as_base64 = \&as_base64Binary; |
249
|
|
|
|
|
|
|
sub as_timeInstant; *as_timeInstant = \&as_dateTime; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
# only 0 and 1 allowed - that's easy... |
252
|
|
|
|
|
|
|
sub as_undef { |
253
|
22
|
50
|
|
22
|
|
217
|
$_[1] |
254
|
|
|
|
|
|
|
? 'true' |
255
|
|
|
|
|
|
|
: 'false' |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
sub as_hexBinary { |
259
|
0
|
|
|
0
|
|
0
|
my ($self, $value, $name, $type, $attr) = @_; |
260
|
|
|
|
|
|
|
return [ |
261
|
0
|
|
|
|
|
0
|
$name, |
262
|
|
|
|
|
|
|
{'xsi:type' => 'xsd:hexBinary', %$attr}, |
263
|
|
|
|
|
|
|
join '', map { |
264
|
0
|
|
|
|
|
0
|
uc sprintf "%02x", ord |
265
|
|
|
|
|
|
|
} split '', $value |
266
|
|
|
|
|
|
|
]; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
sub as_base64Binary { |
270
|
1
|
|
|
1
|
|
11
|
my ($self, $value, $name, $type, $attr) = @_; |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# Fixes #30271 for 5.8 and above. |
273
|
|
|
|
|
|
|
# Won't fix for 5.6 and below - perl can't handle unicode before |
274
|
|
|
|
|
|
|
# 5.8, and applying pack() to everything is just a slowdown. |
275
|
1
|
50
|
|
|
|
100
|
if (eval "require Encode; 1") { |
276
|
1
|
50
|
|
|
|
5
|
if (Encode::is_utf8($value)) { |
277
|
0
|
0
|
|
|
|
0
|
if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions. |
278
|
0
|
|
|
|
|
0
|
Encode::_utf8_off($value); |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
else { |
281
|
0
|
|
|
|
|
0
|
$value = pack('C*',unpack('C*',$value)); # the slow but safe way, |
282
|
|
|
|
|
|
|
# but this fallback works always. |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
1
|
|
|
|
|
6
|
require MIME::Base64; |
288
|
|
|
|
|
|
|
return [ |
289
|
1
|
|
|
|
|
7
|
$name, |
290
|
|
|
|
|
|
|
{ |
291
|
|
|
|
|
|
|
'xsi:type' => 'xsd:base64Binary', %$attr |
292
|
|
|
|
|
|
|
}, |
293
|
|
|
|
|
|
|
MIME::Base64::encode_base64($value,'') |
294
|
|
|
|
|
|
|
]; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
sub as_boolean { |
298
|
2
|
|
|
2
|
|
6
|
my ($self, $value, $name, $type, $attr) = @_; |
299
|
|
|
|
|
|
|
# fix [ 1.05279 ] Boolean serialization error |
300
|
|
|
|
|
|
|
return [ |
301
|
2
|
100
|
66
|
|
|
31
|
$name, |
302
|
|
|
|
|
|
|
{ |
303
|
|
|
|
|
|
|
'xsi:type' => 'xsd:boolean', %$attr |
304
|
|
|
|
|
|
|
}, |
305
|
|
|
|
|
|
|
( $value && ($value ne 'false') ) |
306
|
|
|
|
|
|
|
? 'true' |
307
|
|
|
|
|
|
|
: 'false' |
308
|
|
|
|
|
|
|
]; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
# ====================================================================== |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
package SOAP::Utils; |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
sub qualify { |
317
|
177
|
50
|
33
|
177
|
|
1665
|
$_[1] |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
318
|
|
|
|
|
|
|
? $_[1] =~ /:/ |
319
|
|
|
|
|
|
|
? $_[1] |
320
|
|
|
|
|
|
|
: join(':', $_[0] || (), $_[1]) |
321
|
|
|
|
|
|
|
: defined $_[1] |
322
|
|
|
|
|
|
|
? $_[0] |
323
|
|
|
|
|
|
|
: '' |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
sub overqualify (&$) { |
327
|
0
|
|
|
0
|
|
0
|
for ($_[1]) { |
328
|
0
|
|
|
|
|
0
|
&{$_[0]}; |
|
0
|
|
|
|
|
0
|
|
329
|
0
|
|
|
|
|
0
|
s/^:|:$//g |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub disqualify { |
334
|
106
|
|
|
106
|
|
1870
|
(my $qname = shift) =~ s/^($SOAP::Constants::NSMASK?)://; |
335
|
106
|
|
|
|
|
1173
|
return $qname; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub splitqname { |
339
|
84
|
|
|
84
|
|
238
|
local($1,$2); |
340
|
84
|
|
|
|
|
369
|
$_[0] =~ /^(?:([^:]+):)?(.+)$/; |
341
|
84
|
|
|
|
|
369
|
return ($1,$2) |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
sub longname { |
345
|
0
|
0
|
|
0
|
|
0
|
defined $_[0] |
346
|
|
|
|
|
|
|
? sprintf('{%s}%s', $_[0], $_[1]) |
347
|
|
|
|
|
|
|
: $_[1] |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
sub splitlongname { |
351
|
71
|
|
|
71
|
|
210
|
local($1,$2); |
352
|
71
|
|
|
|
|
293
|
$_[0] =~ /^(?:\{(.*)\})?(.+)$/; |
353
|
71
|
|
|
|
|
310
|
return ($1,$2) |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# Q: why only '&' and '<' are encoded, but not '>'? |
357
|
|
|
|
|
|
|
# A: because it is not required according to XML spec. |
358
|
|
|
|
|
|
|
# |
359
|
|
|
|
|
|
|
# [http://www.w3.org/TR/REC-xml#syntax] |
360
|
|
|
|
|
|
|
# The ampersand character (&) and the left angle bracket (<) may appear in |
361
|
|
|
|
|
|
|
# their literal form only when used as markup delimiters, or within a comment, |
362
|
|
|
|
|
|
|
# a processing instruction, or a CDATA section. If they are needed elsewhere, |
363
|
|
|
|
|
|
|
# they must be escaped using either numeric character references or the |
364
|
|
|
|
|
|
|
# strings "&" and "<" respectively. The right angle bracket (>) may be |
365
|
|
|
|
|
|
|
# represented using the string ">", and must, for compatibility, be |
366
|
|
|
|
|
|
|
# escaped using ">" or a character reference when it appears in the |
367
|
|
|
|
|
|
|
# string "]]>" in content, when that string is not marking the end of a |
368
|
|
|
|
|
|
|
# CDATA section. |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
my %encode_attribute = ('&' => '&', '>' => '>', '<' => '<', '"' => '"'); |
371
|
149
|
|
|
149
|
|
292
|
sub encode_attribute { (my $e = $_[0]) =~ s/([&<>\"])/$encode_attribute{$1}/g; $e } |
|
149
|
|
|
|
|
608
|
|
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
my %encode_data = ('&' => '&', '>' => '>', '<' => '<', "\xd" => '
'); |
374
|
|
|
|
|
|
|
sub encode_data { |
375
|
27
|
|
|
27
|
|
54
|
my $e = $_[0]; |
376
|
27
|
100
|
|
|
|
91
|
if ($e) { |
377
|
11
|
|
|
|
|
19
|
$e =~ s/([&<>\015])/$encode_data{$1}/g; |
378
|
11
|
|
|
|
|
19
|
$e =~ s/\]\]>/\]\]>/g; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
$e |
381
|
27
|
|
|
|
|
171
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# methods for internal tree (SOAP::Deserializer, SOAP::SOM and SOAP::Serializer) |
384
|
|
|
|
|
|
|
|
385
|
0
|
|
|
0
|
|
0
|
sub o_qname { $_[0]->[0] } |
386
|
0
|
|
|
0
|
|
0
|
sub o_attr { $_[0]->[1] } |
387
|
0
|
0
|
|
0
|
|
0
|
sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef } |
388
|
0
|
0
|
|
0
|
|
0
|
sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] } |
389
|
|
|
|
|
|
|
# $_[0]->[3] is not used. Serializer stores object ID there |
390
|
0
|
|
|
0
|
|
0
|
sub o_value { $_[0]->[4] } |
391
|
0
|
|
|
0
|
|
0
|
sub o_lname { $_[0]->[5] } |
392
|
0
|
|
|
0
|
|
0
|
sub o_lattr { $_[0]->[6] } |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
sub format_datetime { |
395
|
0
|
|
|
0
|
|
0
|
my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5]; |
396
|
0
|
|
|
|
|
0
|
my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s); |
397
|
0
|
|
|
|
|
0
|
return $time; |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# make bytelength that calculates length in bytes regardless of utf/byte settings |
401
|
|
|
|
|
|
|
# either we can do 'use bytes' or length will count bytes already |
402
|
|
|
|
|
|
|
BEGIN { |
403
|
|
|
|
|
|
|
sub bytelength; |
404
|
|
|
|
|
|
|
*bytelength = eval('use bytes; 1') # 5.6.0 and later? |
405
|
25
|
50
|
|
25
|
|
48596
|
? sub { use bytes; length(@_ ? $_[0] : $_) } |
|
25
|
|
|
11
|
|
374
|
|
|
25
|
|
|
|
|
142
|
|
|
11
|
|
|
|
|
74
|
|
406
|
25
|
0
|
|
25
|
|
3621
|
: sub { length(@_ ? $_[0] : $_) }; |
|
0
|
50
|
|
25
|
|
0
|
|
|
25
|
|
|
|
|
219
|
|
|
25
|
|
|
|
|
8835
|
|
|
25
|
|
|
|
|
143
|
|
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# ====================================================================== |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
package SOAP::Cloneable; |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
sub clone { |
414
|
24
|
|
|
24
|
|
46
|
my $self = shift; |
415
|
|
|
|
|
|
|
|
416
|
24
|
50
|
33
|
|
|
298
|
return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__); |
417
|
|
|
|
|
|
|
|
418
|
24
|
|
33
|
|
|
251
|
my $clone = bless {} => ref($self) || $self; |
419
|
24
|
|
|
|
|
289
|
for (keys %$self) { |
420
|
199
|
|
|
|
|
303
|
my $value = $self->{$_}; |
421
|
199
|
100
|
100
|
|
|
1375
|
$clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value; |
422
|
|
|
|
|
|
|
} |
423
|
24
|
|
|
|
|
88
|
return $clone; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
# ====================================================================== |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
package SOAP::Transport; |
429
|
|
|
|
|
|
|
|
430
|
25
|
|
|
25
|
|
144
|
use vars qw($AUTOLOAD @ISA); |
|
25
|
|
|
|
|
377
|
|
|
25
|
|
|
|
|
2111
|
|
431
|
|
|
|
|
|
|
@ISA = qw(SOAP::Cloneable); |
432
|
|
|
|
|
|
|
|
433
|
25
|
|
|
25
|
|
56939
|
use Class::Inspector; |
|
25
|
|
|
|
|
132300
|
|
|
25
|
|
|
|
|
8965
|
|
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
|
436
|
15
|
|
|
15
|
|
57
|
sub DESTROY { SOAP::Trace::objects('()') } |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub new { |
439
|
15
|
|
|
15
|
|
37
|
my $self = shift; |
440
|
15
|
50
|
|
|
|
60
|
return $self if ref $self; |
441
|
15
|
|
33
|
|
|
113
|
my $class = ref($self) || $self; |
442
|
|
|
|
|
|
|
|
443
|
15
|
|
|
|
|
74
|
SOAP::Trace::objects('()'); |
444
|
15
|
|
|
|
|
148
|
return bless {} => $class; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub proxy { |
448
|
84
|
|
|
84
|
|
158
|
my $self = shift; |
449
|
84
|
50
|
|
|
|
258
|
$self = $self->new() if not ref $self; |
450
|
|
|
|
|
|
|
|
451
|
84
|
|
|
|
|
144
|
my $class = ref $self; |
452
|
|
|
|
|
|
|
|
453
|
84
|
100
|
|
|
|
951
|
return $self->{_proxy} unless @_; |
454
|
|
|
|
|
|
|
|
455
|
13
|
50
|
|
|
|
204
|
$_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n"; |
456
|
13
|
|
|
|
|
68
|
my $protocol = uc "$1"; # untainted now |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# HTTPS is handled by HTTP class |
459
|
13
|
|
|
|
|
43
|
$protocol =~s/^HTTPS$/HTTP/; |
460
|
|
|
|
|
|
|
|
461
|
13
|
|
|
|
|
68
|
(my $protocol_class = "${class}::$protocol") =~ s/-/_/g; |
462
|
|
|
|
|
|
|
|
463
|
25
|
|
|
25
|
|
227
|
no strict 'refs'; |
|
25
|
|
|
|
|
2946
|
|
|
25
|
|
|
|
|
6213
|
|
464
|
13
|
50
|
33
|
|
|
153
|
unless (Class::Inspector->loaded("$protocol_class\::Client") |
465
|
|
|
|
|
|
|
&& UNIVERSAL::can("$protocol_class\::Client" => 'new') |
466
|
|
|
|
|
|
|
) { |
467
|
13
|
|
|
|
|
2109
|
eval "require $protocol_class"; |
468
|
13
|
50
|
|
|
|
104
|
die "Unsupported protocol '$protocol'\n" |
469
|
|
|
|
|
|
|
if $@ =~ m!^Can\'t locate SOAP/Transport/!; |
470
|
13
|
50
|
|
|
|
66
|
die if $@; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
13
|
|
|
|
|
58
|
$protocol_class .= "::Client"; |
474
|
13
|
|
|
|
|
122
|
return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_); |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
sub AUTOLOAD { |
478
|
46
|
|
|
46
|
|
215
|
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); |
479
|
46
|
50
|
|
|
|
151
|
return if $method eq 'DESTROY'; |
480
|
|
|
|
|
|
|
|
481
|
25
|
|
|
25
|
|
182
|
no strict 'refs'; |
|
25
|
|
|
|
|
50
|
|
|
25
|
|
|
|
|
2394
|
|
482
|
46
|
|
|
47
|
|
384
|
*$AUTOLOAD = sub { shift->proxy->$method(@_) }; |
|
47
|
|
|
|
|
177
|
|
483
|
46
|
|
|
|
|
229
|
goto &$AUTOLOAD; |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
# ====================================================================== |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
package SOAP::Fault; |
489
|
|
|
|
|
|
|
|
490
|
25
|
|
|
25
|
|
180
|
use Carp (); |
|
25
|
|
|
|
|
60
|
|
|
25
|
|
|
|
|
735
|
|
491
|
|
|
|
|
|
|
|
492
|
25
|
|
|
25
|
|
48766
|
use overload fallback => 1, '""' => "stringify"; |
|
25
|
|
|
|
|
29613
|
|
|
25
|
|
|
|
|
166
|
|
493
|
|
|
|
|
|
|
|
494
|
0
|
|
|
0
|
|
0
|
sub DESTROY { SOAP::Trace::objects('()') } |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
sub new { |
497
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
498
|
|
|
|
|
|
|
|
499
|
0
|
0
|
|
|
|
0
|
unless (ref $self) { |
500
|
0
|
|
|
|
|
0
|
my $class = $self; |
501
|
0
|
|
|
|
|
0
|
$self = bless {} => $class; |
502
|
0
|
|
|
|
|
0
|
SOAP::Trace::objects('()'); |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
|
505
|
0
|
0
|
0
|
|
|
0
|
Carp::carp "Odd (wrong?) number of parameters in new()" |
506
|
|
|
|
|
|
|
if $^W && (@_ & 1); |
507
|
|
|
|
|
|
|
|
508
|
25
|
|
|
25
|
|
4335
|
no strict qw(refs); |
|
25
|
|
|
|
|
50
|
|
|
25
|
|
|
|
|
3494
|
|
509
|
0
|
|
|
|
|
0
|
while (@_) { |
510
|
0
|
|
|
|
|
0
|
my $method = shift; |
511
|
0
|
0
|
|
|
|
0
|
$self->$method(shift) |
512
|
|
|
|
|
|
|
if $self->can($method) |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
0
|
|
|
|
|
0
|
return $self; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
sub stringify { |
519
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
520
|
0
|
|
|
|
|
0
|
return join ': ', $self->faultcode, $self->faultstring; |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
sub BEGIN { |
524
|
25
|
|
|
25
|
|
139
|
no strict 'refs'; |
|
25
|
|
|
|
|
57
|
|
|
25
|
|
|
|
|
3615
|
|
525
|
25
|
|
|
25
|
|
75
|
for my $method (qw(faultcode faultstring faultactor faultdetail)) { |
526
|
100
|
|
|
|
|
232
|
my $field = '_' . $method; |
527
|
|
|
|
|
|
|
*$method = sub { |
528
|
0
|
0
|
|
0
|
|
0
|
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) |
529
|
|
|
|
|
|
|
? shift->new |
530
|
|
|
|
|
|
|
: __PACKAGE__->new; |
531
|
0
|
0
|
|
|
|
0
|
if (@_) { |
532
|
0
|
|
|
|
|
0
|
$self->{$field} = shift; |
533
|
0
|
|
|
|
|
0
|
return $self |
534
|
|
|
|
|
|
|
} |
535
|
0
|
|
|
|
|
0
|
return $self->{$field}; |
536
|
|
|
|
|
|
|
} |
537
|
100
|
|
|
|
|
670
|
} |
538
|
25
|
|
|
|
|
953
|
*detail = \&faultdetail; |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# ====================================================================== |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
package SOAP::Data; |
544
|
|
|
|
|
|
|
|
545
|
25
|
|
|
25
|
|
154
|
use vars qw(@ISA @EXPORT_OK); |
|
25
|
|
|
|
|
45
|
|
|
25
|
|
|
|
|
1733
|
|
546
|
25
|
|
|
25
|
|
142
|
use Exporter; |
|
25
|
|
|
|
|
48
|
|
|
25
|
|
|
|
|
1253
|
|
547
|
25
|
|
|
25
|
|
175
|
use Carp (); |
|
25
|
|
|
|
|
197
|
|
|
25
|
|
|
|
|
468
|
|
548
|
25
|
|
|
25
|
|
18164
|
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2; |
|
25
|
|
|
|
|
434
|
|
|
25
|
|
|
|
|
3151
|
|
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
551
|
|
|
|
|
|
|
@EXPORT_OK = qw(name type attr value uri); |
552
|
|
|
|
|
|
|
|
553
|
100
|
|
|
100
|
|
541
|
sub DESTROY { SOAP::Trace::objects('()') } |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
sub new { |
556
|
206
|
|
|
206
|
|
2319
|
my $self = shift; |
557
|
|
|
|
|
|
|
|
558
|
206
|
100
|
|
|
|
617
|
unless (ref $self) { |
559
|
100
|
|
|
|
|
127
|
my $class = $self; |
560
|
100
|
|
|
|
|
663
|
$self = bless {_attr => {}, _value => [], _signature => []} => $class; |
561
|
100
|
|
|
|
|
240
|
SOAP::Trace::objects('()'); |
562
|
|
|
|
|
|
|
} |
563
|
25
|
|
|
25
|
|
215
|
no strict qw(refs); |
|
25
|
|
|
|
|
41
|
|
|
25
|
|
|
|
|
17408
|
|
564
|
206
|
50
|
33
|
|
|
1132
|
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); |
565
|
206
|
|
|
|
|
538
|
while (@_) { |
566
|
0
|
|
|
|
|
0
|
my $method = shift; |
567
|
0
|
0
|
|
|
|
0
|
$self->$method(shift) if $self->can($method) |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
206
|
|
|
|
|
528
|
return $self; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
sub name { |
574
|
297
|
50
|
|
297
|
|
954
|
my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new; |
|
|
100
|
|
|
|
|
|
575
|
297
|
100
|
|
|
|
666
|
if (@_) { |
576
|
99
|
|
|
|
|
140
|
my $name = shift; |
577
|
99
|
|
|
|
|
119
|
my ($uri, $prefix); # predeclare, because can't declare in assign |
578
|
99
|
100
|
|
|
|
225
|
if ($name) { |
579
|
71
|
|
|
|
|
162
|
($uri, $name) = SOAP::Utils::splitlongname($name); |
580
|
71
|
50
|
|
|
|
200
|
unless (defined $uri) { |
581
|
71
|
|
|
|
|
153
|
($prefix, $name) = SOAP::Utils::splitqname($name); |
582
|
71
|
100
|
|
|
|
282
|
$self->prefix($prefix) if defined $prefix; |
583
|
|
|
|
|
|
|
} else { |
584
|
0
|
|
|
|
|
0
|
$self->uri($uri); |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
} |
587
|
99
|
|
|
|
|
288
|
$self->{_name} = $name; |
588
|
|
|
|
|
|
|
|
589
|
99
|
100
|
|
|
|
320
|
$self->value(@_) if @_; |
590
|
99
|
|
|
|
|
476
|
return $self; |
591
|
|
|
|
|
|
|
} |
592
|
198
|
|
|
|
|
586
|
return $self->{_name}; |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
sub attr { |
596
|
132
|
0
|
|
132
|
|
430
|
my $self = ref $_[0] |
|
|
50
|
|
|
|
|
|
597
|
|
|
|
|
|
|
? shift |
598
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[0] => __PACKAGE__) |
599
|
|
|
|
|
|
|
? shift->new() |
600
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
601
|
132
|
100
|
|
|
|
292
|
if (@_) { |
602
|
32
|
|
|
|
|
68
|
$self->{_attr} = shift; |
603
|
32
|
50
|
|
|
|
123
|
return $self->value(@_) if @_; |
604
|
32
|
|
|
|
|
287
|
return $self |
605
|
|
|
|
|
|
|
} |
606
|
100
|
|
|
|
|
549
|
return $self->{_attr}; |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
sub type { |
610
|
311
|
0
|
|
311
|
|
630
|
my $self = ref $_[0] |
|
|
50
|
|
|
|
|
|
611
|
|
|
|
|
|
|
? shift |
612
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[0] => __PACKAGE__) |
613
|
|
|
|
|
|
|
? shift->new() |
614
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
615
|
311
|
100
|
|
|
|
609
|
if (@_) { |
616
|
5
|
|
|
|
|
12
|
$self->{_type} = shift; |
617
|
5
|
50
|
|
|
|
12
|
$self->value(@_) if @_; |
618
|
5
|
|
|
|
|
30
|
return $self; |
619
|
|
|
|
|
|
|
} |
620
|
306
|
50
|
66
|
|
|
959
|
if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) { |
|
102
|
|
|
|
|
2033
|
|
|
296
|
|
|
|
|
1398
|
|
621
|
0
|
|
|
|
|
0
|
$self->{_type} = (SOAP::Utils::splitlongname(delete $self->{_attr}->{shift(@types)}))[1]; |
622
|
|
|
|
|
|
|
} |
623
|
306
|
|
|
|
|
1659
|
return $self->{_type}; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
BEGIN { |
627
|
25
|
|
|
25
|
|
149
|
no strict 'refs'; |
|
25
|
|
|
|
|
41
|
|
|
25
|
|
|
|
|
11461
|
|
628
|
25
|
|
|
25
|
|
75
|
for my $method (qw(root mustUnderstand)) { |
629
|
50
|
|
|
|
|
119
|
my $field = '_' . $method; |
630
|
|
|
|
|
|
|
*$method = sub { |
631
|
2
|
100
|
|
2
|
|
333
|
my $attr = $method eq 'root' |
632
|
|
|
|
|
|
|
? "{$SOAP::Constants::NS_ENC}$method" |
633
|
|
|
|
|
|
|
: "{$SOAP::Constants::NS_ENV}$method"; |
634
|
2
|
50
|
|
|
|
16
|
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) |
635
|
|
|
|
|
|
|
? shift->new |
636
|
|
|
|
|
|
|
: __PACKAGE__->new; |
637
|
2
|
50
|
|
|
|
6
|
if (@_) { |
638
|
2
|
50
|
|
|
|
18
|
$self->{_attr}->{$attr} = $self->{$field} = shift() ? 1 : 0; |
639
|
2
|
100
|
|
|
|
10
|
$self->value(@_) if @_; |
640
|
2
|
|
|
|
|
12
|
return $self; |
641
|
|
|
|
|
|
|
} |
642
|
0
|
0
|
0
|
|
|
0
|
$self->{$field} = SOAP::Lite::Deserializer::XMLSchemaSOAP1_2->as_boolean($self->{_attr}->{$attr}) |
643
|
|
|
|
|
|
|
if !defined $self->{$field} && defined $self->{_attr}->{$attr}; |
644
|
0
|
|
|
|
|
0
|
return $self->{$field}; |
645
|
|
|
|
|
|
|
} |
646
|
50
|
|
|
|
|
469
|
} |
647
|
|
|
|
|
|
|
|
648
|
25
|
|
|
|
|
60
|
for my $method (qw(actor encodingStyle)) { |
649
|
50
|
|
|
|
|
527
|
my $field = '_' . $method; |
650
|
|
|
|
|
|
|
*$method = sub { |
651
|
0
|
|
|
0
|
|
0
|
my $attr = "{$SOAP::Constants::NS_ENV}$method"; |
652
|
0
|
0
|
|
|
|
0
|
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) |
653
|
|
|
|
|
|
|
? shift->new() |
654
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
655
|
0
|
0
|
|
|
|
0
|
if (@_) { |
656
|
0
|
|
|
|
|
0
|
$self->{_attr}->{$attr} = $self->{$field} = shift; |
657
|
0
|
0
|
|
|
|
0
|
$self->value(@_) if @_; |
658
|
0
|
|
|
|
|
0
|
return $self; |
659
|
|
|
|
|
|
|
} |
660
|
0
|
0
|
0
|
|
|
0
|
$self->{$field} = $self->{_attr}->{$attr} |
661
|
|
|
|
|
|
|
if !defined $self->{$field} && defined $self->{_attr}->{$attr}; |
662
|
0
|
|
|
|
|
0
|
return $self->{$field}; |
663
|
|
|
|
|
|
|
} |
664
|
50
|
|
|
|
|
13611
|
} |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
sub prefix { |
668
|
142
|
0
|
|
142
|
|
307
|
my $self = ref $_[0] |
|
|
50
|
|
|
|
|
|
669
|
|
|
|
|
|
|
? shift |
670
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[0] => __PACKAGE__) |
671
|
|
|
|
|
|
|
? shift->new() |
672
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
673
|
142
|
100
|
|
|
|
589
|
return $self->{_prefix} unless @_; |
674
|
43
|
|
|
|
|
125
|
$self->{_prefix} = shift; |
675
|
43
|
50
|
|
|
|
131
|
if (scalar @_) { |
676
|
0
|
|
|
|
|
0
|
return $self->value(@_); |
677
|
|
|
|
|
|
|
} |
678
|
43
|
|
|
|
|
87
|
return $self; |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
sub uri { |
682
|
99
|
0
|
|
99
|
|
235
|
my $self = ref $_[0] |
|
|
50
|
|
|
|
|
|
683
|
|
|
|
|
|
|
? shift |
684
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[0] => __PACKAGE__) |
685
|
|
|
|
|
|
|
? shift->new() |
686
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
687
|
99
|
50
|
|
|
|
390
|
return $self->{_uri} unless @_; |
688
|
0
|
|
|
|
|
0
|
my $uri = $self->{_uri} = shift; |
689
|
0
|
0
|
0
|
|
|
0
|
warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n" |
|
|
|
0
|
|
|
|
|
690
|
|
|
|
|
|
|
if defined $uri && $^W && $uri =~ /::/; |
691
|
0
|
0
|
|
|
|
0
|
if (scalar @_) { |
692
|
0
|
|
|
|
|
0
|
return $self->value(@_); |
693
|
|
|
|
|
|
|
} |
694
|
0
|
|
|
|
|
0
|
return $self; |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
sub set_value { |
698
|
99
|
50
|
|
99
|
|
309
|
my $self = ref $_[0] |
|
|
100
|
|
|
|
|
|
699
|
|
|
|
|
|
|
? shift |
700
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[0] => __PACKAGE__) |
701
|
|
|
|
|
|
|
? shift->new() |
702
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
703
|
99
|
|
|
|
|
276
|
$self->{_value} = [@_]; |
704
|
99
|
|
|
|
|
256
|
return $self; |
705
|
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
sub value { |
708
|
174
|
50
|
|
174
|
|
1134
|
my $self = ref $_[0] ? shift |
|
|
100
|
|
|
|
|
|
709
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[0] => __PACKAGE__) |
710
|
|
|
|
|
|
|
? shift->new() |
711
|
|
|
|
|
|
|
: __PACKAGE__->new; |
712
|
174
|
100
|
|
|
|
348
|
if (@_) { |
713
|
74
|
|
|
|
|
186
|
return $self->set_value(@_); |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
else { |
716
|
|
|
|
|
|
|
return wantarray |
717
|
100
|
50
|
|
|
|
375
|
? @{$self->{_value}} |
|
100
|
|
|
|
|
345
|
|
718
|
|
|
|
|
|
|
: $self->{_value}->[0]; |
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
sub signature { |
723
|
105
|
50
|
|
105
|
|
2246
|
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) |
724
|
|
|
|
|
|
|
? shift->new() |
725
|
|
|
|
|
|
|
: __PACKAGE__->new(); |
726
|
105
|
100
|
|
|
|
4452
|
(@_) |
727
|
|
|
|
|
|
|
? ($self->{_signature} = shift, return $self) |
728
|
|
|
|
|
|
|
: (return $self->{_signature}); |
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
# ====================================================================== |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
package SOAP::Header; |
734
|
|
|
|
|
|
|
|
735
|
25
|
|
|
25
|
|
161
|
use vars qw(@ISA); |
|
25
|
|
|
|
|
43
|
|
|
25
|
|
|
|
|
1674
|
|
736
|
|
|
|
|
|
|
@ISA = qw(SOAP::Data); |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# ====================================================================== |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
package SOAP::Serializer; |
741
|
25
|
|
|
25
|
|
16515
|
use SOAP::Lite::Utils; |
|
25
|
|
|
|
|
63
|
|
|
25
|
|
|
|
|
148
|
|
742
|
25
|
|
|
25
|
|
134
|
use Carp (); |
|
25
|
|
|
|
|
109
|
|
|
25
|
|
|
|
|
457
|
|
743
|
25
|
|
|
25
|
|
118
|
use vars qw(@ISA); |
|
25
|
|
|
|
|
42
|
|
|
25
|
|
|
|
|
5585
|
|
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
@ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer); |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
BEGIN { |
748
|
|
|
|
|
|
|
# namespaces and anonymous data structures |
749
|
25
|
|
|
25
|
|
56
|
my $ns = 0; |
750
|
25
|
|
|
|
|
45
|
my $name = 0; |
751
|
25
|
|
|
|
|
4049
|
my $prefix = 'c-'; |
752
|
11
|
|
|
11
|
|
31
|
sub gen_ns { 'namesp' . ++$ns } |
753
|
41
|
|
|
41
|
|
255
|
sub gen_name { join '', $prefix, 'gensym', ++$name } |
754
|
0
|
|
|
0
|
|
0
|
sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; } |
|
0
|
|
|
|
|
0
|
|
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
sub BEGIN { |
758
|
25
|
|
|
25
|
|
263
|
no strict 'refs'; |
|
25
|
|
|
|
|
46
|
|
|
25
|
|
|
|
|
2215
|
|
759
|
|
|
|
|
|
|
|
760
|
25
|
|
|
25
|
|
211
|
__PACKAGE__->__mk_accessors(qw(readable level seen autotype attr maptype |
761
|
|
|
|
|
|
|
namespaces multirefinplace encoding signature on_nonserialized context |
762
|
|
|
|
|
|
|
ns_uri ns_prefix use_default_ns)); |
763
|
|
|
|
|
|
|
|
764
|
25
|
|
|
|
|
53
|
for my $method (qw(method fault freeform)) { # aliases for envelope |
765
|
6
|
|
|
6
|
|
25
|
*$method = sub { shift->envelope($method => @_) } |
766
|
75
|
|
|
|
|
38130
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
# Is this necessary? Seems like work for nothing when a user could just use |
769
|
|
|
|
|
|
|
# SOAP::Utils directly. |
770
|
|
|
|
|
|
|
# for my $method (qw(qualify overqualify disqualify)) { # import from SOAP::Utils |
771
|
|
|
|
|
|
|
# *$method = \&{'SOAP::Utils::'.$method}; |
772
|
|
|
|
|
|
|
# } |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
|
775
|
25
|
|
|
25
|
|
166
|
sub DESTROY { SOAP::Trace::objects('()') } |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
sub new { |
778
|
183
|
|
|
183
|
|
353
|
my $self = shift; |
779
|
183
|
100
|
|
|
|
572
|
return $self if ref $self; |
780
|
|
|
|
|
|
|
|
781
|
25
|
|
|
|
|
118
|
my $class = $self; |
782
|
0
|
0
|
|
0
|
|
0
|
$self = bless { |
783
|
|
|
|
|
|
|
_level => 0, |
784
|
|
|
|
|
|
|
_autotype => 1, |
785
|
|
|
|
|
|
|
_readable => 0, |
786
|
|
|
|
|
|
|
_ns_uri => '', |
787
|
|
|
|
|
|
|
_ns_prefix => '', |
788
|
|
|
|
|
|
|
_use_default_ns => 1, |
789
|
|
|
|
|
|
|
_multirefinplace => 0, |
790
|
|
|
|
|
|
|
_seen => {}, |
791
|
|
|
|
|
|
|
_encoding => 'UTF-8', |
792
|
|
|
|
|
|
|
_objectstack => {}, |
793
|
|
|
|
|
|
|
_signature => [], |
794
|
|
|
|
|
|
|
_maptype => {}, |
795
|
0
|
|
|
|
|
0
|
_on_nonserialized => sub {Carp::carp "Cannot marshall @{[ref shift]} reference" if $^W; return}, |
|
0
|
|
|
|
|
0
|
|
796
|
25
|
|
|
|
|
377
|
_encodingStyle => $SOAP::Constants::NS_ENC, |
797
|
|
|
|
|
|
|
_attr => { |
798
|
|
|
|
|
|
|
"{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC, |
799
|
|
|
|
|
|
|
}, |
800
|
|
|
|
|
|
|
_namespaces => {}, |
801
|
|
|
|
|
|
|
_soapversion => SOAP::Lite->soapversion, |
802
|
|
|
|
|
|
|
} => $class; |
803
|
28
|
|
|
28
|
|
128
|
$self->typelookup({ |
804
|
|
|
|
|
|
|
'base64Binary' => |
805
|
|
|
|
|
|
|
[10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/ }, 'as_base64Binary'], |
806
|
|
|
|
|
|
|
'zerostring' => |
807
|
28
|
100
|
100
|
27
|
|
96
|
[12, sub { $_[0] =~ /^0\d+$/ }, 'as_string'], |
|
27
|
|
|
|
|
397
|
|
808
|
|
|
|
|
|
|
# int (and actually long too) are subtle: the negative range is one greater... |
809
|
|
|
|
|
|
|
'int' => |
810
|
12
|
100
|
|
12
|
|
80
|
[20, sub {$_[0] =~ /^([+-]?\d+)$/ && ($1 <= 2147483647) && ($1 >= -2147483648); }, 'as_int'], |
811
|
|
|
|
|
|
|
'long' => |
812
|
10
|
|
|
10
|
|
49
|
[25, sub {$_[0] =~ /^([+-]?\d+)$/ && $1 <= 9223372036854775807;}, 'as_long'], |
813
|
|
|
|
|
|
|
'float' => |
814
|
|
|
|
|
|
|
[30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+|NaN|INF)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_float'], |
815
|
|
|
|
|
|
|
'gMonth' => |
816
|
10
|
|
|
10
|
|
25
|
[35, sub { $_[0] =~ /^--\d\d--(-\d\d:\d\d)?$/; }, 'as_gMonth'], |
817
|
|
|
|
|
|
|
'gDay' => |
818
|
10
|
|
|
10
|
|
26
|
[40, sub { $_[0] =~ /^---\d\d(-\d\d:\d\d)?$/; }, 'as_gDay'], |
819
|
|
|
|
|
|
|
'gYear' => |
820
|
10
|
|
|
10
|
|
29
|
[45, sub { $_[0] =~ /^-?\d\d\d\d(-\d\d:\d\d)?$/; }, 'as_gYear'], |
821
|
|
|
|
|
|
|
'gMonthDay' => |
822
|
10
|
|
|
10
|
|
27
|
[50, sub { $_[0] =~ /^-\d\d-\d\d(-\d\d:\d\d)?$/; }, 'as_gMonthDay'], |
823
|
|
|
|
|
|
|
'gYearMonth' => |
824
|
10
|
|
|
10
|
|
29
|
[55, sub { $_[0] =~ /^-?\d\d\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_gYearMonth'], |
825
|
|
|
|
|
|
|
'date' => |
826
|
10
|
|
|
10
|
|
24
|
[60, sub { $_[0] =~ /^-?\d\d\d\d-\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_date'], |
827
|
|
|
|
|
|
|
'time' => |
828
|
10
|
|
|
10
|
|
23
|
[70, sub { $_[0] =~ /^\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_time'], |
829
|
|
|
|
|
|
|
'dateTime' => |
830
|
10
|
|
|
10
|
|
23
|
[75, sub { $_[0] =~ /^\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_dateTime'], |
831
|
|
|
|
|
|
|
'duration' => |
832
|
10
|
100
|
|
10
|
|
71
|
[80, sub { $_[0] !~m{^-?PT?$} && $_[0] =~ m{^ |
833
|
|
|
|
|
|
|
-? # a optional - sign |
834
|
|
|
|
|
|
|
P |
835
|
|
|
|
|
|
|
(:? \d+Y )? |
836
|
|
|
|
|
|
|
(:? \d+M )? |
837
|
|
|
|
|
|
|
(:? \d+D )? |
838
|
|
|
|
|
|
|
(:? |
839
|
|
|
|
|
|
|
T(:?\d+H)? |
840
|
|
|
|
|
|
|
(:?\d+M)? |
841
|
|
|
|
|
|
|
(:?\d+S)? |
842
|
|
|
|
|
|
|
)? |
843
|
|
|
|
|
|
|
$ |
844
|
|
|
|
|
|
|
}x; |
845
|
|
|
|
|
|
|
}, 'as_duration'], |
846
|
|
|
|
|
|
|
'boolean' => |
847
|
9
|
|
|
9
|
|
50
|
[90, sub { $_[0] =~ /^(true|false)$/i; }, 'as_boolean'], |
848
|
|
|
|
|
|
|
'anyURI' => |
849
|
7
|
|
|
7
|
|
30
|
[95, sub { $_[0] =~ /^(urn:|http:\/\/)/i; }, 'as_anyURI'], |
|
6
|
|
|
|
|
43
|
|
850
|
|
|
|
|
|
|
'string' => |
851
|
25
|
|
|
|
|
1583
|
[100, sub {1}, 'as_string'], |
852
|
|
|
|
|
|
|
}); |
853
|
25
|
|
|
|
|
157
|
$self->register_ns($SOAP::Constants::NS_ENC,$SOAP::Constants::PREFIX_ENC); |
854
|
25
|
50
|
|
|
|
237
|
$self->register_ns($SOAP::Constants::NS_ENV,$SOAP::Constants::PREFIX_ENV) |
855
|
|
|
|
|
|
|
if $SOAP::Constants::PREFIX_ENV; |
856
|
25
|
|
|
|
|
113
|
$self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA); |
857
|
25
|
|
|
|
|
77
|
SOAP::Trace::objects('()'); |
858
|
|
|
|
|
|
|
|
859
|
25
|
|
|
25
|
|
177
|
no strict qw(refs); |
|
25
|
|
|
|
|
51
|
|
|
25
|
|
|
|
|
54159
|
|
860
|
25
|
50
|
66
|
|
|
143
|
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); |
861
|
25
|
0
|
|
|
|
108
|
while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
862
|
|
|
|
|
|
|
|
863
|
25
|
|
|
|
|
181
|
return $self; |
864
|
|
|
|
|
|
|
} |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
sub typelookup { |
867
|
25
|
|
|
25
|
|
70
|
my ($self, $lookup) = @_; |
868
|
25
|
50
|
|
|
|
209
|
if (defined $lookup) { |
869
|
25
|
|
|
|
|
255
|
$self->{ _typelookup } = $lookup; |
870
|
25
|
|
|
|
|
58
|
$self->{ _typelookup_order } = [ sort { $lookup->{$a}->[0] <=> $lookup->{$b}->[0] } keys %{ $lookup } ]; |
|
1262
|
|
|
|
|
2235
|
|
|
25
|
|
|
|
|
238
|
|
871
|
25
|
|
|
|
|
96
|
return $self; |
872
|
|
|
|
|
|
|
} |
873
|
0
|
|
|
|
|
0
|
return $self->{ _typelookup }; |
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
sub ns { |
877
|
3
|
|
|
3
|
|
279
|
my $self = shift; |
878
|
3
|
100
|
|
|
|
16
|
$self = $self->new() if not ref $self; |
879
|
3
|
50
|
|
|
|
10
|
if (@_) { |
880
|
3
|
|
|
|
|
6
|
my ($u,$p) = @_; |
881
|
3
|
|
|
|
|
5
|
my $prefix; |
882
|
|
|
|
|
|
|
|
883
|
3
|
100
|
33
|
|
|
17
|
if ($p) { |
|
|
50
|
|
|
|
|
|
884
|
1
|
|
|
|
|
3
|
$prefix = $p; |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
elsif (!$p && !($prefix = $self->find_prefix($u))) { |
887
|
2
|
|
|
|
|
6
|
$prefix = gen_ns; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
|
890
|
3
|
|
|
|
|
6
|
$self->{'_ns_uri'} = $u; |
891
|
3
|
|
|
|
|
5
|
$self->{'_ns_prefix'} = $prefix; |
892
|
3
|
|
|
|
|
7
|
$self->{'_use_default_ns'} = 0; |
893
|
|
|
|
|
|
|
# $self->register_ns($u,$prefix); |
894
|
3
|
|
|
|
|
6
|
$self->{'_namespaces'}->{$u} = $prefix; |
895
|
3
|
|
|
|
|
24
|
return $self; |
896
|
|
|
|
|
|
|
} |
897
|
0
|
|
|
|
|
0
|
return $self->{'_ns_uri'}; |
898
|
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
sub default_ns { |
901
|
14
|
|
|
14
|
|
32
|
my $self = shift; |
902
|
14
|
100
|
|
|
|
99
|
$self = $self->new() if not ref $self; |
903
|
14
|
50
|
|
|
|
59
|
if (@_) { |
904
|
14
|
|
|
|
|
33
|
my ($u) = @_; |
905
|
14
|
|
|
|
|
42
|
$self->{'_ns_uri'} = $u; |
906
|
14
|
|
|
|
|
36
|
$self->{'_ns_prefix'} = ''; |
907
|
14
|
|
|
|
|
32
|
$self->{'_use_default_ns'} = 1; |
908
|
14
|
|
|
|
|
41
|
return $self; |
909
|
|
|
|
|
|
|
} |
910
|
0
|
|
|
|
|
0
|
return $self->{'_ns_uri'}; |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
sub use_prefix { |
914
|
2
|
|
|
2
|
|
880
|
my $self = shift; |
915
|
2
|
50
|
|
|
|
15
|
$self = $self->new() if not ref $self; |
916
|
2
|
|
|
|
|
25
|
warn 'use_prefix has been deprecated. if you wish to turn off or on the ' |
917
|
|
|
|
|
|
|
. 'use of a default namespace, then please use either ns(uri) or default_ns(uri)'; |
918
|
2
|
50
|
|
|
|
14
|
if (@_) { |
919
|
2
|
|
|
|
|
5
|
my $use = shift; |
920
|
2
|
|
100
|
|
|
12
|
$self->{'_use_default_ns'} = !$use || 0; |
921
|
2
|
|
|
|
|
10
|
return $self; |
922
|
|
|
|
|
|
|
} else { |
923
|
0
|
|
|
|
|
0
|
return $self->{'_use_default_ns'}; |
924
|
|
|
|
|
|
|
} |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
sub uri { |
927
|
26
|
|
|
26
|
|
66
|
my $self = shift; |
928
|
26
|
50
|
|
|
|
98
|
$self = $self->new() if not ref $self; |
929
|
|
|
|
|
|
|
# warn 'uri has been deprecated. if you wish to set the namespace for the request, then please use either ns(uri) or default_ns(uri)'; |
930
|
26
|
100
|
|
|
|
96
|
if (@_) { |
931
|
14
|
|
|
|
|
33
|
my $ns = shift; |
932
|
14
|
100
|
|
|
|
69
|
if ($self->{_use_default_ns}) { |
933
|
13
|
|
|
|
|
66
|
$self->default_ns($ns); |
934
|
|
|
|
|
|
|
} |
935
|
|
|
|
|
|
|
else { |
936
|
1
|
|
|
|
|
5
|
$self->ns($ns); |
937
|
|
|
|
|
|
|
} |
938
|
|
|
|
|
|
|
# $self->{'_ns_uri'} = $ns; |
939
|
|
|
|
|
|
|
# $self->register_ns($self->{'_ns_uri'}) if (!$self->{_use_default_ns}); |
940
|
14
|
|
|
|
|
88
|
return $self; |
941
|
|
|
|
|
|
|
} |
942
|
12
|
|
|
|
|
54
|
return $self->{'_ns_uri'}; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
sub encodingStyle { |
946
|
1
|
|
|
1
|
|
3
|
my $self = shift; |
947
|
1
|
50
|
|
|
|
5
|
$self = $self->new() if not ref $self; |
948
|
1
|
50
|
|
|
|
25
|
return $self->{'_encodingStyle'} unless @_; |
949
|
|
|
|
|
|
|
|
950
|
0
|
|
|
|
|
0
|
my $cur_style = $self->{'_encodingStyle'}; |
951
|
0
|
|
|
|
|
0
|
delete($self->{'_namespaces'}->{$cur_style}); |
952
|
|
|
|
|
|
|
|
953
|
0
|
|
|
|
|
0
|
my $new_style = shift; |
954
|
0
|
0
|
|
|
|
0
|
if ($new_style eq "") { |
955
|
0
|
|
|
|
|
0
|
delete($self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"}); |
956
|
|
|
|
|
|
|
} |
957
|
|
|
|
|
|
|
else { |
958
|
0
|
|
|
|
|
0
|
$self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"} = $new_style; |
959
|
0
|
|
|
|
|
0
|
$self->{'_namespaces'}->{$new_style} = $SOAP::Constants::PREFIX_ENC; |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
} |
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
# TODO - changing SOAP version can affect previously set encodingStyle |
964
|
|
|
|
|
|
|
sub soapversion { |
965
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
966
|
1
|
50
|
|
|
|
4
|
return $self->{_soapversion} unless @_; |
967
|
1
|
50
|
|
|
|
4
|
return $self if $self->{_soapversion} eq SOAP::Lite->soapversion; |
968
|
0
|
|
|
|
|
0
|
$self->{_soapversion} = shift; |
969
|
|
|
|
|
|
|
|
970
|
0
|
|
|
|
|
0
|
$self->attr({ |
971
|
|
|
|
|
|
|
"{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC, |
972
|
|
|
|
|
|
|
}); |
973
|
0
|
0
|
|
|
|
0
|
$self->namespaces({ |
974
|
|
|
|
|
|
|
$SOAP::Constants::NS_ENC => $SOAP::Constants::PREFIX_ENC, |
975
|
|
|
|
|
|
|
$SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (), |
976
|
|
|
|
|
|
|
}); |
977
|
0
|
|
|
|
|
0
|
$self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA); |
978
|
|
|
|
|
|
|
|
979
|
0
|
|
|
|
|
0
|
return $self; |
980
|
|
|
|
|
|
|
} |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
sub xmlschema { |
983
|
25
|
|
|
25
|
|
84
|
my $self = shift->new; |
984
|
25
|
50
|
|
|
|
106
|
return $self->{_xmlschema} unless @_; |
985
|
|
|
|
|
|
|
|
986
|
25
|
|
|
|
|
50
|
my @schema; |
987
|
25
|
50
|
|
|
|
108
|
if ($_[0]) { |
988
|
25
|
100
|
|
|
|
106
|
@schema = grep {/XMLSchema/ && /$_[0]/} keys %SOAP::Constants::XML_SCHEMAS; |
|
100
|
|
|
|
|
1606
|
|
989
|
25
|
50
|
|
|
|
118
|
Carp::croak "More than one schema match parameter '$_[0]': @{[join ', ', @schema]}" if @schema > 1; |
|
0
|
|
|
|
|
0
|
|
990
|
25
|
50
|
|
|
|
96
|
Carp::croak "No schema match parameter '$_[0]'" if @schema != 1; |
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
# do nothing if current schema is the same as new |
994
|
|
|
|
|
|
|
# return $self if $self->{_xmlschema} && $self->{_xmlschema} eq $schema[0]; |
995
|
|
|
|
|
|
|
|
996
|
25
|
|
|
|
|
153
|
my $ns = $self->namespaces; |
997
|
|
|
|
|
|
|
# delete current schema from namespaces |
998
|
25
|
50
|
|
|
|
115
|
if (my $schema = $self->{_xmlschema}) { |
999
|
0
|
|
|
|
|
0
|
delete $ns->{$schema}; |
1000
|
0
|
|
|
|
|
0
|
delete $ns->{"$schema-instance"}; |
1001
|
|
|
|
|
|
|
} |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
# add new schema into namespaces |
1004
|
25
|
50
|
|
|
|
119
|
if (my $schema = $self->{_xmlschema} = shift @schema) { |
1005
|
25
|
|
|
|
|
60
|
$ns->{$schema} = 'xsd'; |
1006
|
25
|
|
|
|
|
103
|
$ns->{"$schema-instance"} = 'xsi'; |
1007
|
|
|
|
|
|
|
} |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
# and here is the class serializer should work with |
1010
|
25
|
50
|
|
|
|
155
|
my $class = exists $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} |
1011
|
|
|
|
|
|
|
? $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} . '::Serializer' |
1012
|
|
|
|
|
|
|
: $self; |
1013
|
|
|
|
|
|
|
|
1014
|
25
|
|
|
|
|
202
|
$self->xmlschemaclass($class); |
1015
|
|
|
|
|
|
|
|
1016
|
25
|
|
|
|
|
60
|
return $self; |
1017
|
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
sub envprefix { |
1020
|
42
|
|
|
42
|
|
112
|
my $self = shift->new(); |
1021
|
42
|
50
|
|
|
|
211
|
return $self->namespaces->{$SOAP::Constants::NS_ENV} unless @_; |
1022
|
0
|
|
|
|
|
0
|
$self->namespaces->{$SOAP::Constants::NS_ENV} = shift; |
1023
|
0
|
|
|
|
|
0
|
return $self; |
1024
|
|
|
|
|
|
|
} |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
sub encprefix { |
1027
|
3
|
|
|
3
|
|
7
|
my $self = shift->new(); |
1028
|
3
|
50
|
|
|
|
13
|
return $self->namespaces->{$SOAP::Constants::NS_ENC} unless @_; |
1029
|
0
|
|
|
|
|
0
|
$self->namespaces->{$SOAP::Constants::NS_ENC} = shift; |
1030
|
0
|
|
|
|
|
0
|
return $self; |
1031
|
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
|
1033
|
204
|
|
|
204
|
|
1292
|
sub gen_id { sprintf "%U", $_[1] } |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
sub multiref_object { |
1036
|
152
|
|
|
152
|
|
210
|
my ($self, $object) = @_; |
1037
|
152
|
|
|
|
|
319
|
my $id = $self->gen_id($object); |
1038
|
152
|
100
|
|
|
|
415
|
if (! exists $self->{ _seen }->{ $id }) { |
1039
|
150
|
|
|
|
|
809
|
$self->{ _seen }->{ $id } = { |
1040
|
|
|
|
|
|
|
count => 1, |
1041
|
|
|
|
|
|
|
multiref => 0, |
1042
|
|
|
|
|
|
|
value => $object, |
1043
|
|
|
|
|
|
|
recursive => 0 |
1044
|
|
|
|
|
|
|
}; |
1045
|
|
|
|
|
|
|
} |
1046
|
|
|
|
|
|
|
else { |
1047
|
2
|
|
|
|
|
6
|
my $id_seen = $self->{ _seen }->{ $id }; |
1048
|
2
|
|
|
|
|
3
|
$id_seen->{count}++; |
1049
|
2
|
|
|
|
|
5
|
$id_seen->{multiref} = 1; |
1050
|
2
|
|
|
|
|
4
|
$id_seen->{value} = $object; |
1051
|
2
|
|
100
|
|
|
11
|
$id_seen->{recursive} ||= 0; |
1052
|
|
|
|
|
|
|
} |
1053
|
152
|
|
|
|
|
331
|
return $id; |
1054
|
|
|
|
|
|
|
} |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
sub recursive_object { |
1057
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1058
|
0
|
|
|
|
|
0
|
$self->seen->{$self->gen_id(shift)}->{recursive} = 1; |
1059
|
|
|
|
|
|
|
} |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
sub is_href { |
1062
|
52
|
|
|
52
|
|
76
|
my $self = shift; |
1063
|
52
|
50
|
50
|
|
|
178
|
my $seen = $self->seen->{shift || return} or return; |
1064
|
52
|
100
|
|
|
|
150
|
return 1 if $seen->{id}; |
1065
|
51
|
|
66
|
|
|
293
|
return $seen->{multiref} |
1066
|
|
|
|
|
|
|
&& !($seen->{id} = (shift |
1067
|
|
|
|
|
|
|
|| $seen->{recursive} |
1068
|
|
|
|
|
|
|
|| $seen->{multiref} && $self->multirefinplace)); |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
sub multiref_anchor { |
1072
|
2
|
|
|
2
|
|
6
|
my ($self, $id) = @_; |
1073
|
25
|
|
|
25
|
|
222
|
no warnings qw(uninitialized); |
|
25
|
|
|
|
|
77
|
|
|
25
|
|
|
|
|
18843
|
|
1074
|
2
|
50
|
|
|
|
8
|
if ($self->{ _seen }->{ $id }->{multiref}) { |
1075
|
2
|
|
|
|
|
13
|
return "ref-$id" |
1076
|
|
|
|
|
|
|
} |
1077
|
|
|
|
|
|
|
else { |
1078
|
0
|
|
|
|
|
0
|
return undef; |
1079
|
|
|
|
|
|
|
} |
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
sub encode_multirefs { |
1083
|
21
|
|
|
21
|
|
42
|
my $self = shift; |
1084
|
21
|
50
|
|
|
|
95
|
return if $self->multirefinplace(); |
1085
|
|
|
|
|
|
|
|
1086
|
21
|
|
|
|
|
54
|
my $seen = $self->{ _seen }; |
1087
|
0
|
|
|
|
|
0
|
map { $_->[1]->{_id} = 1; $_ } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1088
|
149
|
100
|
|
|
|
409
|
map { $self->encode_object($seen->{$_}->{value}) } |
1089
|
21
|
|
|
|
|
89
|
grep { $seen->{$_}->{multiref} && !$seen->{$_}->{recursive} } |
1090
|
|
|
|
|
|
|
keys %$seen; |
1091
|
|
|
|
|
|
|
} |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
sub maptypetouri { |
1094
|
52
|
|
|
52
|
|
83
|
my($self, $type, $simple) = @_; |
1095
|
|
|
|
|
|
|
|
1096
|
52
|
100
|
|
|
|
651
|
return $type unless defined $type; |
1097
|
1
|
|
|
|
|
5
|
my($prefix, $name) = SOAP::Utils::splitqname($type); |
1098
|
|
|
|
|
|
|
|
1099
|
1
|
50
|
|
|
|
5
|
unless (defined $prefix) { |
1100
|
0
|
|
|
|
|
0
|
$name =~ s/__|\./::/g; |
1101
|
0
|
0
|
|
|
|
0
|
$self->maptype->{$name} = $simple |
|
|
0
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
? die "Schema/namespace for type '$type' is not specified\n" |
1103
|
|
|
|
|
|
|
: $SOAP::Constants::NS_SL_PERLTYPE |
1104
|
|
|
|
|
|
|
unless exists $self->maptype->{$name}; |
1105
|
0
|
0
|
0
|
|
|
0
|
$type = $self->maptype->{$name} |
1106
|
|
|
|
|
|
|
? SOAP::Utils::qualify($self->namespaces->{$self->maptype->{$name}} ||= gen_ns, $type) |
1107
|
|
|
|
|
|
|
: undef; |
1108
|
|
|
|
|
|
|
} |
1109
|
1
|
|
|
|
|
8
|
return $type; |
1110
|
|
|
|
|
|
|
} |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
sub encode_object { |
1113
|
176
|
|
|
176
|
|
323
|
my($self, $object, $name, $type, $attr) = @_; |
1114
|
|
|
|
|
|
|
|
1115
|
176
|
|
100
|
|
|
590
|
$attr ||= {}; |
1116
|
176
|
100
|
|
|
|
468
|
return $self->encode_scalar($object, $name, $type, $attr) |
1117
|
|
|
|
|
|
|
unless ref $object; |
1118
|
|
|
|
|
|
|
|
1119
|
152
|
|
|
|
|
358
|
my $id = $self->multiref_object($object); |
1120
|
|
|
|
|
|
|
|
1121
|
25
|
|
|
25
|
|
173
|
use vars '%objectstack'; # we'll play with symbol table |
|
25
|
|
|
|
|
90
|
|
|
25
|
|
|
|
|
5933
|
|
1122
|
152
|
|
|
|
|
859
|
local %objectstack = %objectstack; # want to see objects ONLY in the current tree |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
# did we see this object in current tree? Seems to be recursive refs |
1125
|
|
|
|
|
|
|
# same as call to $self->recursive_object($object) - but |
1126
|
|
|
|
|
|
|
# recursive_object($object) has to re-compute the object's id |
1127
|
152
|
100
|
|
|
|
538
|
if (++$objectstack{ $id } > 1) { |
1128
|
2
|
|
|
|
|
6
|
$self->{ _seen }->{ $id }->{recursive} = 1 |
1129
|
|
|
|
|
|
|
} |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
# return if we already saw it twice. It should be already properly serialized |
1132
|
152
|
100
|
|
|
|
356
|
return if $objectstack{$id} > 2; |
1133
|
|
|
|
|
|
|
|
1134
|
151
|
100
|
|
|
|
634
|
if (UNIVERSAL::isa($object => 'SOAP::Data')) { |
1135
|
|
|
|
|
|
|
# use $object->SOAP::Data:: to enable overriding name() and others in inherited classes |
1136
|
99
|
100
|
|
|
|
326
|
$object->SOAP::Data::name($name) |
1137
|
|
|
|
|
|
|
unless defined $object->SOAP::Data::name; |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
# apply ->uri() and ->prefix() which can modify name and attributes of |
1140
|
|
|
|
|
|
|
# element, but do not modify SOAP::Data itself |
1141
|
99
|
|
|
|
|
269
|
my($name, $attr) = $self->fixattrs($object); |
1142
|
99
|
|
|
|
|
325
|
$attr = $self->attrstoqname($attr); |
1143
|
|
|
|
|
|
|
|
1144
|
99
|
|
|
|
|
1296
|
my @realvalues = $object->SOAP::Data::value; |
1145
|
99
|
50
|
0
|
|
|
252
|
return [$name || gen_name, $attr] unless @realvalues; |
1146
|
|
|
|
|
|
|
|
1147
|
99
|
|
50
|
|
|
308
|
my $method = "as_" . ($object->SOAP::Data::type || '-'); # dummy type if not defined |
1148
|
|
|
|
|
|
|
# try to call method specified for this type |
1149
|
25
|
|
|
25
|
|
143
|
no strict qw(refs); |
|
25
|
|
|
|
|
49
|
|
|
25
|
|
|
|
|
8563
|
|
1150
|
106
|
100
|
|
|
|
255
|
my @values = map { |
1151
|
|
|
|
|
|
|
# store null/nil attribute if value is undef |
1152
|
99
|
|
|
|
|
164
|
local $attr->{SOAP::Utils::qualify(xsi => $self->xmlschemaclass->nilValue)} = $self->xmlschemaclass->as_undef(1) |
1153
|
|
|
|
|
|
|
unless defined; |
1154
|
106
|
100
|
0
|
|
|
1141
|
$self->can($method) && $self->$method($_, $name || gen_name, $object->SOAP::Data::type, $attr) |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
1155
|
|
|
|
|
|
|
|| $self->typecast($_, $name || gen_name, $object->SOAP::Data::type, $attr) |
1156
|
|
|
|
|
|
|
|| $self->encode_object($_, $name, $object->SOAP::Data::type, $attr) |
1157
|
|
|
|
|
|
|
} @realvalues; |
1158
|
99
|
50
|
100
|
|
|
470
|
$object->SOAP::Data::signature([map {join $;, $_->[0], SOAP::Utils::disqualify($_->[1]->{'xsi:type'} || '')} @values]) if @values; |
|
106
|
|
|
|
|
1446
|
|
1159
|
99
|
50
|
|
|
|
1008
|
return wantarray ? @values : $values[0]; |
1160
|
|
|
|
|
|
|
} |
1161
|
|
|
|
|
|
|
|
1162
|
52
|
|
|
|
|
103
|
my $class = ref $object; |
1163
|
|
|
|
|
|
|
|
1164
|
52
|
50
|
|
|
|
293
|
if ($class !~ /^(?:SCALAR|ARRAY|HASH|REF)$/o) { |
1165
|
|
|
|
|
|
|
# we could also check for CODE|GLOB|LVALUE, but we cannot serialize |
1166
|
|
|
|
|
|
|
# them anyway, so they'll be caught by check below |
1167
|
0
|
|
|
|
|
0
|
$class =~ s/::/__/g; |
1168
|
|
|
|
|
|
|
|
1169
|
0
|
0
|
|
|
|
0
|
$name = $class if !defined $name; |
1170
|
0
|
0
|
0
|
|
|
0
|
$type = $class if !defined $type && $self->autotype; |
1171
|
|
|
|
|
|
|
|
1172
|
0
|
|
|
|
|
0
|
my $method = 'as_' . $class; |
1173
|
0
|
0
|
|
|
|
0
|
if ($self->can($method)) { |
1174
|
25
|
|
|
25
|
|
157
|
no strict qw(refs); |
|
25
|
|
|
|
|
54
|
|
|
25
|
|
|
|
|
11642
|
|
1175
|
0
|
|
|
|
|
0
|
my $encoded = $self->$method($object, $name, $type, $attr); |
1176
|
0
|
0
|
|
|
|
0
|
return $encoded if ref $encoded; |
1177
|
|
|
|
|
|
|
# return only if handled, otherwise handle with default handlers |
1178
|
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
|
1181
|
52
|
100
|
100
|
|
|
232
|
if (UNIVERSAL::isa($object => 'REF') || UNIVERSAL::isa($object => 'SCALAR')) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1182
|
50
|
|
|
|
|
248
|
return $self->encode_scalar($object, $name, $type, $attr); |
1183
|
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
|
elsif (UNIVERSAL::isa($object => 'ARRAY')) { |
1185
|
|
|
|
|
|
|
# Added in SOAP::Lite 0.65_6 to fix an XMLRPC bug |
1186
|
1
|
50
|
33
|
|
|
6
|
return $self->encodingStyle eq "" |
1187
|
|
|
|
|
|
|
|| $self->isa('XMLRPC::Serializer') |
1188
|
|
|
|
|
|
|
? $self->encode_array($object, $name, $type, $attr) |
1189
|
|
|
|
|
|
|
: $self->encode_literal_array($object, $name, $type, $attr); |
1190
|
|
|
|
|
|
|
} |
1191
|
|
|
|
|
|
|
elsif (UNIVERSAL::isa($object => 'HASH')) { |
1192
|
1
|
|
|
|
|
6
|
return $self->encode_hash($object, $name, $type, $attr); |
1193
|
|
|
|
|
|
|
} |
1194
|
|
|
|
|
|
|
else { |
1195
|
0
|
|
|
|
|
0
|
return $self->on_nonserialized->($object); |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
} |
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
sub encode_scalar { |
1200
|
89
|
|
|
89
|
|
773
|
my($self, $value, $name, $type, $attr) = @_; |
1201
|
89
|
|
66
|
|
|
203
|
$name ||= gen_name; |
1202
|
|
|
|
|
|
|
|
1203
|
89
|
|
|
|
|
291
|
my $schemaclass = $self->xmlschemaclass; |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
# null reference |
1206
|
89
|
100
|
|
|
|
274
|
return [$name, {%$attr, SOAP::Utils::qualify(xsi => $schemaclass->nilValue) => $schemaclass->as_undef(1)}] unless defined $value; |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
# object reference |
1209
|
78
|
100
|
|
|
|
302
|
return [$name, {'xsi:type' => $self->maptypetouri($type), %$attr}, [$self->encode_object($$value)], $self->gen_id($value)] if ref $value; |
1210
|
|
|
|
|
|
|
|
1211
|
|
|
|
|
|
|
# autodefined type |
1212
|
28
|
50
|
|
|
|
62
|
if ($self->{ _autotype}) { |
1213
|
28
|
|
|
|
|
47
|
my $lookup = $self->{_typelookup}; |
1214
|
25
|
|
|
25
|
|
159
|
no strict qw(refs); |
|
25
|
|
|
|
|
62
|
|
|
25
|
|
|
|
|
142361
|
|
1215
|
|
|
|
|
|
|
#for (sort {$lookup->{$a}->[0] <=> $lookup->{$b}->[0]} keys %$lookup) { |
1216
|
28
|
|
|
|
|
30
|
for (@{ $self->{ _typelookup_order } }) { |
|
28
|
|
|
|
|
62
|
|
1217
|
217
|
|
|
|
|
289
|
my $method = $lookup->{$_}->[2]; |
1218
|
217
|
100
|
33
|
|
|
359
|
return $self->can($method) && $self->$method($value, $name, $type, $attr) |
1219
|
|
|
|
|
|
|
|| $method->($value, $name, $type, $attr) |
1220
|
|
|
|
|
|
|
if $lookup->{$_}->[1]->($value); |
1221
|
|
|
|
|
|
|
} |
1222
|
|
|
|
|
|
|
} |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
# invariant |
1225
|
0
|
|
|
|
|
0
|
return [$name, $attr, $value]; |
1226
|
|
|
|
|
|
|
} |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
sub encode_array { |
1229
|
0
|
|
|
0
|
|
0
|
my ($self, $array, $name, $type, $attr) = @_; |
1230
|
0
|
|
|
|
|
0
|
my $items = 'item'; |
1231
|
|
|
|
|
|
|
|
1232
|
|
|
|
|
|
|
# If typing is disabled, just serialize each of the array items |
1233
|
|
|
|
|
|
|
# with no type information, each using the specified name, |
1234
|
|
|
|
|
|
|
# and do not create a wrapper array tag. |
1235
|
0
|
0
|
|
|
|
0
|
if (!$self->autotype) { |
1236
|
0
|
|
0
|
|
|
0
|
$name ||= gen_name; |
1237
|
0
|
|
|
|
|
0
|
return map {$self->encode_object($_, $name)} @$array; |
|
0
|
|
|
|
|
0
|
|
1238
|
|
|
|
|
|
|
} |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
# TODO: add support for multidimensional, partially transmitted and sparse arrays |
1241
|
0
|
|
|
|
|
0
|
my @items = map {$self->encode_object($_, $items)} @$array; |
|
0
|
|
|
|
|
0
|
|
1242
|
0
|
|
|
|
|
0
|
my $num = @items; |
1243
|
0
|
|
|
|
|
0
|
my($arraytype, %types) = '-'; |
1244
|
0
|
|
0
|
|
|
0
|
for (@items) { $arraytype = $_->[1]->{'xsi:type'} || '-'; $types{$arraytype}++ } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1245
|
0
|
0
|
0
|
|
|
0
|
$arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue) : $arraytype; |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
# $type = SOAP::Utils::qualify($self->encprefix => 'Array') if $self->autotype && !defined $type; |
1248
|
0
|
0
|
|
|
|
0
|
$type = qualify($self->encprefix => 'Array') if !defined $type; |
1249
|
0
|
|
0
|
|
|
0
|
return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'), |
1250
|
|
|
|
|
|
|
{ |
1251
|
|
|
|
|
|
|
SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype, |
1252
|
|
|
|
|
|
|
'xsi:type' => $self->maptypetouri($type), %$attr |
1253
|
|
|
|
|
|
|
}, |
1254
|
|
|
|
|
|
|
[@items], |
1255
|
|
|
|
|
|
|
$self->gen_id($array) |
1256
|
|
|
|
|
|
|
]; |
1257
|
|
|
|
|
|
|
} |
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
# Will encode arrays using doc-literal style |
1260
|
|
|
|
|
|
|
sub encode_literal_array { |
1261
|
1
|
|
|
1
|
|
3
|
my($self, $array, $name, $type, $attr) = @_; |
1262
|
|
|
|
|
|
|
|
1263
|
1
|
50
|
|
|
|
4
|
if ($self->autotype) { |
1264
|
1
|
|
|
|
|
3
|
my $items = 'item'; |
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
# TODO: add support for multidimensional, partially transmitted and sparse arrays |
1267
|
1
|
|
|
|
|
3
|
my @items = map {$self->encode_object($_, $items)} @$array; |
|
2
|
|
|
|
|
6
|
|
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
|
1270
|
1
|
|
|
|
|
2
|
my $num = @items; |
1271
|
1
|
|
|
|
|
3
|
my($arraytype, %types) = '-'; |
1272
|
1
|
|
|
|
|
2
|
for (@items) { |
1273
|
2
|
|
50
|
|
|
7
|
$arraytype = $_->[1]->{'xsi:type'} || '-'; |
1274
|
2
|
|
|
|
|
6
|
$types{$arraytype}++ |
1275
|
|
|
|
|
|
|
} |
1276
|
1
|
50
|
33
|
|
|
16
|
$arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' |
1277
|
|
|
|
|
|
|
? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue) |
1278
|
|
|
|
|
|
|
: $arraytype; |
1279
|
|
|
|
|
|
|
|
1280
|
1
|
50
|
|
|
|
7
|
$type = SOAP::Utils::qualify($self->encprefix => 'Array') |
1281
|
|
|
|
|
|
|
if !defined $type; |
1282
|
|
|
|
|
|
|
|
1283
|
1
|
|
33
|
|
|
8
|
return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'), |
1284
|
|
|
|
|
|
|
{ |
1285
|
|
|
|
|
|
|
SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype, |
1286
|
|
|
|
|
|
|
'xsi:type' => $self->maptypetouri($type), %$attr |
1287
|
|
|
|
|
|
|
}, |
1288
|
|
|
|
|
|
|
[ @items ], |
1289
|
|
|
|
|
|
|
$self->gen_id($array) |
1290
|
|
|
|
|
|
|
]; |
1291
|
|
|
|
|
|
|
} |
1292
|
|
|
|
|
|
|
else { |
1293
|
|
|
|
|
|
|
# |
1294
|
|
|
|
|
|
|
# literal arrays are different - { array => [ 5,6 ] } |
1295
|
|
|
|
|
|
|
# results in 56 |
1296
|
|
|
|
|
|
|
# This means that if there's a literal inside the array (not a |
1297
|
|
|
|
|
|
|
# reference), we have to encode it this way. If there's only |
1298
|
|
|
|
|
|
|
# nested tags, encode as |
1299
|
|
|
|
|
|
|
# 12 |
1300
|
|
|
|
|
|
|
# |
1301
|
|
|
|
|
|
|
|
1302
|
0
|
|
|
|
|
0
|
my $literal = undef; |
1303
|
|
|
|
|
|
|
my @items = map { |
1304
|
0
|
|
|
|
|
0
|
ref $_ |
1305
|
|
|
|
|
|
|
? $self->encode_object($_) |
1306
|
0
|
0
|
|
|
|
0
|
: do { |
1307
|
0
|
|
|
|
|
0
|
$literal++; |
1308
|
0
|
|
|
|
|
0
|
$_ |
1309
|
|
|
|
|
|
|
} |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
} @$array; |
1312
|
|
|
|
|
|
|
|
1313
|
0
|
0
|
|
|
|
0
|
if ($literal) { |
1314
|
0
|
|
|
|
|
0
|
return map { [ $name , $attr , $_, $self->gen_id($array) ] } @items; |
|
0
|
|
|
|
|
0
|
|
1315
|
|
|
|
|
|
|
} |
1316
|
|
|
|
|
|
|
else { |
1317
|
0
|
|
0
|
|
|
0
|
return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'), |
1318
|
|
|
|
|
|
|
$attr, |
1319
|
|
|
|
|
|
|
[ @items ], |
1320
|
|
|
|
|
|
|
$self->gen_id($array) |
1321
|
|
|
|
|
|
|
]; |
1322
|
|
|
|
|
|
|
} |
1323
|
|
|
|
|
|
|
} |
1324
|
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
|
sub encode_hash { |
1327
|
1
|
|
|
1
|
|
4
|
my($self, $hash, $name, $type, $attr) = @_; |
1328
|
|
|
|
|
|
|
|
1329
|
1
|
50
|
33
|
|
|
4
|
if ($self->autotype && grep {!/$SOAP::Constants::ELMASK/o} keys %$hash) { |
|
1
|
|
|
|
|
101
|
|
1330
|
0
|
0
|
|
|
|
0
|
warn qq!Cannot encode @{[$name ? "'$name'" : 'unnamed']} element as 'hash'. Will be encoded as 'map' instead\n! if $^W; |
|
0
|
0
|
|
|
|
0
|
|
1331
|
0
|
|
0
|
|
|
0
|
return $self->as_map($hash, $name || gen_name, $type, $attr); |
1332
|
|
|
|
|
|
|
} |
1333
|
|
|
|
|
|
|
|
1334
|
1
|
50
|
33
|
|
|
6
|
$type = 'SOAPStruct' |
|
|
|
33
|
|
|
|
|
1335
|
|
|
|
|
|
|
if $self->autotype && !defined($type) && exists $self->maptype->{SOAPStruct}; |
1336
|
1
|
|
|
|
|
5
|
return [$name || gen_name, |
1337
|
|
|
|
|
|
|
$self->autotype ? {'xsi:type' => $self->maptypetouri($type), %$attr} : { %$attr }, |
1338
|
1
|
50
|
33
|
|
|
6
|
[map {$self->encode_object($hash->{$_}, $_)} keys %$hash], |
1339
|
|
|
|
|
|
|
$self->gen_id($hash) |
1340
|
|
|
|
|
|
|
]; |
1341
|
|
|
|
|
|
|
} |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
sub as_ordered_hash { |
1344
|
0
|
|
|
0
|
|
0
|
my ($self, $value, $name, $type, $attr) = @_; |
1345
|
0
|
0
|
|
|
|
0
|
die "Not an ARRAY reference for 'ordered_hash' type" unless UNIVERSAL::isa($value => 'ARRAY'); |
1346
|
0
|
|
|
|
|
0
|
return [ $name, $attr, |
1347
|
0
|
|
|
|
|
0
|
[map{$self->encode_object(@{$value}[2*$_+1,2*$_])} 0..$#$value/2 ], |
|
0
|
|
|
|
|
0
|
|
1348
|
|
|
|
|
|
|
$self->gen_id($value) |
1349
|
|
|
|
|
|
|
]; |
1350
|
|
|
|
|
|
|
} |
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
sub as_map { |
1353
|
0
|
|
|
0
|
|
0
|
my ($self, $value, $name, $type, $attr) = @_; |
1354
|
0
|
0
|
|
|
|
0
|
die "Not a HASH reference for 'map' type" unless UNIVERSAL::isa($value => 'HASH'); |
1355
|
0
|
|
0
|
|
|
0
|
my $prefix = ($self->namespaces->{$SOAP::Constants::NS_APS} ||= 'apachens'); |
1356
|
0
|
|
|
|
|
0
|
my @items = map { |
1357
|
0
|
|
|
|
|
0
|
$self->encode_object( |
1358
|
|
|
|
|
|
|
SOAP::Data->type( |
1359
|
|
|
|
|
|
|
ordered_hash => [ |
1360
|
|
|
|
|
|
|
key => $_, |
1361
|
|
|
|
|
|
|
value => $value->{$_} |
1362
|
|
|
|
|
|
|
] |
1363
|
|
|
|
|
|
|
), |
1364
|
|
|
|
|
|
|
'item', |
1365
|
|
|
|
|
|
|
'' |
1366
|
|
|
|
|
|
|
)} sort keys %$value; |
1367
|
|
|
|
|
|
|
return [ |
1368
|
0
|
|
|
|
|
0
|
$name, |
1369
|
|
|
|
|
|
|
{'xsi:type' => "$prefix:Map", %$attr}, |
1370
|
|
|
|
|
|
|
[@items], |
1371
|
|
|
|
|
|
|
$self->gen_id($value) |
1372
|
|
|
|
|
|
|
]; |
1373
|
|
|
|
|
|
|
} |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
sub as_xml { |
1376
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1377
|
0
|
|
|
|
|
0
|
my($value, $name, $type, $attr) = @_; |
1378
|
0
|
|
|
|
|
0
|
return [$name, {'_xml' => 1}, $value]; |
1379
|
|
|
|
|
|
|
} |
1380
|
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
|
sub typecast { |
1382
|
106
|
|
|
106
|
|
134
|
my $self = shift; |
1383
|
106
|
|
|
|
|
236
|
my($value, $name, $type, $attr) = @_; |
1384
|
106
|
100
|
|
|
|
670
|
return if ref $value; # skip complex object, caller knows how to deal with it |
1385
|
25
|
100
|
66
|
|
|
103
|
return if $self->autotype && !defined $type; # we don't know, autotype knows |
1386
|
5
|
50
|
33
|
|
|
66
|
return [$name, |
1387
|
|
|
|
|
|
|
{(defined $type && $type gt '' ? ('xsi:type' => $self->maptypetouri($type, 'simple type')) : ()), %$attr}, |
1388
|
|
|
|
|
|
|
$value |
1389
|
|
|
|
|
|
|
]; |
1390
|
|
|
|
|
|
|
} |
1391
|
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
|
sub register_ns { |
1393
|
68
|
|
|
68
|
|
250
|
my $self = shift->new(); |
1394
|
68
|
|
|
|
|
142
|
my ($ns,$prefix) = @_; |
1395
|
68
|
100
|
|
|
|
185
|
$prefix = gen_ns if !$prefix; |
1396
|
68
|
100
|
|
|
|
275
|
$self->{'_namespaces'}->{$ns} = $prefix if $ns; |
1397
|
|
|
|
|
|
|
} |
1398
|
|
|
|
|
|
|
|
1399
|
|
|
|
|
|
|
sub find_prefix { |
1400
|
5
|
|
|
5
|
|
8
|
my ($self, $ns) = @_; |
1401
|
5
|
100
|
|
|
|
28
|
return (exists $self->{'_namespaces'}->{$ns}) |
1402
|
|
|
|
|
|
|
? $self->{'_namespaces'}->{$ns} |
1403
|
|
|
|
|
|
|
: (); |
1404
|
|
|
|
|
|
|
} |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
sub fixattrs { |
1407
|
99
|
|
|
99
|
|
146
|
my ($self, $data) = @_; |
1408
|
99
|
|
|
|
|
279
|
my ($name, $attr) = ($data->SOAP::Data::name, {%{$data->SOAP::Data::attr}}); |
|
99
|
|
|
|
|
283
|
|
1409
|
99
|
|
|
|
|
265
|
my ($xmlns, $prefix) = ($data->uri, $data->prefix); |
1410
|
99
|
100
|
66
|
|
|
493
|
unless (defined($xmlns) || defined($prefix)) { |
1411
|
56
|
100
|
|
|
|
180
|
$self->register_ns($xmlns,$prefix) unless ($self->use_default_ns); |
1412
|
56
|
|
|
|
|
168
|
return ($name, $attr); |
1413
|
|
|
|
|
|
|
} |
1414
|
43
|
|
33
|
|
|
125
|
$name ||= gen_name(); # local name |
1415
|
43
|
50
|
33
|
|
|
204
|
$prefix = gen_ns() if !defined $prefix && $xmlns gt ''; |
1416
|
43
|
50
|
33
|
|
|
598
|
$prefix = '' |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
1417
|
|
|
|
|
|
|
if defined $xmlns && $xmlns eq '' |
1418
|
|
|
|
|
|
|
|| defined $prefix && $prefix eq ''; |
1419
|
|
|
|
|
|
|
|
1420
|
43
|
50
|
0
|
|
|
112
|
$attr->{join ':', xmlns => $prefix || ()} = $xmlns if defined $xmlns; |
1421
|
43
|
50
|
|
|
|
154
|
$name = join ':', $prefix, $name if $prefix; |
1422
|
|
|
|
|
|
|
|
1423
|
43
|
100
|
|
|
|
147
|
$self->register_ns($xmlns,$prefix) unless ($self->use_default_ns); |
1424
|
|
|
|
|
|
|
|
1425
|
43
|
|
|
|
|
136
|
return ($name, $attr); |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
} |
1428
|
|
|
|
|
|
|
|
1429
|
|
|
|
|
|
|
sub toqname { |
1430
|
21
|
|
|
21
|
|
46
|
my $self = shift; |
1431
|
21
|
|
|
|
|
42
|
my $long = shift; |
1432
|
|
|
|
|
|
|
|
1433
|
21
|
50
|
|
|
|
126
|
return $long unless $long =~ /^\{(.*)\}(.+)$/; |
1434
|
21
|
|
33
|
|
|
252
|
return SOAP::Utils::qualify $self->namespaces->{$1} ||= gen_ns, $2; |
1435
|
|
|
|
|
|
|
} |
1436
|
|
|
|
|
|
|
|
1437
|
|
|
|
|
|
|
sub attrstoqname { |
1438
|
99
|
|
|
99
|
|
133
|
my $self = shift; |
1439
|
99
|
|
|
|
|
128
|
my $attrs = shift; |
1440
|
|
|
|
|
|
|
|
1441
|
|
|
|
|
|
|
return { |
1442
|
99
|
50
|
33
|
|
|
260
|
map { /^\{(.*)\}(.+)$/ |
|
34
|
100
|
|
|
|
363
|
|
1443
|
|
|
|
|
|
|
? ($self->toqname($_) => $2 eq 'type' |
1444
|
|
|
|
|
|
|
|| $2 eq 'arrayType' |
1445
|
|
|
|
|
|
|
? $self->toqname($attrs->{$_}) |
1446
|
|
|
|
|
|
|
: $attrs->{$_}) |
1447
|
|
|
|
|
|
|
: ($_ => $attrs->{$_}) |
1448
|
|
|
|
|
|
|
} keys %$attrs |
1449
|
|
|
|
|
|
|
}; |
1450
|
|
|
|
|
|
|
} |
1451
|
|
|
|
|
|
|
|
1452
|
|
|
|
|
|
|
sub tag { |
1453
|
81
|
|
|
81
|
|
190
|
my ($self, $tag, $attrs, @values) = @_; |
1454
|
|
|
|
|
|
|
|
1455
|
81
|
|
|
|
|
153
|
my $readable = $self->{ _readable }; |
1456
|
|
|
|
|
|
|
|
1457
|
81
|
|
|
|
|
175
|
my $value = join '', @values; |
1458
|
81
|
50
|
|
|
|
209
|
my $indent = $readable ? ' ' x (($self->{ _level }-1)*2) : ''; |
1459
|
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
|
# check for special attribute |
1461
|
81
|
50
|
33
|
|
|
260
|
return "$indent$value" if exists $attrs->{_xml} && delete $attrs->{_xml}; |
1462
|
|
|
|
|
|
|
|
1463
|
81
|
50
|
|
|
|
1364
|
die "Element '$tag' can't be allowed in valid XML message. Died." |
1464
|
|
|
|
|
|
|
if $tag !~ /^$SOAP::Constants::NSMASK$/o; |
1465
|
|
|
|
|
|
|
|
1466
|
81
|
50
|
|
|
|
318
|
warn "Element '$tag' uses the reserved prefix 'XML' (in any case)" |
1467
|
|
|
|
|
|
|
if $tag !~ /^(?![Xx][Mm][Ll])/; |
1468
|
|
|
|
|
|
|
|
1469
|
81
|
50
|
|
|
|
239
|
my $prolog = $readable ? "\n" : ""; |
1470
|
81
|
50
|
|
|
|
217
|
my $epilog = $readable ? "\n" : ""; |
1471
|
81
|
|
|
|
|
98
|
my $tagjoiner = " "; |
1472
|
81
|
100
|
|
|
|
225
|
if ($self->{ _level } == 1) { |
1473
|
22
|
|
|
|
|
89
|
my $namespaces = $self->namespaces; |
1474
|
22
|
|
|
|
|
93
|
foreach (keys %$namespaces) { |
1475
|
87
|
|
|
|
|
213
|
$attrs->{SOAP::Utils::qualify(xmlns => $namespaces->{$_})} = $_ |
1476
|
|
|
|
|
|
|
} |
1477
|
22
|
50
|
|
|
|
113
|
$prolog = qq!encoding]}"?>! |
|
22
|
|
|
|
|
81
|
|
1478
|
|
|
|
|
|
|
if defined $self->encoding; |
1479
|
22
|
50
|
|
|
|
97
|
$prolog .= "\n" if $readable; |
1480
|
22
|
50
|
|
|
|
118
|
$tagjoiner = " \n".(' ' x 4 ) if $readable; |
1481
|
|
|
|
|
|
|
} |
1482
|
149
|
|
|
|
|
328
|
my $tagattrs = join($tagjoiner, '', |
1483
|
200
|
100
|
66
|
|
|
1337
|
map { sprintf '%s="%s"', $_, SOAP::Utils::encode_attribute($attrs->{$_}) } |
|
|
|
66
|
|
|
|
|
1484
|
81
|
|
|
|
|
352
|
grep { $_ && defined $attrs->{$_} && ($_ ne 'xsi:type' || $attrs->{$_} ne '') } |
1485
|
|
|
|
|
|
|
sort keys %$attrs); |
1486
|
|
|
|
|
|
|
|
1487
|
81
|
100
|
|
|
|
345
|
if ($value gt '') { |
1488
|
69
|
100
|
|
|
|
1015
|
return sprintf("$prolog$indent<%s%s>%s%s%s>$epilog",$tag,$tagattrs,$value,($value =~ /^\s* ? $indent : ""),$tag); |
1489
|
|
|
|
|
|
|
} |
1490
|
|
|
|
|
|
|
else { |
1491
|
12
|
|
|
|
|
117
|
return sprintf("$prolog$indent<%s%s />$epilog$indent",$tag,$tagattrs); |
1492
|
|
|
|
|
|
|
} |
1493
|
|
|
|
|
|
|
} |
1494
|
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
sub xmlize { |
1496
|
81
|
|
|
81
|
|
128
|
my $self = shift; |
1497
|
81
|
|
|
|
|
87
|
my($name, $attrs, $values, $id) = @{$_[0]}; |
|
81
|
|
|
|
|
204
|
|
1498
|
81
|
|
50
|
|
|
198
|
$attrs ||= {}; |
1499
|
|
|
|
|
|
|
|
1500
|
81
|
|
|
|
|
341
|
local $self->{_level} = $self->{_level} + 1; |
1501
|
|
|
|
|
|
|
|
1502
|
81
|
100
|
|
|
|
213
|
return $self->tag($name, $attrs) |
1503
|
|
|
|
|
|
|
unless defined $values; |
1504
|
|
|
|
|
|
|
|
1505
|
70
|
100
|
|
|
|
245
|
return $self->tag($name, $attrs, $values) |
1506
|
|
|
|
|
|
|
unless ref $values eq "ARRAY"; |
1507
|
|
|
|
|
|
|
|
1508
|
52
|
100
|
|
|
|
201
|
return $self->tag($name, {%$attrs, href => '#'.$self->multiref_anchor($id)}) |
1509
|
|
|
|
|
|
|
if $self->is_href($id, delete($attrs->{_id})); |
1510
|
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
|
# we have seen this element as a reference |
1512
|
51
|
100
|
66
|
|
|
306
|
if (defined $id && $self->{ _seen }->{ $id }->{ multiref}) { |
1513
|
1
|
|
|
|
|
3
|
return $self->tag($name, |
1514
|
|
|
|
|
|
|
{ |
1515
|
|
|
|
|
|
|
%$attrs, id => $self->multiref_anchor($id) |
1516
|
|
|
|
|
|
|
}, |
1517
|
1
|
|
|
|
|
6
|
map {$self->xmlize($_)} @$values |
1518
|
|
|
|
|
|
|
); |
1519
|
|
|
|
|
|
|
} |
1520
|
|
|
|
|
|
|
else { |
1521
|
50
|
|
|
|
|
94
|
return $self->tag($name, $attrs, map {$self->xmlize($_)} @$values); |
|
58
|
|
|
|
|
309
|
|
1522
|
|
|
|
|
|
|
} |
1523
|
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
sub uriformethod { |
1526
|
12
|
|
|
12
|
|
34
|
my $self = shift; |
1527
|
|
|
|
|
|
|
|
1528
|
12
|
|
33
|
|
|
75
|
my $method_is_data = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Data'); |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
# drop prefix from method that could be string or SOAP::Data object |
1531
|
12
|
50
|
|
|
|
252
|
my($prefix, $method) = $method_is_data |
1532
|
|
|
|
|
|
|
? ($_[0]->prefix, $_[0]->name) |
1533
|
|
|
|
|
|
|
: SOAP::Utils::splitqname($_[0]); |
1534
|
|
|
|
|
|
|
|
1535
|
12
|
|
|
|
|
33
|
my $attr = {reverse %{$self->namespaces}}; |
|
12
|
|
|
|
|
74
|
|
1536
|
|
|
|
|
|
|
# try to define namespace that could be stored as |
1537
|
|
|
|
|
|
|
# a) method is SOAP::Data |
1538
|
|
|
|
|
|
|
# ? attribute in method's element as xmlns= or xmlns:${prefix}= |
1539
|
|
|
|
|
|
|
# : uri |
1540
|
|
|
|
|
|
|
# b) attribute in Envelope element as xmlns= or xmlns:${prefix}= |
1541
|
|
|
|
|
|
|
# c) no prefix or prefix equal serializer->envprefix |
1542
|
|
|
|
|
|
|
# ? '', but see comment below |
1543
|
|
|
|
|
|
|
# : die with error message |
1544
|
12
|
50
|
0
|
|
|
155
|
my $uri = $method_is_data |
1545
|
|
|
|
|
|
|
? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri) |
1546
|
|
|
|
|
|
|
: $self->uri; |
1547
|
|
|
|
|
|
|
|
1548
|
12
|
50
|
0
|
|
|
57
|
defined $uri or $uri = $attr->{$prefix || ''}; |
1549
|
|
|
|
|
|
|
|
1550
|
12
|
0
|
0
|
|
|
69
|
defined $uri or $uri = !$prefix || $prefix eq $self->envprefix |
|
|
50
|
0
|
|
|
|
|
1551
|
|
|
|
|
|
|
# still in doubts what should namespace be in this case |
1552
|
|
|
|
|
|
|
# but will keep it like this for now and be compatible with our server |
1553
|
|
|
|
|
|
|
? ( $method_is_data |
1554
|
|
|
|
|
|
|
&& $^W |
1555
|
|
|
|
|
|
|
&& warn("URI is not provided as an attribute for method ($method)\n"), |
1556
|
|
|
|
|
|
|
'' |
1557
|
|
|
|
|
|
|
) |
1558
|
|
|
|
|
|
|
: die "Can't find namespace for method ($prefix:$method)\n"; |
1559
|
|
|
|
|
|
|
|
1560
|
12
|
|
|
|
|
89
|
return ($uri, $method); |
1561
|
|
|
|
|
|
|
} |
1562
|
|
|
|
|
|
|
|
1563
|
3
|
|
|
3
|
|
12
|
sub serialize { SOAP::Trace::trace('()'); |
1564
|
3
|
|
|
|
|
12
|
my $self = shift->new; |
1565
|
3
|
50
|
|
|
|
11
|
@_ == 1 or Carp::croak "serialize() method accepts one parameter"; |
1566
|
|
|
|
|
|
|
|
1567
|
3
|
|
|
|
|
15
|
$self->seen({}); # reinitialize multiref table |
1568
|
3
|
|
|
|
|
13
|
my($encoded) = $self->encode_object($_[0]); |
1569
|
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
|
# now encode multirefs if any |
1571
|
|
|
|
|
|
|
# v -------------- subelements of Envelope |
1572
|
3
|
100
|
|
|
|
15
|
push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2]; |
|
2
|
|
|
|
|
8
|
|
1573
|
3
|
|
|
|
|
12
|
return $self->xmlize($encoded); |
1574
|
|
|
|
|
|
|
} |
1575
|
|
|
|
|
|
|
|
1576
|
|
|
|
|
|
|
sub envelope { |
1577
|
19
|
|
|
19
|
|
80
|
SOAP::Trace::trace('()'); |
1578
|
19
|
|
|
|
|
71
|
my $self = shift->new; |
1579
|
19
|
|
|
|
|
48
|
my $type = shift; |
1580
|
19
|
|
|
|
|
34
|
my(@parameters, @header); |
1581
|
19
|
|
|
|
|
61
|
for (@_) { |
1582
|
|
|
|
|
|
|
# Find all the SOAP Headers |
1583
|
31
|
50
|
100
|
|
|
824
|
if (defined($_) && ref($_) && UNIVERSAL::isa($_ => 'SOAP::Header')) { |
|
|
50
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
1584
|
0
|
|
|
|
|
0
|
push(@header, $_); |
1585
|
|
|
|
|
|
|
} |
1586
|
|
|
|
|
|
|
# Find all the SOAP Message Parts (attachments) |
1587
|
|
|
|
|
|
|
elsif (defined($_) && ref($_) && $self->context |
1588
|
|
|
|
|
|
|
&& $self->context->packager->is_supported_part($_) |
1589
|
|
|
|
|
|
|
) { |
1590
|
0
|
|
|
|
|
0
|
$self->context->packager->push_part($_); |
1591
|
|
|
|
|
|
|
} |
1592
|
|
|
|
|
|
|
# Find all the SOAP Body elements |
1593
|
|
|
|
|
|
|
else { |
1594
|
|
|
|
|
|
|
# proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope |
1595
|
31
|
|
|
|
|
105
|
push(@parameters, $_); |
1596
|
|
|
|
|
|
|
# push (@parameters, SOAP::Utils::encode_data($_)); |
1597
|
|
|
|
|
|
|
} |
1598
|
|
|
|
|
|
|
} |
1599
|
19
|
50
|
|
|
|
104
|
my $header = @header ? SOAP::Data->set_value(@header) : undef; |
1600
|
19
|
|
|
|
|
53
|
my($body,$parameters); |
1601
|
19
|
100
|
66
|
|
|
135
|
if ($type eq 'method' || $type eq 'response') { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1602
|
17
|
|
|
|
|
69
|
SOAP::Trace::method(@parameters); |
1603
|
|
|
|
|
|
|
|
1604
|
17
|
|
|
|
|
38
|
my $method = shift(@parameters); |
1605
|
|
|
|
|
|
|
# or die "Unspecified method for SOAP call\n"; |
1606
|
|
|
|
|
|
|
|
1607
|
17
|
100
|
|
|
|
72
|
$parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef; |
1608
|
17
|
50
|
|
|
|
282
|
if (!defined($method)) {} |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
elsif (UNIVERSAL::isa($method => 'SOAP::Data')) { |
1610
|
0
|
|
|
|
|
0
|
$body = $method; |
1611
|
|
|
|
|
|
|
} |
1612
|
|
|
|
|
|
|
elsif ($self->use_default_ns) { |
1613
|
14
|
100
|
|
|
|
89
|
if ($self->{'_ns_uri'}) { |
1614
|
13
|
|
|
|
|
105
|
$body = SOAP::Data->name($method) |
1615
|
|
|
|
|
|
|
->attr({'xmlns' => $self->{'_ns_uri'} } ); |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
else { |
1618
|
1
|
|
|
|
|
3
|
$body = SOAP::Data->name($method); |
1619
|
|
|
|
|
|
|
} |
1620
|
|
|
|
|
|
|
} |
1621
|
|
|
|
|
|
|
else { |
1622
|
|
|
|
|
|
|
# Commented out by Byrne on 1/4/2006 - to address default namespace problems |
1623
|
|
|
|
|
|
|
# $body = SOAP::Data->name($method)->uri($self->{'_ns_uri'}); |
1624
|
|
|
|
|
|
|
# $body = $body->prefix($self->{'_ns_prefix'}) if ($self->{'_ns_prefix'}); |
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
# Added by Byrne on 1/4/2006 - to avoid the unnecessary creation of a new |
1627
|
|
|
|
|
|
|
# namespace |
1628
|
|
|
|
|
|
|
# Begin New Code (replaces code commented out above) |
1629
|
3
|
|
|
|
|
15
|
$body = SOAP::Data->name($method); |
1630
|
3
|
|
|
|
|
15
|
my $pre = $self->find_prefix($self->{'_ns_uri'}); |
1631
|
3
|
50
|
|
|
|
17
|
$body = $body->prefix($pre) if ($self->{'_ns_prefix'}); |
1632
|
|
|
|
|
|
|
# End new code |
1633
|
|
|
|
|
|
|
} |
1634
|
|
|
|
|
|
|
|
1635
|
|
|
|
|
|
|
# This is breaking a unit test right now... |
1636
|
|
|
|
|
|
|
# proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope |
1637
|
|
|
|
|
|
|
# $body->set_value(SOAP::Utils::encode_data($parameters ? \$parameters : ())) |
1638
|
|
|
|
|
|
|
# if $body; |
1639
|
|
|
|
|
|
|
# must call encode_data on nothing to enforce xsi:nil="true" to be set. |
1640
|
17
|
100
|
|
|
|
163
|
$body->set_value($parameters ? \$parameters : SOAP::Utils::encode_data()) if $body; |
|
|
50
|
|
|
|
|
|
1641
|
|
|
|
|
|
|
} |
1642
|
|
|
|
|
|
|
elsif ($type eq 'fault') { |
1643
|
2
|
|
|
|
|
12
|
SOAP::Trace::fault(@parameters); |
1644
|
|
|
|
|
|
|
# -> attr({'xmlns' => ''}) |
1645
|
|
|
|
|
|
|
# Parameter order fixed thanks to Tom Fischer |
1646
|
|
|
|
|
|
|
$body = SOAP::Data-> name(SOAP::Utils::qualify($self->envprefix => 'Fault')) |
1647
|
|
|
|
|
|
|
-> value(\SOAP::Data->set_value( |
1648
|
|
|
|
|
|
|
SOAP::Data->name(faultcode => SOAP::Utils::qualify($self->envprefix => $parameters[0]))->type(""), |
1649
|
|
|
|
|
|
|
SOAP::Data->name(faultstring => SOAP::Utils::encode_data($parameters[1]))->type(""), |
1650
|
|
|
|
|
|
|
defined($parameters[3]) |
1651
|
|
|
|
|
|
|
? SOAP::Data->name(faultactor => $parameters[3])->type("") |
1652
|
|
|
|
|
|
|
: (), |
1653
|
|
|
|
|
|
|
defined($parameters[2]) |
1654
|
2
|
100
|
|
|
|
9
|
? SOAP::Data->name(detail => do{ |
|
|
100
|
|
|
|
|
|
1655
|
1
|
|
|
|
|
2
|
my $detail = $parameters[2]; |
1656
|
1
|
50
|
|
|
|
4
|
ref $detail |
1657
|
|
|
|
|
|
|
? \$detail |
1658
|
|
|
|
|
|
|
: SOAP::Utils::encode_data($detail) |
1659
|
|
|
|
|
|
|
}) |
1660
|
|
|
|
|
|
|
: (), |
1661
|
|
|
|
|
|
|
)); |
1662
|
|
|
|
|
|
|
} |
1663
|
|
|
|
|
|
|
elsif ($type eq 'freeform') { |
1664
|
0
|
|
|
|
|
0
|
SOAP::Trace::freeform(@parameters); |
1665
|
0
|
|
|
|
|
0
|
$body = SOAP::Data->set_value(@parameters); |
1666
|
|
|
|
|
|
|
} |
1667
|
|
|
|
|
|
|
elsif (!defined($type)) { |
1668
|
|
|
|
|
|
|
# This occurs when the Body is intended to be null. When no method has been |
1669
|
|
|
|
|
|
|
# passed in of any kind. |
1670
|
|
|
|
|
|
|
} |
1671
|
|
|
|
|
|
|
else { |
1672
|
0
|
|
|
|
|
0
|
die "Wrong type of envelope ($type) for SOAP call\n"; |
1673
|
|
|
|
|
|
|
} |
1674
|
|
|
|
|
|
|
|
1675
|
19
|
|
|
|
|
73
|
$self->{ _seen } = {}; # reinitialize multiref table |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
# Build the envelope |
1678
|
|
|
|
|
|
|
# Right now it is possible for $body to be a SOAP::Data element that has not |
1679
|
|
|
|
|
|
|
# XML escaped any values. How do you remedy this? |
1680
|
19
|
50
|
|
|
|
122
|
my($encoded) = $self->encode_object( |
|
|
50
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
SOAP::Data->name( |
1682
|
|
|
|
|
|
|
SOAP::Utils::qualify($self->envprefix => 'Envelope') => \SOAP::Data->value( |
1683
|
|
|
|
|
|
|
($header |
1684
|
|
|
|
|
|
|
? SOAP::Data->name( SOAP::Utils::qualify($self->envprefix => 'Header') => \$header) |
1685
|
|
|
|
|
|
|
: () |
1686
|
|
|
|
|
|
|
), |
1687
|
|
|
|
|
|
|
($body |
1688
|
|
|
|
|
|
|
? SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body') => \$body) |
1689
|
|
|
|
|
|
|
: SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body')) ), |
1690
|
|
|
|
|
|
|
) |
1691
|
|
|
|
|
|
|
)->attr($self->attr) |
1692
|
|
|
|
|
|
|
); |
1693
|
|
|
|
|
|
|
|
1694
|
19
|
100
|
|
|
|
120
|
$self->signature($parameters->signature) if ref $parameters; |
1695
|
|
|
|
|
|
|
|
1696
|
|
|
|
|
|
|
# IMHO multirefs should be encoded after Body, but only some |
1697
|
|
|
|
|
|
|
# toolkits understand this encoding, so we'll keep them for now (04/15/2001) |
1698
|
|
|
|
|
|
|
# as the last element inside the Body |
1699
|
|
|
|
|
|
|
# v -------------- subelements of Envelope |
1700
|
|
|
|
|
|
|
# vv -------- last of them (Body) |
1701
|
|
|
|
|
|
|
# v --- subelements |
1702
|
19
|
50
|
|
|
|
107
|
push(@{$encoded->[2]->[-1]->[2]}, $self->encode_multirefs) if ref $encoded->[2]->[-1]->[2]; |
|
19
|
|
|
|
|
101
|
|
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
# Sometimes SOAP::Serializer is invoked statically when there is no context. |
1705
|
|
|
|
|
|
|
# So first check to see if a context exists. |
1706
|
|
|
|
|
|
|
# TODO - a context needs to be initialized by a constructor? |
1707
|
19
|
100
|
66
|
|
|
94
|
if ($self->context && $self->context->packager->parts) { |
1708
|
|
|
|
|
|
|
# TODO - this needs to be called! Calling it though wraps the payload twice! |
1709
|
|
|
|
|
|
|
# return $self->context->packager->package($self->xmlize($encoded)); |
1710
|
|
|
|
|
|
|
} |
1711
|
|
|
|
|
|
|
|
1712
|
19
|
|
|
|
|
93
|
return $self->xmlize($encoded); |
1713
|
|
|
|
|
|
|
} |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
# ====================================================================== |
1716
|
|
|
|
|
|
|
|
1717
|
|
|
|
|
|
|
package SOAP::Parser; |
1718
|
|
|
|
|
|
|
|
1719
|
15
|
|
|
15
|
|
51
|
sub DESTROY { SOAP::Trace::objects('()') } |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
sub xmlparser { |
1722
|
18
|
|
|
18
|
|
64
|
my $self = shift; |
1723
|
|
|
|
|
|
|
return eval { |
1724
|
|
|
|
|
|
|
$SOAP::Constants::DO_NOT_USE_XML_PARSER |
1725
|
|
|
|
|
|
|
? undef |
1726
|
|
|
|
|
|
|
: do { |
1727
|
|
|
|
|
|
|
require XML::Parser; |
1728
|
|
|
|
|
|
|
XML::Parser->new() } |
1729
|
|
|
|
|
|
|
} |
1730
|
18
|
|
50
|
|
|
53
|
|| eval { require XML::Parser::Lite; XML::Parser::Lite->new } |
1731
|
|
|
|
|
|
|
|| die "XML::Parser is not @{[$SOAP::Constants::DO_NOT_USE_XML_PARSER ? 'used' : 'available']} and ", $@; |
1732
|
|
|
|
|
|
|
} |
1733
|
|
|
|
|
|
|
|
1734
|
|
|
|
|
|
|
sub parser { |
1735
|
18
|
|
|
18
|
|
78
|
my $self = shift->new; |
1736
|
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
|
# set the parser if passed |
1738
|
18
|
50
|
|
|
|
83
|
if (my $parser = shift) { |
1739
|
0
|
|
|
|
|
0
|
$self->{'_parser'} = shift; |
1740
|
0
|
|
|
|
|
0
|
return $self; |
1741
|
|
|
|
|
|
|
} |
1742
|
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
|
# else return the parser or use XML::Parser::Lite |
1744
|
18
|
|
33
|
|
|
241
|
return ($self->{'_parser'} ||= $self->xmlparser); |
1745
|
|
|
|
|
|
|
} |
1746
|
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
|
sub new { |
1748
|
39
|
|
|
39
|
|
89
|
my $self = shift; |
1749
|
39
|
100
|
|
|
|
152
|
return $self if ref $self; |
1750
|
21
|
|
|
|
|
42
|
my $class = $self; |
1751
|
21
|
|
|
|
|
67
|
SOAP::Trace::objects('()'); |
1752
|
21
|
|
|
|
|
151
|
return bless {_parser => shift}, $class; |
1753
|
|
|
|
|
|
|
} |
1754
|
|
|
|
|
|
|
|
1755
|
18
|
|
|
18
|
|
226
|
sub decode { SOAP::Trace::trace('()'); |
1756
|
18
|
|
|
|
|
37
|
my $self = shift; |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
$self->parser->setHandlers( |
1759
|
0
|
|
|
0
|
|
0
|
Final => sub { shift; $self->final(@_) }, |
|
0
|
|
|
|
|
0
|
|
1760
|
0
|
|
|
0
|
|
0
|
Start => sub { shift; $self->start(@_) }, |
|
0
|
|
|
|
|
0
|
|
1761
|
0
|
|
|
0
|
|
0
|
End => sub { shift; $self->end(@_) }, |
|
0
|
|
|
|
|
0
|
|
1762
|
0
|
|
|
0
|
|
0
|
Char => sub { shift; $self->char(@_) }, |
|
0
|
|
|
|
|
0
|
|
1763
|
0
|
|
|
0
|
|
0
|
ExternEnt => sub { shift; die "External entity (pointing to '$_[1]') is not allowed" }, |
|
0
|
|
|
|
|
0
|
|
1764
|
18
|
|
|
|
|
97
|
); |
1765
|
|
|
|
|
|
|
# my $parsed = $self->parser->parse($_[0]); |
1766
|
|
|
|
|
|
|
# return $parsed; |
1767
|
|
|
|
|
|
|
# |
1768
|
0
|
|
|
|
|
0
|
my $ret = undef; |
1769
|
0
|
|
|
|
|
0
|
eval { |
1770
|
0
|
|
|
|
|
0
|
$ret = $self->parser->parse($_[0]); |
1771
|
|
|
|
|
|
|
}; |
1772
|
0
|
0
|
|
|
|
0
|
if ($@) { |
1773
|
0
|
|
|
|
|
0
|
$self->final; # Clean up in the event of an error |
1774
|
0
|
|
|
|
|
0
|
die $@; # Pass back the error |
1775
|
|
|
|
|
|
|
} |
1776
|
0
|
|
|
|
|
0
|
return $ret; |
1777
|
|
|
|
|
|
|
} |
1778
|
|
|
|
|
|
|
|
1779
|
|
|
|
|
|
|
sub final { |
1780
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
# clean handlers, otherwise SOAP::Parser won't be deleted: |
1783
|
|
|
|
|
|
|
# it refers to XML::Parser which refers to subs from SOAP::Parser |
1784
|
|
|
|
|
|
|
# Thanks to Ryan Adams |
1785
|
|
|
|
|
|
|
# and Craig Johnston |
1786
|
|
|
|
|
|
|
# checked by number of tests in t/02-payload.t |
1787
|
|
|
|
|
|
|
|
1788
|
0
|
|
|
|
|
0
|
undef $self->{_values}; |
1789
|
0
|
|
|
|
|
0
|
$self->parser->setHandlers( |
1790
|
|
|
|
|
|
|
Final => undef, |
1791
|
|
|
|
|
|
|
Start => undef, |
1792
|
|
|
|
|
|
|
End => undef, |
1793
|
|
|
|
|
|
|
Char => undef, |
1794
|
|
|
|
|
|
|
ExternEnt => undef, |
1795
|
|
|
|
|
|
|
); |
1796
|
0
|
|
|
|
|
0
|
$self->{_done}; |
1797
|
|
|
|
|
|
|
} |
1798
|
|
|
|
|
|
|
|
1799
|
0
|
|
|
0
|
|
0
|
sub start { push @{shift->{_values}}, [shift, {@_}] } |
|
0
|
|
|
|
|
0
|
|
1800
|
|
|
|
|
|
|
|
1801
|
|
|
|
|
|
|
# string concatenation changed to arrays which should improve performance |
1802
|
|
|
|
|
|
|
# for strings with many entity-encoded elements. |
1803
|
|
|
|
|
|
|
# Thanks to Mathieu Longtin |
1804
|
0
|
|
|
0
|
|
0
|
sub char { push @{shift->{_values}->[-1]->[3]}, shift } |
|
0
|
|
|
|
|
0
|
|
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
sub end { |
1807
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1808
|
0
|
|
|
|
|
0
|
my $done = pop @{$self->{_values}}; |
|
0
|
|
|
|
|
0
|
|
1809
|
0
|
|
|
|
|
0
|
$done->[2] = defined $done->[3] |
1810
|
0
|
0
|
|
|
|
0
|
? join('',@{$done->[3]}) |
|
|
0
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
: '' unless ref $done->[2]; |
1812
|
0
|
|
|
|
|
0
|
undef $done->[3]; |
1813
|
0
|
|
|
|
|
0
|
@{$self->{_values}} |
|
0
|
|
|
|
|
0
|
|
1814
|
0
|
0
|
|
|
|
0
|
? (push @{$self->{_values}->[-1]->[2]}, $done) |
1815
|
|
|
|
|
|
|
: ($self->{_done} = $done); |
1816
|
|
|
|
|
|
|
} |
1817
|
|
|
|
|
|
|
|
1818
|
|
|
|
|
|
|
# ====================================================================== |
1819
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
package SOAP::SOM; |
1821
|
|
|
|
|
|
|
|
1822
|
25
|
|
|
25
|
|
275
|
use Carp (); |
|
25
|
|
|
|
|
59
|
|
|
25
|
|
|
|
|
607
|
|
1823
|
25
|
|
|
25
|
|
164
|
use SOAP::Lite::Utils; |
|
25
|
|
|
|
|
51
|
|
|
25
|
|
|
|
|
215
|
|
1824
|
|
|
|
|
|
|
|
1825
|
|
|
|
|
|
|
sub BEGIN { |
1826
|
25
|
|
|
25
|
|
146
|
no strict 'refs'; |
|
25
|
|
|
|
|
52
|
|
|
25
|
|
|
|
|
12402
|
|
1827
|
25
|
|
|
25
|
|
430
|
my %path = ( |
1828
|
|
|
|
|
|
|
root => '/', |
1829
|
|
|
|
|
|
|
envelope => '/Envelope', |
1830
|
|
|
|
|
|
|
body => '/Envelope/Body', |
1831
|
|
|
|
|
|
|
header => '/Envelope/Header', |
1832
|
|
|
|
|
|
|
headers => '/Envelope/Header/[>0]', |
1833
|
|
|
|
|
|
|
fault => '/Envelope/Body/Fault', |
1834
|
|
|
|
|
|
|
faultcode => '/Envelope/Body/Fault/faultcode', |
1835
|
|
|
|
|
|
|
faultstring => '/Envelope/Body/Fault/faultstring', |
1836
|
|
|
|
|
|
|
faultactor => '/Envelope/Body/Fault/faultactor', |
1837
|
|
|
|
|
|
|
faultdetail => '/Envelope/Body/Fault/detail', |
1838
|
|
|
|
|
|
|
); |
1839
|
25
|
|
|
|
|
174
|
for my $method (keys %path) { |
1840
|
|
|
|
|
|
|
*$method = sub { |
1841
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1842
|
0
|
0
|
|
|
|
0
|
ref $self or return $path{$method}; |
1843
|
0
|
0
|
|
|
|
0
|
Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; |
1844
|
0
|
|
|
|
|
0
|
return $self->valueof($path{$method}); |
1845
|
250
|
|
|
|
|
1671
|
}; |
1846
|
|
|
|
|
|
|
} |
1847
|
25
|
|
|
|
|
198
|
my %results = ( |
1848
|
|
|
|
|
|
|
method => '/Envelope/Body/[1]', |
1849
|
|
|
|
|
|
|
result => '/Envelope/Body/[1]/[1]', |
1850
|
|
|
|
|
|
|
freeform => '/Envelope/Body/[>0]', |
1851
|
|
|
|
|
|
|
paramsin => '/Envelope/Body/[1]/[>0]', |
1852
|
|
|
|
|
|
|
paramsall => '/Envelope/Body/[1]/[>0]', |
1853
|
|
|
|
|
|
|
paramsout => '/Envelope/Body/[1]/[>1]' |
1854
|
|
|
|
|
|
|
); |
1855
|
25
|
|
|
|
|
100
|
for my $method (keys %results) { |
1856
|
|
|
|
|
|
|
*$method = sub { |
1857
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1858
|
0
|
0
|
|
|
|
0
|
ref $self or return $results{$method}; |
1859
|
0
|
0
|
|
|
|
0
|
Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; |
1860
|
0
|
0
|
|
|
|
0
|
defined $self->fault ? return : return $self->valueof($results{$method}); |
1861
|
150
|
|
|
|
|
995
|
}; |
1862
|
|
|
|
|
|
|
} |
1863
|
|
|
|
|
|
|
|
1864
|
25
|
|
|
|
|
79
|
for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils |
1865
|
125
|
|
|
|
|
152
|
*$method = \&{'SOAP::Utils::'.$method}; |
|
125
|
|
|
|
|
689
|
|
1866
|
|
|
|
|
|
|
} |
1867
|
|
|
|
|
|
|
|
1868
|
25
|
|
|
|
|
186
|
__PACKAGE__->__mk_accessors('context'); |
1869
|
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
|
} |
1871
|
|
|
|
|
|
|
|
1872
|
|
|
|
|
|
|
# use object in boolean context return true/false on last match |
1873
|
|
|
|
|
|
|
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success'; |
1874
|
25
|
|
|
25
|
|
174
|
use overload fallback => 1, 'bool' => sub { @{shift->{_current}} > 0 }; |
|
25
|
|
|
0
|
|
51
|
|
|
25
|
|
|
|
|
324
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1875
|
|
|
|
|
|
|
|
1876
|
0
|
|
|
0
|
|
0
|
sub DESTROY { SOAP::Trace::objects('()') } |
1877
|
|
|
|
|
|
|
|
1878
|
|
|
|
|
|
|
sub new { |
1879
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1880
|
0
|
|
0
|
|
|
0
|
my $class = ref($self) || $self; |
1881
|
0
|
|
|
|
|
0
|
my $content = shift; |
1882
|
0
|
|
|
|
|
0
|
SOAP::Trace::objects('()'); |
1883
|
0
|
|
|
|
|
0
|
return bless { _content => $content, _current => [$content] } => $class; |
1884
|
|
|
|
|
|
|
} |
1885
|
|
|
|
|
|
|
|
1886
|
|
|
|
|
|
|
sub parts { |
1887
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1888
|
0
|
0
|
|
|
|
0
|
if (@_) { |
1889
|
0
|
|
|
|
|
0
|
$self->context->packager->parts(@_); |
1890
|
0
|
|
|
|
|
0
|
return $self; |
1891
|
|
|
|
|
|
|
} |
1892
|
|
|
|
|
|
|
else { |
1893
|
0
|
|
|
|
|
0
|
return $self->context->packager->parts; |
1894
|
|
|
|
|
|
|
} |
1895
|
|
|
|
|
|
|
} |
1896
|
|
|
|
|
|
|
|
1897
|
|
|
|
|
|
|
sub is_multipart { |
1898
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1899
|
0
|
|
|
|
|
0
|
return defined($self->parts); |
1900
|
|
|
|
|
|
|
} |
1901
|
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
|
sub current { |
1903
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1904
|
0
|
0
|
|
|
|
0
|
$self->{_current} = [@_], return $self if @_; |
1905
|
0
|
0
|
|
|
|
0
|
return wantarray ? @{$self->{_current}} : $self->{_current}->[0]; |
|
0
|
|
|
|
|
0
|
|
1906
|
|
|
|
|
|
|
} |
1907
|
|
|
|
|
|
|
|
1908
|
|
|
|
|
|
|
sub valueof { |
1909
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1910
|
0
|
|
|
|
|
0
|
local $self->{_current} = $self->{_current}; |
1911
|
0
|
0
|
|
|
|
0
|
$self->match(shift) if @_; |
1912
|
|
|
|
|
|
|
return wantarray |
1913
|
0
|
|
|
|
|
0
|
? map {o_value($_)} @{$self->{_current}} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1914
|
0
|
0
|
|
|
|
0
|
: @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef; |
|
|
0
|
|
|
|
|
|
1915
|
|
|
|
|
|
|
} |
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it |
1918
|
|
|
|
|
|
|
wantarray |
1919
|
0
|
|
|
|
|
0
|
? map { bless $_ => 'SOAP::Header' } shift->dataof(@_) |
1920
|
0
|
0
|
|
0
|
|
0
|
: do { # header returned by ->dataof can be undef in scalar context |
1921
|
0
|
|
|
|
|
0
|
my $header = shift->dataof(@_); |
1922
|
0
|
0
|
|
|
|
0
|
ref $header ? bless($header => 'SOAP::Header') : undef; |
1923
|
|
|
|
|
|
|
}; |
1924
|
|
|
|
|
|
|
} |
1925
|
|
|
|
|
|
|
|
1926
|
|
|
|
|
|
|
sub dataof { |
1927
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1928
|
0
|
|
|
|
|
0
|
local $self->{_current} = $self->{_current}; |
1929
|
0
|
0
|
|
|
|
0
|
$self->match(shift) if @_; |
1930
|
|
|
|
|
|
|
return wantarray |
1931
|
0
|
|
|
|
|
0
|
? map {$self->_as_data($_)} @{$self->{_current}} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1932
|
0
|
0
|
|
|
|
0
|
: @{$self->{_current}} |
|
|
0
|
|
|
|
|
|
1933
|
|
|
|
|
|
|
? $self->_as_data($self->{_current}->[0]) |
1934
|
|
|
|
|
|
|
: undef; |
1935
|
|
|
|
|
|
|
} |
1936
|
|
|
|
|
|
|
|
1937
|
|
|
|
|
|
|
sub namespaceuriof { |
1938
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1939
|
0
|
|
|
|
|
0
|
local $self->{_current} = $self->{_current}; |
1940
|
0
|
0
|
|
|
|
0
|
$self->match(shift) if @_; |
1941
|
|
|
|
|
|
|
return wantarray |
1942
|
0
|
|
|
|
|
0
|
? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1943
|
0
|
0
|
|
|
|
0
|
: @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef; |
|
|
0
|
|
|
|
|
|
1944
|
|
|
|
|
|
|
} |
1945
|
|
|
|
|
|
|
|
1946
|
|
|
|
|
|
|
#sub _as_data { |
1947
|
|
|
|
|
|
|
# my $self = shift; |
1948
|
|
|
|
|
|
|
# my $pointer = shift; |
1949
|
|
|
|
|
|
|
# |
1950
|
|
|
|
|
|
|
# SOAP::Data |
1951
|
|
|
|
|
|
|
# -> new(prefix => '', name => o_qname($pointer), name => o_lname($pointer), attr => o_lattr($pointer)) |
1952
|
|
|
|
|
|
|
# -> set_value(o_value($pointer)); |
1953
|
|
|
|
|
|
|
#} |
1954
|
|
|
|
|
|
|
|
1955
|
|
|
|
|
|
|
sub _as_data { |
1956
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1957
|
0
|
|
|
|
|
0
|
my $node = shift; |
1958
|
|
|
|
|
|
|
|
1959
|
0
|
|
|
|
|
0
|
my $data = SOAP::Data->new( prefix => '', |
1960
|
|
|
|
|
|
|
# name => o_qname has side effect: sets namespace ! |
1961
|
|
|
|
|
|
|
name => o_qname($node), |
1962
|
|
|
|
|
|
|
name => o_lname($node), |
1963
|
|
|
|
|
|
|
attr => o_lattr($node) ); |
1964
|
|
|
|
|
|
|
|
1965
|
0
|
0
|
|
|
|
0
|
if ( defined o_child($node) ) { |
1966
|
0
|
|
|
|
|
0
|
my @children; |
1967
|
0
|
|
|
|
|
0
|
foreach my $child ( @{ o_child($node) } ) { |
|
0
|
|
|
|
|
0
|
|
1968
|
0
|
|
|
|
|
0
|
push( @children, $self->_as_data($child) ); |
1969
|
|
|
|
|
|
|
} |
1970
|
0
|
|
|
|
|
0
|
$data->set_value( \SOAP::Data->value(@children) ); |
1971
|
|
|
|
|
|
|
} |
1972
|
|
|
|
|
|
|
else { |
1973
|
0
|
|
|
|
|
0
|
$data->set_value( o_value($node) ); |
1974
|
|
|
|
|
|
|
} |
1975
|
|
|
|
|
|
|
|
1976
|
0
|
|
|
|
|
0
|
return $data; |
1977
|
|
|
|
|
|
|
} |
1978
|
|
|
|
|
|
|
|
1979
|
|
|
|
|
|
|
|
1980
|
|
|
|
|
|
|
sub match { |
1981
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1982
|
0
|
|
|
|
|
0
|
my $path = shift; |
1983
|
|
|
|
|
|
|
$self->{_current} = [ |
1984
|
0
|
|
|
|
|
0
|
$path =~ s!^/!! || !@{$self->{_current}} |
1985
|
|
|
|
|
|
|
? $self->_traverse($self->{_content}, 1 => split '/' => $path) |
1986
|
0
|
0
|
0
|
|
|
0
|
: map {$self->_traverse_tree(o_child($_), split '/' => $path)} @{$self->{_current}} |
|
0
|
|
|
|
|
0
|
|
1987
|
|
|
|
|
|
|
]; |
1988
|
0
|
|
|
|
|
0
|
return $self; |
1989
|
|
|
|
|
|
|
} |
1990
|
|
|
|
|
|
|
|
1991
|
|
|
|
|
|
|
sub _traverse { |
1992
|
0
|
|
|
0
|
|
0
|
my ($self, $pointer, $itself, $path, @path) = @_; |
1993
|
|
|
|
|
|
|
|
1994
|
0
|
0
|
|
|
|
0
|
die "Incorrect parameter" unless $itself =~/^\d+$/; |
1995
|
|
|
|
|
|
|
|
1996
|
0
|
0
|
0
|
|
|
0
|
if ($path && substr($path, 0, 1) eq '{') { |
1997
|
0
|
|
0
|
|
|
0
|
$path = join '/', $path, shift @path while @path && $path !~ /}/; |
1998
|
|
|
|
|
|
|
} |
1999
|
|
|
|
|
|
|
|
2000
|
0
|
0
|
|
|
|
0
|
my($op, $num) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/ if defined $path; |
2001
|
|
|
|
|
|
|
|
2002
|
0
|
0
|
|
|
|
0
|
return $pointer unless defined $path; |
2003
|
|
|
|
|
|
|
|
2004
|
0
|
0
|
0
|
|
|
0
|
if (! $op) { |
|
|
0
|
|
|
|
|
|
2005
|
0
|
|
|
|
|
0
|
$op = '=='; |
2006
|
|
|
|
|
|
|
} |
2007
|
|
|
|
|
|
|
elsif ($op eq '=' || $op eq '!') { |
2008
|
0
|
|
|
|
|
0
|
$op .= '='; |
2009
|
|
|
|
|
|
|
} |
2010
|
0
|
|
0
|
|
|
0
|
my $numok = defined $num && eval "$itself $op $num"; |
2011
|
0
|
0
|
0
|
|
|
0
|
my $nameok = (o_lname($pointer) || '') =~ /(?:^|\})$path$/ if defined $path; # name can be with namespace |
2012
|
|
|
|
|
|
|
|
2013
|
0
|
|
|
|
|
0
|
my $anynode = $path eq ''; |
2014
|
0
|
0
|
|
|
|
0
|
unless ($anynode) { |
2015
|
0
|
0
|
|
|
|
0
|
if (@path) { |
2016
|
0
|
0
|
0
|
|
|
0
|
return if defined $num && !$numok || !defined $num && !$nameok; |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2017
|
|
|
|
|
|
|
} |
2018
|
|
|
|
|
|
|
else { |
2019
|
0
|
0
|
0
|
|
|
0
|
return $pointer if defined $num && $numok || !defined $num && $nameok; |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2020
|
0
|
|
|
|
|
0
|
return; |
2021
|
|
|
|
|
|
|
} |
2022
|
|
|
|
|
|
|
} |
2023
|
|
|
|
|
|
|
|
2024
|
0
|
|
|
|
|
0
|
my @walk; |
2025
|
0
|
0
|
|
|
|
0
|
push @walk, $self->_traverse_tree([$pointer], @path) if $anynode; |
2026
|
0
|
0
|
|
|
|
0
|
push @walk, $self->_traverse_tree(o_child($pointer), $anynode ? ($path, @path) : @path); |
2027
|
0
|
|
|
|
|
0
|
return @walk; |
2028
|
|
|
|
|
|
|
} |
2029
|
|
|
|
|
|
|
|
2030
|
|
|
|
|
|
|
sub _traverse_tree { |
2031
|
0
|
|
|
0
|
|
0
|
my ($self, $pointer, @path) = @_; |
2032
|
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
|
# can be list of children or value itself. Traverse only children |
2034
|
0
|
0
|
|
|
|
0
|
return unless ref $pointer eq 'ARRAY'; |
2035
|
|
|
|
|
|
|
|
2036
|
0
|
|
|
|
|
0
|
my $itself = 1; |
2037
|
|
|
|
|
|
|
|
2038
|
0
|
|
|
|
|
0
|
grep {defined} |
|
0
|
|
|
|
|
0
|
|
2039
|
0
|
0
|
0
|
|
|
0
|
map {$self->_traverse($_, $itself++, @path)} |
2040
|
0
|
|
|
|
|
0
|
grep {!ref o_lattr($_) || |
2041
|
|
|
|
|
|
|
!exists o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} || |
2042
|
|
|
|
|
|
|
o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ne '0'} |
2043
|
|
|
|
|
|
|
@$pointer; |
2044
|
|
|
|
|
|
|
} |
2045
|
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
|
# ====================================================================== |
2047
|
|
|
|
|
|
|
|
2048
|
|
|
|
|
|
|
package SOAP::Deserializer; |
2049
|
|
|
|
|
|
|
|
2050
|
25
|
|
|
25
|
|
45383
|
use vars qw(@ISA); |
|
25
|
|
|
|
|
64
|
|
|
25
|
|
|
|
|
1574
|
|
2051
|
25
|
|
|
25
|
|
224
|
use SOAP::Lite::Utils; |
|
25
|
|
|
|
|
50
|
|
|
25
|
|
|
|
|
177
|
|
2052
|
25
|
|
|
25
|
|
396
|
use Class::Inspector; |
|
25
|
|
|
|
|
178
|
|
|
25
|
|
|
|
|
804
|
|
2053
|
25
|
|
|
25
|
|
26983
|
use URI::Escape qw{uri_unescape}; |
|
25
|
|
|
|
|
58409
|
|
|
25
|
|
|
|
|
5523
|
|
2054
|
|
|
|
|
|
|
|
2055
|
|
|
|
|
|
|
@ISA = qw(SOAP::Cloneable); |
2056
|
|
|
|
|
|
|
|
2057
|
21
|
|
|
21
|
|
79
|
sub DESTROY { SOAP::Trace::objects('()') } |
2058
|
|
|
|
|
|
|
|
2059
|
|
|
|
|
|
|
sub BEGIN { |
2060
|
25
|
|
|
25
|
|
195
|
__PACKAGE__->__mk_accessors( qw(ids hrefs parts parser |
2061
|
|
|
|
|
|
|
base xmlschemas xmlschema context) ); |
2062
|
|
|
|
|
|
|
} |
2063
|
|
|
|
|
|
|
|
2064
|
|
|
|
|
|
|
# Cache (slow) Class::Inspector results |
2065
|
|
|
|
|
|
|
my %_class_loaded=(); |
2066
|
|
|
|
|
|
|
|
2067
|
|
|
|
|
|
|
sub new { |
2068
|
54
|
|
|
54
|
|
1429
|
my $self = shift; |
2069
|
54
|
100
|
|
|
|
205
|
return $self if ref $self; |
2070
|
21
|
|
|
|
|
54
|
my $class = $self; |
2071
|
21
|
|
|
|
|
73
|
SOAP::Trace::objects('()'); |
2072
|
84
|
|
|
|
|
560
|
return bless { |
2073
|
|
|
|
|
|
|
'_ids' => {}, |
2074
|
|
|
|
|
|
|
'_hrefs' => {}, |
2075
|
|
|
|
|
|
|
'_parser' => SOAP::Parser->new, |
2076
|
|
|
|
|
|
|
'_xmlschemas' => { |
2077
|
|
|
|
|
|
|
$SOAP::Constants::NS_APS => 'SOAP::XMLSchemaApacheSOAP::Deserializer', |
2078
|
|
|
|
|
|
|
# map { |
2079
|
|
|
|
|
|
|
# $_ => $SOAP::Constants::XML_SCHEMAS{$_} . '::Deserializer' |
2080
|
|
|
|
|
|
|
# } keys %SOAP::Constants::XML_SCHEMAS |
2081
|
|
|
|
|
|
|
map { |
2082
|
21
|
|
|
|
|
181
|
$_ => 'SOAP::Lite::Deserializer::' . $SOAP::Constants::XML_SCHEMA_OF{$_} |
2083
|
|
|
|
|
|
|
} keys %SOAP::Constants::XML_SCHEMA_OF |
2084
|
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
|
}, |
2086
|
|
|
|
|
|
|
}, $class; |
2087
|
|
|
|
|
|
|
} |
2088
|
|
|
|
|
|
|
|
2089
|
|
|
|
|
|
|
sub is_xml { |
2090
|
|
|
|
|
|
|
# Added check for envelope delivery. Fairly standard with MMDF and sendmail |
2091
|
|
|
|
|
|
|
# Thanks to Chris Davies |
2092
|
19
|
100
|
|
19
|
|
327
|
$_[1] =~ /^\s* || $_[1] !~ /^(?:[\w-]+:|From )/; |
2093
|
|
|
|
|
|
|
} |
2094
|
|
|
|
|
|
|
|
2095
|
|
|
|
|
|
|
sub baselocation { |
2096
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2097
|
0
|
|
|
|
|
0
|
my $location = shift; |
2098
|
0
|
0
|
|
|
|
0
|
if ($location) { |
2099
|
0
|
|
|
|
|
0
|
my $uri = URI->new($location); |
2100
|
|
|
|
|
|
|
# make absolute location if relative |
2101
|
0
|
0
|
0
|
|
|
0
|
$location = $uri->abs($self->base || 'thismessage:/')->as_string unless $uri->scheme; |
2102
|
|
|
|
|
|
|
} |
2103
|
0
|
|
|
|
|
0
|
return $location; |
2104
|
|
|
|
|
|
|
} |
2105
|
|
|
|
|
|
|
|
2106
|
|
|
|
|
|
|
# Returns the envelope and populates SOAP::Packager with parts |
2107
|
|
|
|
|
|
|
sub decode_parts { |
2108
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
2109
|
1
|
|
|
|
|
6
|
my $env = $self->context->packager->unpackage($_[0],$self->context); |
2110
|
0
|
|
|
|
|
0
|
my $body = $self->parser->decode($env); |
2111
|
|
|
|
|
|
|
# TODO - This shouldn't be here! This is packager specific! |
2112
|
|
|
|
|
|
|
# However this does need to pull out all the cid's |
2113
|
|
|
|
|
|
|
# to populate ids hash with. |
2114
|
0
|
|
|
|
|
0
|
foreach (@{$self->context->packager->parts}) { |
|
0
|
|
|
|
|
0
|
|
2115
|
0
|
|
|
|
|
0
|
my $data = $_->bodyhandle->as_string; |
2116
|
0
|
|
|
|
|
0
|
my $type = $_->head->mime_attr('Content-Type'); |
2117
|
0
|
|
|
|
|
0
|
my $location = $_->head->mime_attr('Content-Location'); |
2118
|
0
|
|
|
|
|
0
|
my $id = $_->head->mime_attr('Content-Id'); |
2119
|
0
|
|
|
|
|
0
|
$location = $self->baselocation($location); |
2120
|
0
|
0
|
0
|
|
|
0
|
my $part = lc($type) eq 'text/xml' && !$SOAP::Constants::DO_NOT_PROCESS_XML_IN_MIME |
2121
|
|
|
|
|
|
|
? $self->parser->decode($data) |
2122
|
|
|
|
|
|
|
: ['mimepart', {}, $data]; |
2123
|
|
|
|
|
|
|
# This below looks like unnecessary bloat!!! |
2124
|
|
|
|
|
|
|
# I should probably dereference the mimepart, provide a callback to get the string data |
2125
|
0
|
0
|
0
|
|
|
0
|
$self->ids->{$1} = $part if ($id && $id =~ m/^<([^>]+)>$/); # strip any leading and trailing brackets |
2126
|
0
|
0
|
|
|
|
0
|
$self->ids->{$location} = $part if $location; |
2127
|
|
|
|
|
|
|
} |
2128
|
0
|
|
|
|
|
0
|
return $body; |
2129
|
|
|
|
|
|
|
} |
2130
|
|
|
|
|
|
|
|
2131
|
|
|
|
|
|
|
# decode returns a parsed body in the form of an ARRAY |
2132
|
|
|
|
|
|
|
# each element of the ARRAY is a HASH, ARRAY or SCALAR |
2133
|
|
|
|
|
|
|
sub decode { |
2134
|
19
|
|
|
19
|
|
67
|
my $self = shift->new; # this actually is important |
2135
|
19
|
100
|
|
|
|
107
|
return $self->is_xml($_[0]) |
2136
|
|
|
|
|
|
|
? $self->parser->decode($_[0]) |
2137
|
|
|
|
|
|
|
: $self->decode_parts($_[0]); |
2138
|
|
|
|
|
|
|
} |
2139
|
|
|
|
|
|
|
|
2140
|
|
|
|
|
|
|
# deserialize returns a SOAP::SOM object and parses straight |
2141
|
|
|
|
|
|
|
# text as input |
2142
|
|
|
|
|
|
|
sub deserialize { |
2143
|
19
|
|
|
19
|
|
1694
|
SOAP::Trace::trace('()'); |
2144
|
19
|
|
|
|
|
101
|
my $self = shift->new; |
2145
|
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
|
# initialize |
2147
|
19
|
|
|
|
|
314
|
$self->hrefs({}); |
2148
|
19
|
|
|
|
|
95
|
$self->ids({}); |
2149
|
|
|
|
|
|
|
|
2150
|
|
|
|
|
|
|
# If the document is XML, then ids will be empty |
2151
|
|
|
|
|
|
|
# If the document is MIME, then ids will hold a list of cids |
2152
|
19
|
|
|
|
|
103
|
my $parsed = $self->decode($_[0]); |
2153
|
|
|
|
|
|
|
|
2154
|
|
|
|
|
|
|
# Having this code here makes multirefs in the Body work, but multirefs |
2155
|
|
|
|
|
|
|
# that reference XML fragments in a MIME part do not work. |
2156
|
0
|
0
|
|
|
|
0
|
if (keys %{$self->ids()}) { |
|
0
|
|
|
|
|
0
|
|
2157
|
0
|
|
|
|
|
0
|
$self->traverse_ids($parsed); |
2158
|
|
|
|
|
|
|
} |
2159
|
|
|
|
|
|
|
else { |
2160
|
|
|
|
|
|
|
# delay - set ids to be traversed later in decode_object, they only get |
2161
|
|
|
|
|
|
|
# traversed if an href is found that is referencing an id. |
2162
|
0
|
|
|
|
|
0
|
$self->ids($parsed); |
2163
|
|
|
|
|
|
|
} |
2164
|
0
|
|
|
|
|
0
|
$self->decode_object($parsed); |
2165
|
0
|
|
|
|
|
0
|
my $som = SOAP::SOM->new($parsed); |
2166
|
0
|
|
|
|
|
0
|
$som->context($self->context); # TODO - try removing this and see if it works! |
2167
|
0
|
|
|
|
|
0
|
return $som; |
2168
|
|
|
|
|
|
|
} |
2169
|
|
|
|
|
|
|
|
2170
|
|
|
|
|
|
|
sub traverse_ids { |
2171
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2172
|
0
|
|
|
|
|
0
|
my $ref = shift; |
2173
|
0
|
|
|
|
|
0
|
my($undef, $attrs, $children) = @$ref; |
2174
|
|
|
|
|
|
|
# ^^^^^^ to fix nasty error on Mac platform (Carl K. Cunningham) |
2175
|
0
|
0
|
|
|
|
0
|
$self->ids->{$attrs->{'id'}} = $ref if exists $attrs->{'id'}; |
2176
|
0
|
0
|
|
|
|
0
|
return unless ref $children; |
2177
|
0
|
|
|
|
|
0
|
for (@$children) { |
2178
|
0
|
|
|
|
|
0
|
$self->traverse_ids($_) |
2179
|
|
|
|
|
|
|
}; |
2180
|
|
|
|
|
|
|
} |
2181
|
|
|
|
|
|
|
|
2182
|
25
|
|
|
25
|
|
466
|
use constant _ATTRS => 6; |
|
25
|
|
|
|
|
54
|
|
|
25
|
|
|
|
|
6622
|
|
2183
|
25
|
|
|
25
|
|
154
|
use constant _NAME => 5; |
|
25
|
|
|
|
|
1454
|
|
|
25
|
|
|
|
|
3180
|
|
2184
|
|
|
|
|
|
|
|
2185
|
|
|
|
|
|
|
sub decode_object { |
2186
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2187
|
0
|
|
|
|
|
0
|
my $ref = shift; |
2188
|
0
|
|
|
|
|
0
|
my($name, $attrs_ref, $children, $value) = @$ref; |
2189
|
|
|
|
|
|
|
|
2190
|
0
|
|
|
|
|
0
|
my %attrs = %{ $attrs_ref }; |
|
0
|
|
|
|
|
0
|
|
2191
|
|
|
|
|
|
|
|
2192
|
0
|
|
|
|
|
0
|
$ref->[ _ATTRS ] = \%attrs; # make a copy for long attributes |
2193
|
|
|
|
|
|
|
|
2194
|
25
|
|
|
25
|
|
1652
|
use vars qw(%uris); |
|
25
|
|
|
|
|
101
|
|
|
25
|
|
|
|
|
20144
|
|
2195
|
|
|
|
|
|
|
local %uris = (%uris, map { |
2196
|
0
|
|
|
|
|
0
|
do { (my $ns = $_) =~ s/^xmlns:?//; $ns } => delete $attrs{$_} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2197
|
0
|
|
|
|
|
0
|
} grep {/^xmlns(:|$)/} keys %attrs); |
2198
|
|
|
|
|
|
|
|
2199
|
0
|
|
|
|
|
0
|
foreach (keys %attrs) { |
2200
|
0
|
0
|
|
|
|
0
|
next unless m/^($SOAP::Constants::NSMASK?):($SOAP::Constants::NSMASK)$/; |
2201
|
|
|
|
|
|
|
|
2202
|
|
|
|
|
|
|
$1 =~ /^[xX][mM][lL]/ || |
2203
|
|
|
|
|
|
|
$uris{$1} && |
2204
|
0
|
0
|
0
|
|
|
0
|
do { |
|
|
|
0
|
|
|
|
|
2205
|
0
|
|
|
|
|
0
|
$attrs{SOAP::Utils::longname($uris{$1}, $2)} = do { |
2206
|
0
|
|
|
|
|
0
|
my $value = $attrs{$_}; |
2207
|
0
|
0
|
0
|
|
|
0
|
$2 ne 'type' && $2 ne 'arrayType' |
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2208
|
|
|
|
|
|
|
? $value |
2209
|
|
|
|
|
|
|
: SOAP::Utils::longname($value =~ m/^($SOAP::Constants::NSMASK?):(${SOAP::Constants::NSMASK}(?:\[[\d,]*\])*)/ |
2210
|
|
|
|
|
|
|
? ($uris{$1} || die("Unresolved prefix '$1' for attribute value '$value'\n"), $2) |
2211
|
|
|
|
|
|
|
: ($uris{''} || die("Unspecified namespace for type '$value'\n"), $value) |
2212
|
|
|
|
|
|
|
); |
2213
|
|
|
|
|
|
|
}; |
2214
|
0
|
|
|
|
|
0
|
1; |
2215
|
|
|
|
|
|
|
} |
2216
|
|
|
|
|
|
|
|| die "Unresolved prefix '$1' for attribute '$_'\n"; |
2217
|
|
|
|
|
|
|
} |
2218
|
|
|
|
|
|
|
|
2219
|
|
|
|
|
|
|
# and now check the element |
2220
|
0
|
0
|
|
|
|
0
|
my $ns = ($name =~ s/^($SOAP::Constants::NSMASK?):// ? $1 : ''); |
2221
|
0
|
0
|
0
|
|
|
0
|
$ref->[ _NAME ] = SOAP::Utils::longname( |
|
|
0
|
|
|
|
|
|
2222
|
|
|
|
|
|
|
$ns |
2223
|
|
|
|
|
|
|
? ($uris{$ns} || die "Unresolved prefix '$ns' for element '$name'\n") |
2224
|
|
|
|
|
|
|
: (defined $uris{''} ? $uris{''} : undef), |
2225
|
|
|
|
|
|
|
$name |
2226
|
|
|
|
|
|
|
); |
2227
|
|
|
|
|
|
|
|
2228
|
0
|
0
|
|
|
|
0
|
($children, $value) = (undef, $children) unless ref $children; |
2229
|
|
|
|
|
|
|
|
2230
|
0
|
|
|
|
|
0
|
return $name => ($ref->[4] = $self->decode_value( |
2231
|
|
|
|
|
|
|
[$ref->[ _NAME ], \%attrs, $children, $value] |
2232
|
|
|
|
|
|
|
)); |
2233
|
|
|
|
|
|
|
} |
2234
|
|
|
|
|
|
|
|
2235
|
|
|
|
|
|
|
sub decode_value { |
2236
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2237
|
0
|
|
|
|
|
0
|
my($name, $attrs, $children, $value) = @{ $_[0] }; |
|
0
|
|
|
|
|
0
|
|
2238
|
|
|
|
|
|
|
|
2239
|
|
|
|
|
|
|
# check SOAP version if applicable |
2240
|
25
|
|
0
|
25
|
|
171
|
use vars '$level'; local $level = $level || 0; |
|
25
|
|
|
|
|
53
|
|
|
25
|
|
|
|
|
17753
|
|
|
0
|
|
|
|
|
0
|
|
2241
|
0
|
0
|
|
|
|
0
|
if (++$level == 1) { |
2242
|
0
|
|
|
|
|
0
|
my($namespace, $envelope) = SOAP::Utils::splitlongname($name); |
2243
|
0
|
0
|
0
|
|
|
0
|
SOAP::Lite->soapversion($namespace) if $envelope eq 'Envelope' && $namespace; |
2244
|
|
|
|
|
|
|
} |
2245
|
|
|
|
|
|
|
|
2246
|
0
|
0
|
|
|
|
0
|
if (exists $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}) { |
2247
|
|
|
|
|
|
|
# check encodingStyle |
2248
|
|
|
|
|
|
|
# future versions may bind deserializer to encodingStyle |
2249
|
0
|
|
|
|
|
0
|
my $encodingStyle = $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}; |
2250
|
|
|
|
|
|
|
# TODO - SOAP 1.2 and 1.1 have different rules about valid encodingStyle values |
2251
|
|
|
|
|
|
|
# For example, in 1.1 - any http://schemas.xmlsoap.org/soap/encoding/* |
2252
|
|
|
|
|
|
|
# value is valid |
2253
|
0
|
0
|
0
|
|
|
0
|
if (defined $encodingStyle && length($encodingStyle)) { |
2254
|
0
|
|
|
|
|
0
|
my %styles = map { $_ => undef } @SOAP::Constants::SUPPORTED_ENCODING_STYLES; |
|
0
|
|
|
|
|
0
|
|
2255
|
0
|
|
|
|
|
0
|
my $found = 0; |
2256
|
0
|
|
|
|
|
0
|
foreach my $e (split(/ +/,$encodingStyle)) { |
2257
|
0
|
0
|
|
|
|
0
|
if (exists $styles{$e}) { |
2258
|
0
|
|
|
|
|
0
|
$found ++; |
2259
|
|
|
|
|
|
|
} |
2260
|
|
|
|
|
|
|
} |
2261
|
0
|
0
|
0
|
|
|
0
|
die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'" |
|
|
|
0
|
|
|
|
|
2262
|
|
|
|
|
|
|
if (! $found) && !(SOAP::Lite->soapversion == 1.1 && $encodingStyle =~ /(?:^|\b)$SOAP::Constants::NS_ENC/); |
2263
|
|
|
|
|
|
|
} |
2264
|
|
|
|
|
|
|
} |
2265
|
25
|
|
|
25
|
|
404
|
use vars '$arraytype'; # type of Array element specified on Array itself |
|
25
|
|
|
|
|
1335
|
|
|
25
|
|
|
|
|
6145
|
|
2266
|
|
|
|
|
|
|
# either specified with xsi:type, or or array element |
2267
|
0
|
|
|
|
|
0
|
my ($type) = grep { defined } |
|
0
|
|
|
|
|
0
|
|
2268
|
0
|
0
|
|
|
|
0
|
map($attrs->{$_}, sort grep {/^\{$SOAP::Constants::NS_XSI_ALL\}type$/o} keys %$attrs), |
2269
|
|
|
|
|
|
|
$name =~ /^\{$SOAP::Constants::NS_ENC\}/ ? $name : $arraytype; |
2270
|
0
|
|
|
|
|
0
|
local $arraytype; # it's used only for one level, we don't need it anymore |
2271
|
|
|
|
|
|
|
|
2272
|
|
|
|
|
|
|
# $name is not used here since type should be encoded as type, not as name |
2273
|
0
|
0
|
|
|
|
0
|
my ($schema, $class) = SOAP::Utils::splitlongname($type) if $type; |
2274
|
0
|
|
0
|
|
|
0
|
my $schemaclass = defined($schema) && $self->{ _xmlschemas }->{$schema} |
2275
|
|
|
|
|
|
|
|| $self; |
2276
|
|
|
|
|
|
|
|
2277
|
0
|
0
|
|
|
|
0
|
if (! exists $_class_loaded{$schemaclass}) { |
2278
|
25
|
|
|
25
|
|
160
|
no strict qw(refs); |
|
25
|
|
|
|
|
49
|
|
|
25
|
|
|
|
|
49925
|
|
2279
|
0
|
0
|
|
|
|
0
|
if (! Class::Inspector->loaded($schemaclass) ) { |
2280
|
0
|
0
|
0
|
|
|
0
|
eval "require $schemaclass" or die $@ if not ref $schemaclass; |
2281
|
|
|
|
|
|
|
} |
2282
|
0
|
|
|
|
|
0
|
$_class_loaded{$schemaclass} = undef; |
2283
|
|
|
|
|
|
|
} |
2284
|
|
|
|
|
|
|
|
2285
|
|
|
|
|
|
|
# store schema that is used in parsed message |
2286
|
0
|
0
|
0
|
|
|
0
|
$self->{ _xmlschema } = $schema if ($schema) && $schema =~ /XMLSchema/; |
2287
|
|
|
|
|
|
|
|
2288
|
|
|
|
|
|
|
# don't use class/type if anyType/ur-type is specified on wire |
2289
|
0
|
0
|
0
|
|
|
0
|
undef $class |
2290
|
|
|
|
|
|
|
if $schemaclass->can('anyTypeValue') |
2291
|
|
|
|
|
|
|
&& $schemaclass->anyTypeValue eq $class; |
2292
|
|
|
|
|
|
|
|
2293
|
0
|
|
0
|
|
|
0
|
my $method = 'as_' . ($class || '-'); # dummy type if not defined |
2294
|
0
|
0
|
|
|
|
0
|
$class =~ s/__|\./::/g if $class; |
2295
|
|
|
|
|
|
|
|
2296
|
0
|
|
|
|
|
0
|
my $id = $attrs->{id}; |
2297
|
0
|
0
|
0
|
|
|
0
|
if (defined $id && exists $self->hrefs->{$id}) { |
|
|
0
|
|
|
|
|
|
2298
|
0
|
|
|
|
|
0
|
return $self->hrefs->{$id}; |
2299
|
|
|
|
|
|
|
} |
2300
|
|
|
|
|
|
|
elsif (exists $attrs->{href}) { |
2301
|
0
|
|
|
|
|
0
|
(my $id = delete $attrs->{href}) =~ s/^(#|cid:|uuid:)?//; |
2302
|
0
|
|
|
|
|
0
|
my $type=$1; |
2303
|
0
|
0
|
0
|
|
|
0
|
$id=uri_unescape($id) if (defined($type) and $type eq 'cid:'); |
2304
|
|
|
|
|
|
|
# convert to absolute if not internal '#' or 'cid:' |
2305
|
0
|
0
|
|
|
|
0
|
$id = $self->baselocation($id) unless $type; |
2306
|
0
|
0
|
|
|
|
0
|
return $self->hrefs->{$id} if exists $self->hrefs->{$id}; |
2307
|
|
|
|
|
|
|
# First time optimization. we don't traverse IDs unless asked for it. |
2308
|
|
|
|
|
|
|
# This is where traversing id's is delayed from before |
2309
|
|
|
|
|
|
|
# - the first time through - ids should contain a copy of the parsed XML |
2310
|
|
|
|
|
|
|
# structure! seems silly to make so many copies |
2311
|
0
|
|
|
|
|
0
|
my $ids = $self->ids; |
2312
|
0
|
0
|
|
|
|
0
|
if (ref($ids) ne 'HASH') { |
2313
|
0
|
|
|
|
|
0
|
$self->ids({}); # reset list of ids first time through |
2314
|
0
|
|
|
|
|
0
|
$self->traverse_ids($ids); |
2315
|
|
|
|
|
|
|
} |
2316
|
0
|
0
|
|
|
|
0
|
if (exists($self->ids->{$id})) { |
2317
|
0
|
|
|
|
|
0
|
my $obj = ($self->decode_object(delete($self->ids->{$id})))[1]; |
2318
|
0
|
|
|
|
|
0
|
return $self->hrefs->{$id} = $obj; |
2319
|
|
|
|
|
|
|
} |
2320
|
|
|
|
|
|
|
else { |
2321
|
0
|
|
|
|
|
0
|
die "Unresolved (wrong?) href ($id) in element '$name'\n"; |
2322
|
|
|
|
|
|
|
} |
2323
|
|
|
|
|
|
|
} |
2324
|
|
|
|
|
|
|
|
2325
|
|
|
|
|
|
|
return undef if grep { |
2326
|
0
|
0
|
|
|
|
0
|
/^$SOAP::Constants::NS_XSI_NILS$/ && do { |
|
0
|
0
|
|
|
|
0
|
|
2327
|
0
|
|
0
|
|
|
0
|
my $class = $self->xmlschemas->{ $1 || $2 }; |
2328
|
0
|
0
|
|
|
|
0
|
eval "require $class" or die @$;; |
2329
|
0
|
|
|
|
|
0
|
$class->as_undef($attrs->{$_}) |
2330
|
|
|
|
|
|
|
} |
2331
|
|
|
|
|
|
|
} keys %$attrs; |
2332
|
|
|
|
|
|
|
|
2333
|
|
|
|
|
|
|
# try to handle with typecasting |
2334
|
0
|
|
|
|
|
0
|
my $res = $self->typecast($value, $name, $attrs, $children, $type); |
2335
|
0
|
0
|
|
|
|
0
|
return $res if defined $res; |
2336
|
|
|
|
|
|
|
|
2337
|
|
|
|
|
|
|
# ok, continue with others |
2338
|
0
|
0
|
0
|
|
|
0
|
if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) { |
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2339
|
0
|
|
|
|
|
0
|
my $res = []; |
2340
|
0
|
0
|
|
|
|
0
|
$self->hrefs->{$id} = $res if defined $id; |
2341
|
|
|
|
|
|
|
|
2342
|
|
|
|
|
|
|
# check for arrayType which could be [1], [,2][5] or [] |
2343
|
|
|
|
|
|
|
# [,][1] will NOT be allowed right now (multidimensional sparse array) |
2344
|
0
|
0
|
|
|
|
0
|
my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"} |
2345
|
|
|
|
|
|
|
=~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/ |
2346
|
0
|
|
|
|
|
0
|
or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!; |
2347
|
|
|
|
|
|
|
|
2348
|
0
|
0
|
|
|
|
0
|
my @dimensions = map { $_ || undef } split /,/, $multisize; |
|
0
|
|
|
|
|
0
|
|
2349
|
0
|
|
|
|
|
0
|
my $size = 1; |
2350
|
0
|
|
0
|
|
|
0
|
foreach (@dimensions) { $size *= $_ || 0 } |
|
0
|
|
|
|
|
0
|
|
2351
|
|
|
|
|
|
|
|
2352
|
|
|
|
|
|
|
# TODO ähm, shouldn't this local be my? |
2353
|
0
|
|
|
|
|
0
|
local $arraytype = $type; |
2354
|
|
|
|
|
|
|
|
2355
|
|
|
|
|
|
|
# multidimensional |
2356
|
0
|
0
|
|
|
|
0
|
if ($multisize =~ /,/) { |
2357
|
0
|
|
|
|
|
0
|
@$res = splitarray( |
2358
|
|
|
|
|
|
|
[@dimensions], |
2359
|
0
|
0
|
|
|
|
0
|
[map { scalar(($self->decode_object($_))[1]) } @{$children || []}] |
|
0
|
|
|
|
|
0
|
|
2360
|
|
|
|
|
|
|
); |
2361
|
|
|
|
|
|
|
} |
2362
|
|
|
|
|
|
|
# normal |
2363
|
|
|
|
|
|
|
else { |
2364
|
0
|
0
|
|
|
|
0
|
@$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2365
|
|
|
|
|
|
|
} |
2366
|
|
|
|
|
|
|
|
2367
|
|
|
|
|
|
|
# sparse (position) |
2368
|
0
|
0
|
0
|
|
|
0
|
if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) { |
2369
|
0
|
|
|
|
|
0
|
my @new; |
2370
|
0
|
|
|
|
|
0
|
for (my $pos = 0; $pos < @$children; $pos++) { |
2371
|
|
|
|
|
|
|
# TBD implement position in multidimensional array |
2372
|
0
|
0
|
|
|
|
0
|
my($position) = SOAP::Utils::o_lattr($children->[$pos])->{"{$SOAP::Constants::NS_ENC}position"} =~ /^\[(\d+)\]$/ |
2373
|
|
|
|
|
|
|
or die "Position must be specified for all elements of sparse array\n"; |
2374
|
0
|
|
|
|
|
0
|
$new[$position] = $res->[$pos]; |
2375
|
|
|
|
|
|
|
} |
2376
|
0
|
|
|
|
|
0
|
@$res = @new; |
2377
|
|
|
|
|
|
|
} |
2378
|
|
|
|
|
|
|
|
2379
|
|
|
|
|
|
|
# partially transmitted (offset) |
2380
|
|
|
|
|
|
|
# TBD implement offset in multidimensional array |
2381
|
0
|
0
|
|
|
|
0
|
my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/ |
2382
|
|
|
|
|
|
|
if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"}; |
2383
|
0
|
0
|
|
|
|
0
|
unshift(@$res, (undef) x $offset) if $offset; |
2384
|
|
|
|
|
|
|
|
2385
|
0
|
0
|
0
|
|
|
0
|
die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n" |
|
0
|
|
|
|
|
0
|
|
2386
|
|
|
|
|
|
|
if $multisize && $size < @$res; |
2387
|
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
|
# extend the array if number of elements is specified |
2389
|
0
|
0
|
0
|
|
|
0
|
$#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0]; |
2390
|
|
|
|
|
|
|
|
2391
|
0
|
0
|
0
|
|
|
0
|
return defined $class && $class ne 'Array' ? bless($res => $class) : $res; |
2392
|
|
|
|
|
|
|
|
2393
|
|
|
|
|
|
|
} |
2394
|
|
|
|
|
|
|
elsif ($name =~ /^\{$SOAP::Constants::NS_ENC\}Struct$/ |
2395
|
|
|
|
|
|
|
|| !$schemaclass->can($method) |
2396
|
|
|
|
|
|
|
&& (ref $children || defined $class && $value =~ /^\s*$/)) { |
2397
|
0
|
|
|
|
|
0
|
my $res = {}; |
2398
|
0
|
0
|
|
|
|
0
|
$self->hrefs->{$id} = $res if defined $id; |
2399
|
|
|
|
|
|
|
|
2400
|
|
|
|
|
|
|
# Patch code introduced in 0.65 - deserializes array properly |
2401
|
|
|
|
|
|
|
# Decode each element of the struct. |
2402
|
0
|
|
|
|
|
0
|
my %child_count_of = (); |
2403
|
0
|
0
|
|
|
|
0
|
foreach my $child (@{$children || []}) { |
|
0
|
|
|
|
|
0
|
|
2404
|
0
|
|
|
|
|
0
|
my ($child_name, $child_value) = $self->decode_object($child); |
2405
|
|
|
|
|
|
|
# Store the decoded element in the struct. If the element name is |
2406
|
|
|
|
|
|
|
# repeated, replace the previous scalar value with a new array |
2407
|
|
|
|
|
|
|
# containing both values. |
2408
|
0
|
0
|
|
|
|
0
|
if (not $child_count_of{$child_name}) { |
|
|
0
|
|
|
|
|
|
2409
|
|
|
|
|
|
|
# first time to see this value: use scalar |
2410
|
0
|
|
|
|
|
0
|
$res->{$child_name} = $child_value; |
2411
|
|
|
|
|
|
|
} |
2412
|
|
|
|
|
|
|
elsif ($child_count_of{$child_name} == 1) { |
2413
|
|
|
|
|
|
|
# second time to see this value: convert scalar to array |
2414
|
0
|
|
|
|
|
0
|
$res->{$child_name} = [ $res->{$child_name}, $child_value ]; |
2415
|
|
|
|
|
|
|
} |
2416
|
|
|
|
|
|
|
else { |
2417
|
|
|
|
|
|
|
# already have an array: append to it |
2418
|
0
|
|
|
|
|
0
|
push @{$res->{$child_name}}, $child_value; |
|
0
|
|
|
|
|
0
|
|
2419
|
|
|
|
|
|
|
} |
2420
|
0
|
|
|
|
|
0
|
$child_count_of{$child_name}++; |
2421
|
|
|
|
|
|
|
} |
2422
|
|
|
|
|
|
|
# End patch code |
2423
|
|
|
|
|
|
|
|
2424
|
0
|
0
|
0
|
|
|
0
|
return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res; |
2425
|
|
|
|
|
|
|
} |
2426
|
|
|
|
|
|
|
else { |
2427
|
0
|
|
|
|
|
0
|
my $res; |
2428
|
0
|
0
|
|
|
|
0
|
if (my $method_ref = $schemaclass->can($method)) { |
2429
|
0
|
|
|
|
|
0
|
$res = $method_ref->($self, $value, $name, $attrs, $children, $type); |
2430
|
|
|
|
|
|
|
} |
2431
|
|
|
|
|
|
|
else { |
2432
|
0
|
|
|
|
|
0
|
$res = $self->typecast($value, $name, $attrs, $children, $type); |
2433
|
0
|
0
|
|
|
|
0
|
$res = $class ? die "Unrecognized type '$type'\n" : $value |
|
|
0
|
|
|
|
|
|
2434
|
|
|
|
|
|
|
unless defined $res; |
2435
|
|
|
|
|
|
|
} |
2436
|
0
|
0
|
|
|
|
0
|
$self->hrefs->{$id} = $res if defined $id; |
2437
|
0
|
|
|
|
|
0
|
return $res; |
2438
|
|
|
|
|
|
|
} |
2439
|
|
|
|
|
|
|
} |
2440
|
|
|
|
|
|
|
|
2441
|
|
|
|
|
|
|
sub splitarray { |
2442
|
0
|
|
|
0
|
|
0
|
my @sizes = @{+shift}; |
|
0
|
|
|
|
|
0
|
|
2443
|
0
|
|
|
|
|
0
|
my $size = shift @sizes; |
2444
|
0
|
|
|
|
|
0
|
my $array = shift; |
2445
|
|
|
|
|
|
|
|
2446
|
0
|
0
|
|
|
|
0
|
return splice(@$array, 0, $size) unless @sizes; |
2447
|
0
|
|
|
|
|
0
|
my @array = (); |
2448
|
0
|
|
0
|
|
|
0
|
push @array, [ |
|
|
|
0
|
|
|
|
|
2449
|
|
|
|
|
|
|
splitarray([@sizes], $array) |
2450
|
|
|
|
|
|
|
] while @$array && (!defined $size || $size--); |
2451
|
0
|
|
|
|
|
0
|
return @array; |
2452
|
|
|
|
|
|
|
} |
2453
|
|
|
|
|
|
|
|
2454
|
0
|
|
|
0
|
|
0
|
sub typecast { } # typecast is called for both objects AND scalar types |
2455
|
|
|
|
|
|
|
# check ref of the second parameter (first is the object) |
2456
|
|
|
|
|
|
|
# return undef if you don't want to handle it |
2457
|
|
|
|
|
|
|
|
2458
|
|
|
|
|
|
|
# ====================================================================== |
2459
|
|
|
|
|
|
|
|
2460
|
|
|
|
|
|
|
package SOAP::Client; |
2461
|
|
|
|
|
|
|
|
2462
|
|
|
|
|
|
|
|
2463
|
25
|
|
|
25
|
|
206
|
use SOAP::Lite::Utils; |
|
25
|
|
|
|
|
62
|
|
|
25
|
|
|
|
|
295
|
|
2464
|
|
|
|
|
|
|
|
2465
|
|
|
|
|
|
|
$VERSION = $SOAP::Lite::VERSION; |
2466
|
|
|
|
|
|
|
sub BEGIN { |
2467
|
25
|
|
|
25
|
|
174
|
__PACKAGE__->__mk_accessors(qw(endpoint code message |
2468
|
|
|
|
|
|
|
is_success status options)); |
2469
|
|
|
|
|
|
|
} |
2470
|
|
|
|
|
|
|
|
2471
|
|
|
|
|
|
|
# ====================================================================== |
2472
|
|
|
|
|
|
|
|
2473
|
|
|
|
|
|
|
package SOAP::Server::Object; |
2474
|
|
|
|
|
|
|
|
2475
|
|
|
|
|
|
|
sub gen_id; *gen_id = \&SOAP::Serializer::gen_id; |
2476
|
|
|
|
|
|
|
|
2477
|
|
|
|
|
|
|
my %alive; |
2478
|
|
|
|
|
|
|
my %objects; |
2479
|
|
|
|
|
|
|
|
2480
|
|
|
|
|
|
|
sub objects_by_reference { |
2481
|
0
|
|
|
0
|
|
0
|
shift; |
2482
|
0
|
|
|
|
|
0
|
while (@_) { |
2483
|
|
|
|
|
|
|
@alive{shift()} = ref $_[0] |
2484
|
|
|
|
|
|
|
? shift |
2485
|
|
|
|
|
|
|
: sub { |
2486
|
0
|
0
|
|
0
|
|
0
|
$_[1]-$_[$_[5] ? 5 : 4] > $SOAP::Constants::OBJS_BY_REF_KEEPALIVE |
2487
|
|
|
|
|
|
|
} |
2488
|
0
|
0
|
|
|
|
0
|
} |
2489
|
0
|
|
|
|
|
0
|
keys %alive; |
2490
|
|
|
|
|
|
|
} |
2491
|
|
|
|
|
|
|
|
2492
|
|
|
|
|
|
|
sub reference { |
2493
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2494
|
0
|
|
|
|
|
0
|
my $stamp = time; |
2495
|
0
|
|
|
|
|
0
|
my $object = shift; |
2496
|
0
|
|
|
|
|
0
|
my $id = $stamp . $self->gen_id($object); |
2497
|
|
|
|
|
|
|
|
2498
|
|
|
|
|
|
|
# this is code for garbage collection |
2499
|
0
|
|
|
|
|
0
|
my $time = time; |
2500
|
0
|
|
|
|
|
0
|
my $type = ref $object; |
2501
|
0
|
|
|
|
|
0
|
my @objects = grep { $objects{$_}->[1] eq $type } keys %objects; |
|
0
|
|
|
|
|
0
|
|
2502
|
0
|
|
|
|
|
0
|
for (grep { $alive{$type}->(scalar @objects, $time, @{$objects{$_}}) } @objects) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2503
|
0
|
|
|
|
|
0
|
delete $objects{$_}; |
2504
|
|
|
|
|
|
|
} |
2505
|
|
|
|
|
|
|
|
2506
|
0
|
|
|
|
|
0
|
$objects{$id} = [$object, $type, $stamp]; |
2507
|
0
|
|
|
|
|
0
|
bless { id => $id } => ref $object; |
2508
|
|
|
|
|
|
|
} |
2509
|
|
|
|
|
|
|
|
2510
|
|
|
|
|
|
|
sub references { |
2511
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2512
|
0
|
0
|
|
|
|
0
|
return @_ unless %alive; # small optimization |
2513
|
0
|
0
|
0
|
|
|
0
|
return map { |
2514
|
0
|
|
|
|
|
0
|
ref($_) && exists $alive{ref $_} |
2515
|
|
|
|
|
|
|
? $self->reference($_) |
2516
|
|
|
|
|
|
|
: $_ |
2517
|
|
|
|
|
|
|
} @_; |
2518
|
|
|
|
|
|
|
} |
2519
|
|
|
|
|
|
|
|
2520
|
|
|
|
|
|
|
sub object { |
2521
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2522
|
0
|
|
0
|
|
|
0
|
my $class = ref($self) || $self; |
2523
|
0
|
|
|
|
|
0
|
my $object = shift; |
2524
|
0
|
0
|
0
|
|
|
0
|
return $object unless ref($object) && $alive{ref $object} && exists $object->{id}; |
|
|
|
0
|
|
|
|
|
2525
|
|
|
|
|
|
|
|
2526
|
0
|
|
|
|
|
0
|
my $reference = $objects{$object->{id}}; |
2527
|
0
|
0
|
|
|
|
0
|
die "Object with specified id couldn't be found\n" unless ref $reference->[0]; |
2528
|
|
|
|
|
|
|
|
2529
|
0
|
|
|
|
|
0
|
$reference->[3] = time; # last access time |
2530
|
0
|
|
|
|
|
0
|
return $reference->[0]; # reference to actual object |
2531
|
|
|
|
|
|
|
} |
2532
|
|
|
|
|
|
|
|
2533
|
|
|
|
|
|
|
sub objects { |
2534
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2535
|
0
|
0
|
|
|
|
0
|
return @_ unless %alive; # small optimization |
2536
|
0
|
0
|
0
|
|
|
0
|
return map { |
2537
|
0
|
|
|
|
|
0
|
ref($_) && exists $alive{ref $_} && exists $_->{id} |
2538
|
|
|
|
|
|
|
? $self->object($_) |
2539
|
|
|
|
|
|
|
: $_ |
2540
|
|
|
|
|
|
|
} @_; |
2541
|
|
|
|
|
|
|
} |
2542
|
|
|
|
|
|
|
|
2543
|
|
|
|
|
|
|
# ====================================================================== |
2544
|
|
|
|
|
|
|
|
2545
|
|
|
|
|
|
|
package SOAP::Server::Parameters; |
2546
|
|
|
|
|
|
|
|
2547
|
|
|
|
|
|
|
sub byNameOrOrder { |
2548
|
0
|
0
|
|
0
|
|
0
|
unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) { |
2549
|
0
|
0
|
|
|
|
0
|
warn "Last parameter is expected to be envelope\n" if $^W; |
2550
|
0
|
|
|
|
|
0
|
pop; |
2551
|
0
|
|
|
|
|
0
|
return @_; |
2552
|
|
|
|
|
|
|
} |
2553
|
0
|
|
|
|
|
0
|
my $params = pop->method; |
2554
|
0
|
|
|
|
|
0
|
my @mandatory = ref $_[0] eq 'ARRAY' |
2555
|
0
|
0
|
|
|
|
0
|
? @{shift()} |
2556
|
|
|
|
|
|
|
: die "list of parameters expected as the first parameter for byName"; |
2557
|
0
|
|
|
|
|
0
|
my $byname = 0; |
2558
|
0
|
|
|
|
|
0
|
my @res = map { $byname += exists $params->{$_}; $params->{$_} } @mandatory; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2559
|
0
|
0
|
|
|
|
0
|
return $byname |
2560
|
|
|
|
|
|
|
? @res |
2561
|
|
|
|
|
|
|
: @_; |
2562
|
|
|
|
|
|
|
} |
2563
|
|
|
|
|
|
|
|
2564
|
|
|
|
|
|
|
sub byName { |
2565
|
0
|
0
|
|
0
|
|
0
|
unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) { |
2566
|
0
|
0
|
|
|
|
0
|
warn "Last parameter is expected to be envelope\n" if $^W; |
2567
|
0
|
|
|
|
|
0
|
pop; |
2568
|
0
|
|
|
|
|
0
|
return @_; |
2569
|
|
|
|
|
|
|
} |
2570
|
0
|
0
|
|
|
|
0
|
return @{pop->method}{ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName"}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2571
|
|
|
|
|
|
|
} |
2572
|
|
|
|
|
|
|
|
2573
|
|
|
|
|
|
|
# ====================================================================== |
2574
|
|
|
|
|
|
|
|
2575
|
|
|
|
|
|
|
package SOAP::Server; |
2576
|
|
|
|
|
|
|
|
2577
|
25
|
|
|
25
|
|
1117
|
use Carp (); |
|
25
|
|
|
|
|
60
|
|
|
25
|
|
|
|
|
557
|
|
2578
|
25
|
|
|
25
|
|
142
|
use Scalar::Util qw(weaken); |
|
25
|
|
|
|
|
44
|
|
|
25
|
|
|
|
|
9994
|
|
2579
|
1
|
|
|
1
|
|
3
|
sub DESTROY { SOAP::Trace::objects('()') } |
2580
|
|
|
|
|
|
|
|
2581
|
|
|
|
|
|
|
sub initialize { |
2582
|
|
|
|
|
|
|
return ( |
2583
|
|
|
|
|
|
|
packager => SOAP::Packager::MIME->new, |
2584
|
|
|
|
|
|
|
transport => SOAP::Transport->new, |
2585
|
|
|
|
|
|
|
serializer => SOAP::Serializer->new, |
2586
|
|
|
|
|
|
|
deserializer => SOAP::Deserializer->new, |
2587
|
0
|
|
|
0
|
|
0
|
on_action => sub { ; }, |
2588
|
|
|
|
|
|
|
on_dispatch => sub { |
2589
|
0
|
|
|
0
|
|
0
|
return; |
2590
|
|
|
|
|
|
|
}, |
2591
|
1
|
|
|
1
|
|
5
|
); |
2592
|
|
|
|
|
|
|
} |
2593
|
|
|
|
|
|
|
|
2594
|
|
|
|
|
|
|
sub new { |
2595
|
13
|
|
|
13
|
|
17
|
my $self = shift; |
2596
|
13
|
100
|
|
|
|
42
|
return $self if ref $self; |
2597
|
|
|
|
|
|
|
|
2598
|
1
|
50
|
|
|
|
3
|
unless (ref $self) { |
2599
|
1
|
|
|
|
|
4
|
my $class = $self; |
2600
|
1
|
|
|
|
|
2
|
my(@params, @methods); |
2601
|
|
|
|
|
|
|
|
2602
|
1
|
|
|
|
|
6
|
while (@_) { |
2603
|
0
|
|
|
|
|
0
|
my($method, $params) = splice(@_,0,2); |
2604
|
0
|
0
|
0
|
|
|
0
|
$class->can($method) |
2605
|
|
|
|
|
|
|
? push(@methods, $method, $params) |
2606
|
|
|
|
|
|
|
: $^W && Carp::carp "Unrecognized parameter '$method' in new()"; |
2607
|
|
|
|
|
|
|
} |
2608
|
|
|
|
|
|
|
|
2609
|
1
|
|
|
|
|
11
|
$self = bless { |
2610
|
|
|
|
|
|
|
_dispatch_to => [], |
2611
|
|
|
|
|
|
|
_dispatch_with => {}, |
2612
|
|
|
|
|
|
|
_dispatched => [], |
2613
|
|
|
|
|
|
|
_action => '', |
2614
|
|
|
|
|
|
|
_options => {}, |
2615
|
|
|
|
|
|
|
} => $class; |
2616
|
1
|
|
|
|
|
5
|
unshift(@methods, $self->initialize); |
2617
|
25
|
|
|
25
|
|
149
|
no strict qw(refs); |
|
25
|
|
|
|
|
65
|
|
|
25
|
|
|
|
|
2833
|
|
2618
|
1
|
|
|
|
|
7
|
while (@methods) { |
2619
|
6
|
|
|
|
|
14
|
my($method, $params) = splice(@methods,0,2); |
2620
|
6
|
50
|
|
|
|
30
|
$self->$method(ref $params eq 'ARRAY' ? @$params : $params) |
2621
|
|
|
|
|
|
|
} |
2622
|
1
|
|
|
|
|
3
|
SOAP::Trace::objects('()'); |
2623
|
|
|
|
|
|
|
} |
2624
|
|
|
|
|
|
|
|
2625
|
1
|
50
|
33
|
|
|
6
|
Carp::carp "Odd (wrong?) number of parameters in new()" |
2626
|
|
|
|
|
|
|
if $^W && (@_ & 1); |
2627
|
|
|
|
|
|
|
|
2628
|
25
|
|
|
25
|
|
132
|
no strict qw(refs); |
|
25
|
|
|
|
|
44
|
|
|
25
|
|
|
|
|
6766
|
|
2629
|
1
|
|
|
|
|
6
|
while (@_) { |
2630
|
0
|
|
|
|
|
0
|
my($method, $params) = splice(@_,0,2); |
2631
|
0
|
0
|
0
|
|
|
0
|
$self->can($method) |
|
|
0
|
|
|
|
|
|
2632
|
|
|
|
|
|
|
? $self->$method(ref $params eq 'ARRAY' ? @$params : $params) |
2633
|
|
|
|
|
|
|
: $^W && Carp::carp "Unrecognized parameter '$method' in new()" |
2634
|
|
|
|
|
|
|
} |
2635
|
|
|
|
|
|
|
|
2636
|
1
|
|
|
|
|
3
|
return $self; |
2637
|
|
|
|
|
|
|
} |
2638
|
|
|
|
|
|
|
|
2639
|
|
|
|
|
|
|
sub init_context { |
2640
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
2641
|
1
|
|
|
|
|
3
|
$self->{'_deserializer'}->{'_context'} = $self; |
2642
|
|
|
|
|
|
|
# weaken circular reference to avoid a memory hole |
2643
|
1
|
|
|
|
|
7
|
weaken($self->{'_deserializer'}->{'_context'}); |
2644
|
|
|
|
|
|
|
|
2645
|
1
|
|
|
|
|
2
|
$self->{'_serializer'}->{'_context'} = $self; |
2646
|
|
|
|
|
|
|
# weaken circular reference to avoid a memory hole |
2647
|
1
|
|
|
|
|
5
|
weaken($self->{'_serializer'}->{'_context'}); |
2648
|
|
|
|
|
|
|
} |
2649
|
|
|
|
|
|
|
|
2650
|
|
|
|
|
|
|
sub BEGIN { |
2651
|
25
|
|
|
25
|
|
171
|
no strict 'refs'; |
|
25
|
|
|
|
|
44
|
|
|
25
|
|
|
|
|
11513
|
|
2652
|
25
|
|
|
25
|
|
1508
|
for my $method (qw(serializer deserializer transport)) { |
2653
|
75
|
|
|
|
|
1607
|
my $field = '_' . $method; |
2654
|
|
|
|
|
|
|
*$method = sub { |
2655
|
6
|
|
|
6
|
|
15
|
my $self = shift->new(); |
2656
|
6
|
100
|
|
|
|
13
|
if (@_) { |
2657
|
3
|
|
|
|
|
10
|
my $context = $self->{$field}->{'_context'}; # save the old context |
2658
|
3
|
|
|
|
|
6
|
$self->{$field} = shift; |
2659
|
3
|
|
|
|
|
15
|
$self->{$field}->{'_context'} = $context; # restore the old context |
2660
|
3
|
|
|
|
|
8
|
return $self; |
2661
|
|
|
|
|
|
|
} |
2662
|
|
|
|
|
|
|
else { |
2663
|
3
|
|
|
|
|
18
|
return $self->{$field}; |
2664
|
|
|
|
|
|
|
} |
2665
|
|
|
|
|
|
|
} |
2666
|
75
|
|
|
|
|
609
|
} |
2667
|
|
|
|
|
|
|
|
2668
|
25
|
|
|
|
|
67
|
for my $method (qw(action myuri options dispatch_with packager)) { |
2669
|
125
|
|
|
|
|
1650
|
my $field = '_' . $method; |
2670
|
|
|
|
|
|
|
*$method = sub { |
2671
|
4
|
|
|
4
|
|
14
|
my $self = shift->new(); |
2672
|
|
|
|
|
|
|
(@_) |
2673
|
4
|
100
|
|
|
|
27
|
? do { |
2674
|
1
|
|
|
|
|
8
|
$self->{$field} = shift; |
2675
|
1
|
|
|
|
|
4
|
return $self; |
2676
|
|
|
|
|
|
|
} |
2677
|
|
|
|
|
|
|
: return $self->{$field}; |
2678
|
|
|
|
|
|
|
} |
2679
|
125
|
|
|
|
|
2312
|
} |
2680
|
25
|
|
|
|
|
66
|
for my $method (qw(on_action on_dispatch)) { |
2681
|
50
|
|
|
|
|
115
|
my $field = '_' . $method; |
2682
|
|
|
|
|
|
|
*$method = sub { |
2683
|
2
|
|
|
2
|
|
5
|
my $self = shift->new; |
2684
|
|
|
|
|
|
|
# my $self = shift; |
2685
|
2
|
50
|
|
|
|
7
|
return $self->{$field} unless @_; |
2686
|
2
|
|
|
|
|
1
|
local $@; |
2687
|
|
|
|
|
|
|
# commented out because that 'eval' was unsecure |
2688
|
|
|
|
|
|
|
# > ref $_[0] eq 'CODE' ? shift : eval shift; |
2689
|
|
|
|
|
|
|
# Am I paranoid enough? |
2690
|
2
|
|
|
|
|
6
|
$self->{$field} = shift; |
2691
|
2
|
50
|
|
|
|
5
|
Carp::croak $@ if $@; |
2692
|
2
|
50
|
|
|
|
8
|
Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)" |
2693
|
|
|
|
|
|
|
unless ref $self->{$field} eq 'CODE'; |
2694
|
2
|
|
|
|
|
6
|
return $self; |
2695
|
|
|
|
|
|
|
} |
2696
|
50
|
|
|
|
|
313
|
} |
2697
|
|
|
|
|
|
|
|
2698
|
|
|
|
|
|
|
# __PACKAGE__->__mk_accessors( qw(dispatch_to) ); |
2699
|
25
|
|
|
|
|
55
|
for my $method (qw(dispatch_to)) { |
2700
|
25
|
|
|
|
|
55
|
my $field = '_' . $method; |
2701
|
|
|
|
|
|
|
*$method = sub { |
2702
|
1
|
|
|
1
|
|
460
|
my $self = shift->new; |
2703
|
|
|
|
|
|
|
# my $self = shift; |
2704
|
|
|
|
|
|
|
(@_) |
2705
|
0
|
|
|
|
|
0
|
? do { |
2706
|
1
|
|
|
|
|
5
|
$self->{$field} = [@_]; |
2707
|
1
|
|
|
|
|
4
|
return $self; |
2708
|
|
|
|
|
|
|
} |
2709
|
1
|
50
|
|
|
|
5
|
: return @{ $self->{$field} }; |
2710
|
|
|
|
|
|
|
} |
2711
|
25
|
|
|
|
|
22972
|
} |
2712
|
|
|
|
|
|
|
} |
2713
|
|
|
|
|
|
|
|
2714
|
|
|
|
|
|
|
sub objects_by_reference { |
2715
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2716
|
0
|
0
|
|
|
|
0
|
$self = $self->new() if not ref $self; |
2717
|
|
|
|
|
|
|
@_ |
2718
|
0
|
0
|
|
|
|
0
|
? (SOAP::Server::Object->objects_by_reference(@_), return $self) |
2719
|
|
|
|
|
|
|
: SOAP::Server::Object->objects_by_reference; |
2720
|
|
|
|
|
|
|
} |
2721
|
|
|
|
|
|
|
|
2722
|
|
|
|
|
|
|
sub dispatched { |
2723
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2724
|
0
|
0
|
|
|
|
0
|
$self = $self->new() if not ref $self; |
2725
|
|
|
|
|
|
|
@_ |
2726
|
0
|
|
|
|
|
0
|
? (push(@{$self->{_dispatched}}, @_), return $self) |
|
0
|
|
|
|
|
0
|
|
2727
|
0
|
0
|
|
|
|
0
|
: return @{$self->{_dispatched}}; |
2728
|
|
|
|
|
|
|
} |
2729
|
|
|
|
|
|
|
|
2730
|
|
|
|
|
|
|
sub find_target { |
2731
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
2732
|
0
|
|
|
|
|
0
|
my $request = shift; |
2733
|
|
|
|
|
|
|
|
2734
|
|
|
|
|
|
|
# try to find URI/method from on_dispatch call first |
2735
|
0
|
|
|
|
|
0
|
my($method_uri, $method_name) = $self->on_dispatch->($request); |
2736
|
|
|
|
|
|
|
|
2737
|
|
|
|
|
|
|
# if nothing there, then get it from envelope itself |
2738
|
0
|
|
|
|
|
0
|
$request->match((ref $request)->method); |
2739
|
0
|
0
|
0
|
|
|
0
|
($method_uri, $method_name) = ($request->namespaceuriof || '', $request->dataof->name) |
2740
|
|
|
|
|
|
|
unless $method_name; |
2741
|
|
|
|
|
|
|
|
2742
|
0
|
|
|
|
|
0
|
$self->on_action->(my $action = $self->action, $method_uri, $method_name); |
2743
|
|
|
|
|
|
|
|
2744
|
|
|
|
|
|
|
# check to avoid security vulnerability: Protected->Unprotected::method(@parameters) |
2745
|
|
|
|
|
|
|
# see for more details: http://www.phrack.org/phrack/58/p58-0x09 |
2746
|
0
|
0
|
|
|
|
0
|
die "Denied access to method ($method_name)\n" unless $method_name =~ /^\w+$/; |
2747
|
|
|
|
|
|
|
|
2748
|
0
|
|
|
|
|
0
|
my ($class, $static); |
2749
|
|
|
|
|
|
|
# try to bind directly |
2750
|
0
|
0
|
0
|
|
|
0
|
if (defined($class = $self->dispatch_with->{$method_uri} |
2751
|
|
|
|
|
|
|
|| $self->dispatch_with->{$action || ''} |
2752
|
|
|
|
|
|
|
|| (defined($action) && $action =~ /^"(.+)"$/ |
2753
|
|
|
|
|
|
|
? $self->dispatch_with->{$1} |
2754
|
|
|
|
|
|
|
: undef))) { |
2755
|
|
|
|
|
|
|
# return object, nothing else to do here |
2756
|
0
|
0
|
|
|
|
0
|
return ($class, $method_uri, $method_name) if ref $class; |
2757
|
0
|
|
|
|
|
0
|
$static = 1; |
2758
|
|
|
|
|
|
|
} |
2759
|
|
|
|
|
|
|
else { |
2760
|
0
|
0
|
|
|
|
0
|
die "URI path shall map to class" unless defined ($class = URI->new($method_uri)->path); |
2761
|
|
|
|
|
|
|
|
2762
|
0
|
|
|
|
|
0
|
for ($class) { s!^/|/$!!g; s!/!::!g; s/^$/main/; } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2763
|
0
|
0
|
|
|
|
0
|
die "Failed to access class ($class)" unless $class =~ /^(\w[\w:]*)$/; |
2764
|
|
|
|
|
|
|
|
2765
|
0
|
|
|
|
|
0
|
my $fullname = "$class\::$method_name"; |
2766
|
0
|
|
|
|
|
0
|
foreach ($self->dispatch_to) { |
2767
|
0
|
0
|
|
|
|
0
|
return ($_, $method_uri, $method_name) if ref eq $class; # $OBJECT |
2768
|
0
|
0
|
|
|
|
0
|
next if ref; # skip other objects |
2769
|
|
|
|
|
|
|
# will ignore errors, because it may complain on |
2770
|
|
|
|
|
|
|
# d:\foo\bar, which is PATH and not regexp |
2771
|
0
|
|
|
|
|
0
|
eval { |
2772
|
0
|
|
0
|
|
|
0
|
$static ||= $class =~ /^$_$/ # MODULE |
|
|
|
0
|
|
|
|
|
2773
|
|
|
|
|
|
|
|| $fullname =~ /^$_$/ # MODULE::method |
2774
|
|
|
|
|
|
|
|| $method_name =~ /^$_$/ && ($class eq 'main'); # method ('main' assumed) |
2775
|
|
|
|
|
|
|
}; |
2776
|
|
|
|
|
|
|
} |
2777
|
|
|
|
|
|
|
} |
2778
|
|
|
|
|
|
|
|
2779
|
25
|
|
|
25
|
|
170
|
no strict 'refs'; |
|
25
|
|
|
|
|
1333
|
|
|
25
|
|
|
|
|
21785
|
|
2780
|
|
|
|
|
|
|
|
2781
|
|
|
|
|
|
|
# TODO - sort this mess out: |
2782
|
|
|
|
|
|
|
# The task is to test whether the class in question has already been loaded. |
2783
|
|
|
|
|
|
|
# |
2784
|
|
|
|
|
|
|
# SOAP::Lite 0.60: |
2785
|
|
|
|
|
|
|
# unless (defined %{"${class}::"}) { |
2786
|
|
|
|
|
|
|
# Patch to SOAP::Lite 0.60: |
2787
|
|
|
|
|
|
|
# The following patch does not work for packages defined within a BEGIN block |
2788
|
|
|
|
|
|
|
# unless (exists($INC{join '/', split /::/, $class.'.pm'})) { |
2789
|
|
|
|
|
|
|
# Combination of 0.60 and patch did not work reliably, either. |
2790
|
|
|
|
|
|
|
# |
2791
|
|
|
|
|
|
|
# Now we do the following: Check whether the class is main (always loaded) |
2792
|
|
|
|
|
|
|
# or the class implements the method in question |
2793
|
|
|
|
|
|
|
# or the package exists as file in %INC. |
2794
|
|
|
|
|
|
|
# |
2795
|
|
|
|
|
|
|
# This is still sort of a hack - but I don't know anything better |
2796
|
|
|
|
|
|
|
# If you have some idea, please help me out... |
2797
|
|
|
|
|
|
|
# |
2798
|
0
|
0
|
0
|
|
|
0
|
unless (($class eq 'main') || $class->can($method_name) |
|
|
|
0
|
|
|
|
|
2799
|
|
|
|
|
|
|
|| exists($INC{join '/', split /::/, $class . '.pm'})) { |
2800
|
|
|
|
|
|
|
|
2801
|
|
|
|
|
|
|
# allow all for static and only specified path for dynamic bindings |
2802
|
0
|
0
|
|
|
|
0
|
local @INC = (($static ? @INC : ()), grep {!ref && m![/\\.]!} $self->dispatch_to()); |
|
0
|
0
|
|
|
|
0
|
|
2803
|
0
|
|
|
|
|
0
|
eval 'local $^W; ' . "require $class"; |
2804
|
0
|
0
|
|
|
|
0
|
die "Failed to access class ($class): $@" if $@; |
2805
|
0
|
0
|
|
|
|
0
|
$self->dispatched($class) unless $static; |
2806
|
|
|
|
|
|
|
} |
2807
|
|
|
|
|
|
|
|
2808
|
0
|
|
|
|
|
0
|
die "Denied access to method ($method_name) in class ($class)" |
2809
|
0
|
0
|
0
|
|
|
0
|
unless $static || grep {/^$class$/} $self->dispatched; |
2810
|
|
|
|
|
|
|
|
2811
|
0
|
|
|
|
|
0
|
return ($class, $method_uri, $method_name); |
2812
|
|
|
|
|
|
|
} |
2813
|
|
|
|
|
|
|
|
2814
|
|
|
|
|
|
|
sub handle { |
2815
|
1
|
|
|
1
|
|
15
|
SOAP::Trace::trace('()'); |
2816
|
1
|
|
|
|
|
1
|
my $self = shift; |
2817
|
1
|
50
|
|
|
|
6
|
$self = $self->new if !ref $self; # inits the server when called in a static context |
2818
|
1
|
|
|
|
|
4
|
$self->init_context(); |
2819
|
|
|
|
|
|
|
# we want to restore it when we are done |
2820
|
1
|
|
|
|
|
3
|
local $SOAP::Constants::DEFAULT_XML_SCHEMA |
2821
|
|
|
|
|
|
|
= $SOAP::Constants::DEFAULT_XML_SCHEMA; |
2822
|
|
|
|
|
|
|
|
2823
|
|
|
|
|
|
|
# SOAP version WILL NOT be restored when we are done. |
2824
|
|
|
|
|
|
|
# is it problem? |
2825
|
|
|
|
|
|
|
|
2826
|
1
|
|
|
|
|
2
|
my $result = eval { |
2827
|
1
|
|
|
|
|
4
|
local $SIG{__DIE__}; |
2828
|
|
|
|
|
|
|
# why is this here: |
2829
|
1
|
|
|
|
|
3
|
$self->serializer->soapversion(1.1); |
2830
|
1
|
|
|
|
|
3
|
my $request = eval { $self->deserializer->deserialize($_[0]) }; |
|
1
|
|
|
|
|
3
|
|
2831
|
|
|
|
|
|
|
|
2832
|
1
|
50
|
33
|
|
|
23
|
die SOAP::Fault |
2833
|
|
|
|
|
|
|
->faultcode($SOAP::Constants::FAULT_VERSION_MISMATCH) |
2834
|
|
|
|
|
|
|
->faultstring($@) |
2835
|
|
|
|
|
|
|
if $@ && $@ =~ /^$SOAP::Constants::WRONG_VERSION/; |
2836
|
|
|
|
|
|
|
|
2837
|
1
|
50
|
|
|
|
11
|
die "Application failed during request deserialization: $@" if $@; |
2838
|
0
|
|
|
|
|
0
|
my $som = ref $request; |
2839
|
0
|
0
|
|
|
|
0
|
die "Can't find root element in the message" |
2840
|
|
|
|
|
|
|
unless $request->match($som->envelope); |
2841
|
0
|
|
|
|
|
0
|
$self->serializer->soapversion(SOAP::Lite->soapversion); |
2842
|
0
|
0
|
|
|
|
0
|
$self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA |
2843
|
|
|
|
|
|
|
= $self->deserializer->xmlschema) |
2844
|
|
|
|
|
|
|
if $self->deserializer->xmlschema; |
2845
|
|
|
|
|
|
|
|
2846
|
0
|
0
|
0
|
|
|
0
|
die SOAP::Fault |
2847
|
|
|
|
|
|
|
->faultcode($SOAP::Constants::FAULT_MUST_UNDERSTAND) |
2848
|
|
|
|
|
|
|
->faultstring("Unrecognized header has mustUnderstand attribute set to 'true'") |
2849
|
|
|
|
|
|
|
if !$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND && |
2850
|
|
|
|
|
|
|
grep { |
2851
|
0
|
0
|
0
|
|
|
0
|
$_->mustUnderstand |
2852
|
|
|
|
|
|
|
&& (!$_->actor || $_->actor eq $SOAP::Constants::NEXT_ACTOR) |
2853
|
|
|
|
|
|
|
} $request->dataof($som->headers); |
2854
|
|
|
|
|
|
|
|
2855
|
0
|
0
|
|
|
|
0
|
die "Can't find method element in the message" |
2856
|
|
|
|
|
|
|
unless $request->match($som->method); |
2857
|
|
|
|
|
|
|
# TODO - SOAP::Dispatcher plugs in here |
2858
|
|
|
|
|
|
|
# my $handler = $self->dispatcher->find_handler($request); |
2859
|
0
|
|
|
|
|
0
|
my($class, $method_uri, $method_name) = $self->find_target($request); |
2860
|
0
|
|
|
|
|
0
|
my @results = eval { |
2861
|
0
|
|
|
|
|
0
|
local $^W; |
2862
|
0
|
|
|
|
|
0
|
my @parameters = $request->paramsin; |
2863
|
|
|
|
|
|
|
|
2864
|
|
|
|
|
|
|
# SOAP::Trace::dispatch($fullname); |
2865
|
0
|
|
|
|
|
0
|
SOAP::Trace::parameters(@parameters); |
2866
|
|
|
|
|
|
|
|
2867
|
0
|
0
|
|
|
|
0
|
push @parameters, $request |
2868
|
|
|
|
|
|
|
if UNIVERSAL::isa($class => 'SOAP::Server::Parameters'); |
2869
|
|
|
|
|
|
|
|
2870
|
25
|
|
|
25
|
|
161
|
no strict qw(refs); |
|
25
|
|
|
|
|
52
|
|
|
25
|
|
|
|
|
27483
|
|
2871
|
|
|
|
|
|
|
SOAP::Server::Object->references( |
2872
|
|
|
|
|
|
|
defined $parameters[0] |
2873
|
|
|
|
|
|
|
&& ref $parameters[0] |
2874
|
|
|
|
|
|
|
&& UNIVERSAL::isa($parameters[0] => $class) |
2875
|
0
|
0
|
0
|
|
|
0
|
? do { |
2876
|
0
|
|
|
|
|
0
|
my $object = shift @parameters; |
2877
|
0
|
0
|
|
|
|
0
|
SOAP::Server::Object->object(ref $class |
2878
|
|
|
|
|
|
|
? $class |
2879
|
|
|
|
|
|
|
: $object |
2880
|
|
|
|
|
|
|
)->$method_name(SOAP::Server::Object->objects(@parameters)), |
2881
|
|
|
|
|
|
|
|
2882
|
|
|
|
|
|
|
# send object back as a header |
2883
|
|
|
|
|
|
|
# preserve name, specify URI |
2884
|
|
|
|
|
|
|
SOAP::Header |
2885
|
|
|
|
|
|
|
->uri($SOAP::Constants::NS_SL_HEADER => $object) |
2886
|
|
|
|
|
|
|
->name($request->dataof($som->method.'/[1]')->name) |
2887
|
|
|
|
|
|
|
} # end do block |
2888
|
|
|
|
|
|
|
|
2889
|
|
|
|
|
|
|
# SOAP::Dispatcher will plug-in here as well |
2890
|
|
|
|
|
|
|
# $handler->dispatch(SOAP::Server::Object->objects(@parameters) |
2891
|
|
|
|
|
|
|
: $class->$method_name(SOAP::Server::Object->objects(@parameters)) ); |
2892
|
|
|
|
|
|
|
}; # end eval block |
2893
|
0
|
|
|
|
|
0
|
SOAP::Trace::result(@results); |
2894
|
|
|
|
|
|
|
|
2895
|
|
|
|
|
|
|
# let application errors pass through with 'Server' code |
2896
|
0
|
0
|
|
|
|
0
|
die ref $@ |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2897
|
|
|
|
|
|
|
? $@ |
2898
|
|
|
|
|
|
|
: $@ =~ /^Can\'t locate object method "$method_name"/ |
2899
|
|
|
|
|
|
|
? "Failed to locate method ($method_name) in class ($class)" |
2900
|
|
|
|
|
|
|
: SOAP::Fault->faultcode($SOAP::Constants::FAULT_SERVER)->faultstring($@) |
2901
|
|
|
|
|
|
|
if $@; |
2902
|
|
|
|
|
|
|
|
2903
|
0
|
|
|
|
|
0
|
my $result = $self->serializer |
2904
|
|
|
|
|
|
|
->prefix('s') # distinguish generated element names between client and server |
2905
|
|
|
|
|
|
|
->uri($method_uri) |
2906
|
|
|
|
|
|
|
->envelope(response => $method_name . 'Response', @results); |
2907
|
0
|
|
|
|
|
0
|
return $result; |
2908
|
|
|
|
|
|
|
}; |
2909
|
|
|
|
|
|
|
|
2910
|
|
|
|
|
|
|
# void context |
2911
|
1
|
50
|
|
|
|
5
|
return unless defined wantarray; |
2912
|
|
|
|
|
|
|
|
2913
|
|
|
|
|
|
|
# normal result |
2914
|
1
|
50
|
|
|
|
8
|
return $result unless $@; |
2915
|
|
|
|
|
|
|
|
2916
|
|
|
|
|
|
|
# check fails, something wrong with message |
2917
|
1
|
50
|
|
|
|
8
|
return $self->make_fault($SOAP::Constants::FAULT_CLIENT, $@) unless ref $@; |
2918
|
|
|
|
|
|
|
|
2919
|
|
|
|
|
|
|
# died with SOAP::Fault |
2920
|
0
|
0
|
0
|
|
|
0
|
return $self->make_fault($@->faultcode || $SOAP::Constants::FAULT_SERVER, |
|
|
|
0
|
|
|
|
|
2921
|
|
|
|
|
|
|
$@->faultstring || 'Application error', |
2922
|
|
|
|
|
|
|
$@->faultdetail, $@->faultactor) |
2923
|
|
|
|
|
|
|
if UNIVERSAL::isa($@ => 'SOAP::Fault'); |
2924
|
|
|
|
|
|
|
|
2925
|
|
|
|
|
|
|
# died with complex detail |
2926
|
0
|
|
|
|
|
0
|
return $self->make_fault($SOAP::Constants::FAULT_SERVER, 'Application error' => $@); |
2927
|
|
|
|
|
|
|
|
2928
|
|
|
|
|
|
|
} # end of handle() |
2929
|
|
|
|
|
|
|
|
2930
|
|
|
|
|
|
|
sub make_fault { |
2931
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
2932
|
1
|
|
|
|
|
3
|
my($code, $string, $detail, $actor) = @_; |
2933
|
1
|
|
33
|
|
|
4
|
$self->serializer->fault($code, $string, $detail, $actor || $self->myuri); |
2934
|
|
|
|
|
|
|
} |
2935
|
|
|
|
|
|
|
|
2936
|
|
|
|
|
|
|
# ====================================================================== |
2937
|
|
|
|
|
|
|
|
2938
|
|
|
|
|
|
|
package SOAP::Trace; |
2939
|
|
|
|
|
|
|
|
2940
|
25
|
|
|
25
|
|
174
|
use Carp (); |
|
25
|
|
|
|
|
46
|
|
|
25
|
|
|
|
|
1021
|
|
2941
|
|
|
|
|
|
|
|
2942
|
|
|
|
|
|
|
my @list = qw( |
2943
|
|
|
|
|
|
|
transport dispatch result |
2944
|
|
|
|
|
|
|
parameters headers objects |
2945
|
|
|
|
|
|
|
method fault freeform |
2946
|
|
|
|
|
|
|
trace debug); |
2947
|
|
|
|
|
|
|
{ |
2948
|
25
|
|
|
25
|
|
132
|
no strict 'refs'; |
|
25
|
|
|
|
|
56
|
|
|
25
|
|
|
|
|
4643
|
|
2949
|
|
|
|
|
|
|
for (@list) { |
2950
|
551
|
|
|
551
|
|
12100
|
*$_ = sub {} |
2951
|
|
|
|
|
|
|
} |
2952
|
|
|
|
|
|
|
} |
2953
|
|
|
|
|
|
|
|
2954
|
|
|
|
|
|
|
sub defaultlog { |
2955
|
0
|
|
|
0
|
|
0
|
my $caller = (caller(1))[3]; # the 4th element returned by caller is the subroutine name |
2956
|
0
|
0
|
|
|
|
0
|
$caller = (caller(2))[3] if $caller =~ /eval/; |
2957
|
0
|
|
|
|
|
0
|
chomp(my $msg = join ' ', @_); |
2958
|
0
|
|
|
|
|
0
|
printf STDERR "%s: %s\n", $caller, $msg; |
2959
|
|
|
|
|
|
|
} |
2960
|
|
|
|
|
|
|
|
2961
|
|
|
|
|
|
|
sub import { |
2962
|
25
|
|
|
25
|
|
138
|
no strict 'refs'; |
|
25
|
|
|
|
|
52
|
|
|
25
|
|
|
|
|
893
|
|
2963
|
25
|
|
|
25
|
|
142
|
no warnings qw{ redefine }; # suppress warnings about redefining |
|
25
|
|
|
|
|
62
|
|
|
25
|
|
|
|
|
9827
|
|
2964
|
0
|
|
|
0
|
|
0
|
my $pack = shift; |
2965
|
0
|
|
|
|
|
0
|
my(@notrace, @symbols); |
2966
|
0
|
|
|
|
|
0
|
for (@_) { |
2967
|
0
|
0
|
|
|
|
0
|
if (ref eq 'CODE') { |
2968
|
0
|
|
|
|
|
0
|
my $call = $_; |
2969
|
0
|
|
|
0
|
|
0
|
foreach (@symbols) { *$_ = sub { $call->(@_) } } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2970
|
0
|
|
|
|
|
0
|
@symbols = (); |
2971
|
|
|
|
|
|
|
} |
2972
|
|
|
|
|
|
|
else { |
2973
|
0
|
|
|
|
|
0
|
local $_ = $_; |
2974
|
0
|
|
|
|
|
0
|
my $minus = s/^-//; |
2975
|
0
|
|
|
|
|
0
|
my $all = $_ eq 'all'; |
2976
|
0
|
0
|
0
|
|
|
0
|
Carp::carp "Illegal symbol for tracing ($_)" unless $all || $pack->can($_); |
2977
|
0
|
0
|
|
|
|
0
|
$minus ? push(@notrace, $all ? @list : $_) : push(@symbols, $all ? @list : $_); |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2978
|
|
|
|
|
|
|
} |
2979
|
|
|
|
|
|
|
} |
2980
|
0
|
|
|
|
|
0
|
foreach (@symbols) { *$_ = \&defaultlog } |
|
0
|
|
|
|
|
0
|
|
2981
|
0
|
|
|
0
|
|
0
|
foreach (@notrace) { *$_ = sub {} } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2982
|
|
|
|
|
|
|
} |
2983
|
|
|
|
|
|
|
|
2984
|
|
|
|
|
|
|
# ====================================================================== |
2985
|
|
|
|
|
|
|
|
2986
|
|
|
|
|
|
|
package SOAP::Custom::XML::Data; |
2987
|
|
|
|
|
|
|
|
2988
|
25
|
|
|
25
|
|
148
|
use vars qw(@ISA $AUTOLOAD); |
|
25
|
|
|
|
|
45
|
|
|
25
|
|
|
|
|
2468
|
|
2989
|
|
|
|
|
|
|
@ISA = qw(SOAP::Data); |
2990
|
|
|
|
|
|
|
|
2991
|
25
|
|
|
25
|
|
147
|
use overload fallback => 1, '""' => sub { shift->value }; |
|
25
|
|
|
0
|
|
60
|
|
|
25
|
|
|
|
|
392
|
|
|
0
|
|
|
|
|
0
|
|
2992
|
|
|
|
|
|
|
|
2993
|
|
|
|
|
|
|
sub _compileit { |
2994
|
25
|
|
|
25
|
|
2524
|
no strict 'refs'; |
|
25
|
|
|
|
|
52
|
|
|
25
|
|
|
|
|
5001
|
|
2995
|
100
|
|
|
100
|
|
150
|
my $method = shift; |
2996
|
|
|
|
|
|
|
*$method = sub { |
2997
|
1
|
50
|
|
1
|
|
13
|
return __PACKAGE__->SUPER::name($method => $_[0]->attr->{$method}) |
2998
|
|
|
|
|
|
|
if exists $_[0]->attr->{$method}; |
2999
|
0
|
0
|
0
|
|
|
0
|
my @elems = grep { |
3000
|
1
|
|
|
|
|
10
|
ref $_ && UNIVERSAL::isa($_ => __PACKAGE__) |
3001
|
|
|
|
|
|
|
&& $_->SUPER::name =~ /(^|:)$method$/ |
3002
|
|
|
|
|
|
|
} $_[0]->value; |
3003
|
1
|
50
|
|
|
|
6
|
return wantarray? @elems : $elems[0]; |
3004
|
100
|
|
|
|
|
7747
|
}; |
3005
|
|
|
|
|
|
|
} |
3006
|
|
|
|
|
|
|
|
3007
|
25
|
|
|
25
|
|
69
|
sub BEGIN { foreach (qw(name type import use)) { _compileit($_) } } |
|
100
|
|
|
|
|
205
|
|
3008
|
|
|
|
|
|
|
|
3009
|
|
|
|
|
|
|
sub AUTOLOAD { |
3010
|
0
|
|
|
0
|
|
0
|
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); |
3011
|
0
|
0
|
|
|
|
0
|
return if $method eq 'DESTROY'; |
3012
|
|
|
|
|
|
|
|
3013
|
0
|
|
|
|
|
0
|
_compileit($method); |
3014
|
0
|
|
|
|
|
0
|
goto &$AUTOLOAD; |
3015
|
|
|
|
|
|
|
} |
3016
|
|
|
|
|
|
|
|
3017
|
|
|
|
|
|
|
# ====================================================================== |
3018
|
|
|
|
|
|
|
|
3019
|
|
|
|
|
|
|
package SOAP::Custom::XML::Deserializer; |
3020
|
|
|
|
|
|
|
|
3021
|
25
|
|
|
25
|
|
260
|
use vars qw(@ISA); |
|
25
|
|
|
|
|
56
|
|
|
25
|
|
|
|
|
4582
|
|
3022
|
|
|
|
|
|
|
@ISA = qw(SOAP::Deserializer); |
3023
|
|
|
|
|
|
|
|
3024
|
|
|
|
|
|
|
sub decode_value { |
3025
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3026
|
0
|
|
|
|
|
0
|
my $ref = shift; |
3027
|
0
|
|
|
|
|
0
|
my($name, $attrs, $children, $value) = @$ref; |
3028
|
|
|
|
|
|
|
# base class knows what to do with it |
3029
|
0
|
0
|
|
|
|
0
|
return $self->SUPER::decode_value($ref) if exists $attrs->{href}; |
3030
|
|
|
|
|
|
|
|
3031
|
0
|
0
|
0
|
|
|
0
|
SOAP::Custom::XML::Data |
3032
|
|
|
|
|
|
|
-> SOAP::Data::name($name) |
3033
|
|
|
|
|
|
|
-> attr($attrs) |
3034
|
|
|
|
|
|
|
-> set_value(ref $children && @$children |
3035
|
|
|
|
|
|
|
? map(scalar(($self->decode_object($_))[1]), @$children) |
3036
|
|
|
|
|
|
|
: $value); |
3037
|
|
|
|
|
|
|
} |
3038
|
|
|
|
|
|
|
|
3039
|
|
|
|
|
|
|
# ====================================================================== |
3040
|
|
|
|
|
|
|
|
3041
|
|
|
|
|
|
|
package SOAP::Schema::Deserializer; |
3042
|
|
|
|
|
|
|
|
3043
|
25
|
|
|
25
|
|
147
|
use vars qw(@ISA); |
|
25
|
|
|
|
|
61
|
|
|
25
|
|
|
|
|
2509
|
|
3044
|
|
|
|
|
|
|
@ISA = qw(SOAP::Custom::XML::Deserializer); |
3045
|
|
|
|
|
|
|
|
3046
|
|
|
|
|
|
|
# ====================================================================== |
3047
|
|
|
|
|
|
|
|
3048
|
|
|
|
|
|
|
package SOAP::Schema::WSDL; |
3049
|
|
|
|
|
|
|
|
3050
|
25
|
|
|
25
|
|
126
|
use vars qw(%imported @ISA); |
|
25
|
|
|
|
|
43
|
|
|
25
|
|
|
|
|
46695
|
|
3051
|
|
|
|
|
|
|
@ISA = qw(SOAP::Schema); |
3052
|
|
|
|
|
|
|
|
3053
|
|
|
|
|
|
|
sub new { |
3054
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3055
|
|
|
|
|
|
|
|
3056
|
0
|
0
|
|
|
|
0
|
unless (ref $self) { |
3057
|
0
|
|
|
|
|
0
|
my $class = $self; |
3058
|
0
|
|
|
|
|
0
|
$self = $class->SUPER::new(@_); |
3059
|
|
|
|
|
|
|
} |
3060
|
0
|
|
|
|
|
0
|
return $self; |
3061
|
|
|
|
|
|
|
} |
3062
|
|
|
|
|
|
|
|
3063
|
|
|
|
|
|
|
sub base { |
3064
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3065
|
|
|
|
|
|
|
@_ |
3066
|
0
|
0
|
|
|
|
0
|
? ($self->{_base} = shift, return $self) |
3067
|
|
|
|
|
|
|
: return $self->{_base}; |
3068
|
|
|
|
|
|
|
} |
3069
|
|
|
|
|
|
|
|
3070
|
|
|
|
|
|
|
sub import { |
3071
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3072
|
0
|
|
|
|
|
0
|
my $s = shift; |
3073
|
0
|
|
0
|
|
|
0
|
my $base = shift || $self->base || die "Missing base argument for ", __PACKAGE__, "\n"; |
3074
|
|
|
|
|
|
|
|
3075
|
0
|
|
|
|
|
0
|
my @a = $s->import; |
3076
|
0
|
|
|
|
|
0
|
local %imported = %imported; |
3077
|
0
|
|
|
|
|
0
|
foreach (@a) { |
3078
|
0
|
0
|
|
|
|
0
|
next unless $_->location; |
3079
|
0
|
|
|
|
|
0
|
my $location = URI->new_abs($_->location->value, $base)->as_string; |
3080
|
0
|
0
|
|
|
|
0
|
if ($imported{$location}++) { |
3081
|
0
|
0
|
|
|
|
0
|
warn "Recursion loop detected in service description from '$location'. Ignored\n" if $^W; |
3082
|
0
|
|
|
|
|
0
|
return $s; |
3083
|
|
|
|
|
|
|
} |
3084
|
0
|
|
|
|
|
0
|
my $root = $self->import( |
3085
|
|
|
|
|
|
|
$self->deserializer->deserialize( |
3086
|
|
|
|
|
|
|
$self->access($location) |
3087
|
|
|
|
|
|
|
)->root, $location); |
3088
|
|
|
|
|
|
|
|
3089
|
|
|
|
|
|
|
$root->SOAP::Data::name eq 'definitions' ? $s->set_value($s->value, $root->value) : |
3090
|
0
|
0
|
|
|
|
0
|
$root->SOAP::Data::name eq 'schema' ? do { # add element if there is no one |
|
|
0
|
|
|
|
|
|
3091
|
0
|
0
|
|
|
|
0
|
$s->set_value($s->value, $self->deserializer->deserialize('')->root) unless $s->types; |
3092
|
0
|
|
|
|
|
0
|
$s->types->set_value($s->types->value, $root) } : |
3093
|
0
|
|
|
|
|
0
|
die "Don't know what to do with '@{[$root->SOAP::Data::name]}' in schema imported from '$location'\n"; |
3094
|
|
|
|
|
|
|
} |
3095
|
|
|
|
|
|
|
|
3096
|
|
|
|
|
|
|
# return the parsed WSDL file |
3097
|
0
|
|
|
|
|
0
|
$s; |
3098
|
|
|
|
|
|
|
} |
3099
|
|
|
|
|
|
|
|
3100
|
|
|
|
|
|
|
# TODO - This is woefully incomplete! |
3101
|
|
|
|
|
|
|
sub parse_schema_element { |
3102
|
0
|
|
|
0
|
|
0
|
my $element = shift; |
3103
|
|
|
|
|
|
|
# Current element is a complex type |
3104
|
0
|
0
|
|
|
|
0
|
if (defined($element->complexType)) { |
|
|
0
|
|
|
|
|
|
3105
|
0
|
|
|
|
|
0
|
my @elements = (); |
3106
|
0
|
0
|
|
|
|
0
|
if (defined($element->complexType->sequence)) { |
3107
|
|
|
|
|
|
|
|
3108
|
0
|
|
|
|
|
0
|
foreach my $e ($element->complexType->sequence->element) { |
3109
|
0
|
|
|
|
|
0
|
push @elements,parse_schema_element($e); |
3110
|
|
|
|
|
|
|
} |
3111
|
|
|
|
|
|
|
} |
3112
|
0
|
|
|
|
|
0
|
return @elements; |
3113
|
|
|
|
|
|
|
} |
3114
|
|
|
|
|
|
|
elsif ($element->simpleType) { |
3115
|
|
|
|
|
|
|
} |
3116
|
|
|
|
|
|
|
else { |
3117
|
0
|
|
|
|
|
0
|
return $element; |
3118
|
|
|
|
|
|
|
} |
3119
|
|
|
|
|
|
|
} |
3120
|
|
|
|
|
|
|
|
3121
|
|
|
|
|
|
|
sub parse { |
3122
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3123
|
0
|
|
|
|
|
0
|
my($s, $service, $port) = @_; |
3124
|
0
|
|
|
|
|
0
|
my @result; |
3125
|
|
|
|
|
|
|
|
3126
|
|
|
|
|
|
|
# handle imports |
3127
|
0
|
|
|
|
|
0
|
$self->import($s); |
3128
|
|
|
|
|
|
|
|
3129
|
|
|
|
|
|
|
# handle descriptions without , aka tModel-type descriptions |
3130
|
0
|
|
|
|
|
0
|
my @services = $s->service; |
3131
|
0
|
|
|
|
|
0
|
my $tns = $s->{'_attr'}->{'targetNamespace'}; |
3132
|
|
|
|
|
|
|
# if there is no element we'll provide it |
3133
|
0
|
0
|
|
|
|
0
|
@services = $self->deserializer->deserialize(<<"FAKE")->root->service unless @services; |
3134
|
|
|
|
|
|
|
|
3135
|
0
|
|
0
|
|
|
0
|
|
|
0
|
|
0
|
|
|
0
|
|
3136
|
0
|
|
|
|
|
0
|
|
3137
|
|
|
|
|
|
|
|
3138
|
|
|
|
|
|
|
|
3139
|
|
|
|
|
|
|
FAKE |
3140
|
|
|
|
|
|
|
|
3141
|
0
|
|
|
|
|
0
|
my $has_warned = 0; |
3142
|
0
|
|
|
|
|
0
|
foreach (@services) { |
3143
|
0
|
|
|
|
|
0
|
my $name = $_->name; |
3144
|
0
|
0
|
0
|
|
|
0
|
next if $service && $service ne $name; |
3145
|
0
|
|
|
|
|
0
|
my %services; |
3146
|
0
|
|
|
|
|
0
|
foreach ($_->port) { |
3147
|
0
|
0
|
0
|
|
|
0
|
next if $port && $port ne $_->name; |
3148
|
0
|
|
|
|
|
0
|
my $binding = SOAP::Utils::disqualify($_->binding); |
3149
|
0
|
0
|
|
|
|
0
|
my $endpoint = ref $_->address ? $_->address->location : undef; |
3150
|
0
|
|
|
|
|
0
|
foreach ($s->binding) { |
3151
|
|
|
|
|
|
|
# is this a SOAP binding? |
3152
|
0
|
0
|
|
|
|
0
|
next unless grep { $_->uri eq 'http://schemas.xmlsoap.org/wsdl/soap/' } $_->binding; |
|
0
|
|
|
|
|
0
|
|
3153
|
0
|
0
|
|
|
|
0
|
next unless $_->name eq $binding; |
3154
|
0
|
|
|
|
|
0
|
my $default_style = $_->binding->style; |
3155
|
0
|
|
|
|
|
0
|
my $porttype = SOAP::Utils::disqualify($_->type); |
3156
|
0
|
|
|
|
|
0
|
foreach ($_->operation) { |
3157
|
0
|
|
|
|
|
0
|
my $opername = $_->name; |
3158
|
0
|
|
|
|
|
0
|
$services{$opername} = {}; # should be initialized in 5.7 and after |
3159
|
0
|
|
|
|
|
0
|
my $soapaction = $_->operation->soapAction; |
3160
|
0
|
|
0
|
|
|
0
|
my $invocationStyle = $_->operation->style || $default_style || "rpc"; |
3161
|
0
|
|
0
|
|
|
0
|
my $encodingStyle = $_->input->body->use || "encoded"; |
3162
|
0
|
|
0
|
|
|
0
|
my $namespace = $_->input->body->namespace || $tns; |
3163
|
0
|
|
|
|
|
0
|
my @parts; |
3164
|
0
|
|
|
|
|
0
|
foreach ($s->portType) { |
3165
|
0
|
0
|
|
|
|
0
|
next unless $_->name eq $porttype; |
3166
|
0
|
|
|
|
|
0
|
foreach ($_->operation) { |
3167
|
0
|
0
|
|
|
|
0
|
next unless $_->name eq $opername; |
3168
|
0
|
|
|
|
|
0
|
my $inputmessage = SOAP::Utils::disqualify($_->input->message); |
3169
|
0
|
|
|
|
|
0
|
foreach my $msg ($s->message) { |
3170
|
0
|
0
|
|
|
|
0
|
next unless $msg->name eq $inputmessage; |
3171
|
0
|
0
|
0
|
|
|
0
|
if ($invocationStyle eq "document" && $encodingStyle eq "literal") { |
3172
|
|
|
|
|
|
|
# warn "document/literal support is EXPERIMENTAL in SOAP::Lite" |
3173
|
|
|
|
|
|
|
# if !$has_warned && ($has_warned = 1); |
3174
|
0
|
|
|
|
|
0
|
my ($input_ns,$input_name) = SOAP::Utils::splitqname($msg->part->element); |
3175
|
0
|
|
|
|
|
0
|
foreach my $schema ($s->types->schema) { |
3176
|
0
|
|
|
|
|
0
|
foreach my $element ($schema->element) { |
3177
|
0
|
0
|
|
|
|
0
|
next unless $element->name eq $input_name; |
3178
|
0
|
|
|
|
|
0
|
push @parts,parse_schema_element($element); |
3179
|
|
|
|
|
|
|
} |
3180
|
0
|
|
|
|
|
0
|
$services{$opername}->{parameters} = [ @parts ]; |
3181
|
|
|
|
|
|
|
} |
3182
|
|
|
|
|
|
|
} |
3183
|
|
|
|
|
|
|
else { |
3184
|
|
|
|
|
|
|
# TODO - support all combinations of doc|rpc/lit|enc. |
3185
|
|
|
|
|
|
|
#warn "$invocationStyle/$encodingStyle is not supported in this version of SOAP::Lite"; |
3186
|
0
|
|
|
|
|
0
|
@parts = $msg->part; |
3187
|
0
|
|
|
|
|
0
|
$services{$opername}->{parameters} = [ @parts ]; |
3188
|
|
|
|
|
|
|
} |
3189
|
|
|
|
|
|
|
} |
3190
|
|
|
|
|
|
|
} |
3191
|
|
|
|
|
|
|
|
3192
|
0
|
|
|
|
|
0
|
for ($services{$opername}) { |
3193
|
0
|
|
|
|
|
0
|
$_->{endpoint} = $endpoint; |
3194
|
0
|
|
|
|
|
0
|
$_->{soapaction} = $soapaction; |
3195
|
0
|
|
|
|
|
0
|
$_->{namespace} = $namespace; |
3196
|
|
|
|
|
|
|
# $_->{parameters} = [@parts]; |
3197
|
|
|
|
|
|
|
} |
3198
|
|
|
|
|
|
|
} |
3199
|
|
|
|
|
|
|
} |
3200
|
|
|
|
|
|
|
} |
3201
|
|
|
|
|
|
|
} |
3202
|
|
|
|
|
|
|
# fix nonallowed characters in package name, and add 's' if started with digit |
3203
|
0
|
|
|
|
|
0
|
for ($name) { s/\W+/_/g; s/^(\d)/s$1/ } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3204
|
0
|
|
|
|
|
0
|
push @result, $name => \%services; |
3205
|
|
|
|
|
|
|
} |
3206
|
0
|
|
|
|
|
0
|
return @result; |
3207
|
|
|
|
|
|
|
} |
3208
|
|
|
|
|
|
|
|
3209
|
|
|
|
|
|
|
# ====================================================================== |
3210
|
|
|
|
|
|
|
|
3211
|
|
|
|
|
|
|
# Naming? SOAP::Service::Schema? |
3212
|
|
|
|
|
|
|
package SOAP::Schema; |
3213
|
|
|
|
|
|
|
|
3214
|
25
|
|
|
25
|
|
177
|
use Carp (); |
|
25
|
|
|
|
|
51
|
|
|
25
|
|
|
|
|
4185
|
|
3215
|
|
|
|
|
|
|
|
3216
|
0
|
|
|
0
|
|
0
|
sub DESTROY { SOAP::Trace::objects('()') } |
3217
|
|
|
|
|
|
|
|
3218
|
|
|
|
|
|
|
sub new { |
3219
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3220
|
0
|
0
|
|
|
|
0
|
return $self if ref $self; |
3221
|
0
|
0
|
|
|
|
0
|
unless (ref $self) { |
3222
|
0
|
|
|
|
|
0
|
my $class = $self; |
3223
|
0
|
|
|
|
|
0
|
require LWP::UserAgent; |
3224
|
0
|
|
|
|
|
0
|
$self = bless { |
3225
|
|
|
|
|
|
|
'_deserializer' => SOAP::Schema::Deserializer->new, |
3226
|
|
|
|
|
|
|
'_useragent' => LWP::UserAgent->new, |
3227
|
|
|
|
|
|
|
}, $class; |
3228
|
|
|
|
|
|
|
|
3229
|
0
|
|
|
|
|
0
|
SOAP::Trace::objects('()'); |
3230
|
|
|
|
|
|
|
} |
3231
|
|
|
|
|
|
|
|
3232
|
0
|
0
|
0
|
|
|
0
|
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); |
3233
|
25
|
|
|
25
|
|
139
|
no strict qw(refs); |
|
25
|
|
|
|
|
45
|
|
|
25
|
|
|
|
|
3581
|
|
3234
|
0
|
|
|
|
|
0
|
while (@_) { |
3235
|
0
|
|
|
|
|
0
|
my $method = shift; |
3236
|
0
|
0
|
|
|
|
0
|
$self->$method(shift) if $self->can($method) |
3237
|
|
|
|
|
|
|
} |
3238
|
|
|
|
|
|
|
|
3239
|
0
|
|
|
|
|
0
|
return $self; |
3240
|
|
|
|
|
|
|
} |
3241
|
|
|
|
|
|
|
|
3242
|
|
|
|
|
|
|
sub schema { |
3243
|
0
|
|
|
0
|
|
0
|
warn "SOAP::Schema->schema has been deprecated. " |
3244
|
|
|
|
|
|
|
. "Please use SOAP::Schema->schema_url instead."; |
3245
|
0
|
|
|
|
|
0
|
return shift->schema_url(@_); |
3246
|
|
|
|
|
|
|
} |
3247
|
|
|
|
|
|
|
|
3248
|
|
|
|
|
|
|
sub BEGIN { |
3249
|
25
|
|
|
25
|
|
150
|
no strict 'refs'; |
|
25
|
|
|
|
|
48
|
|
|
25
|
|
|
|
|
2646
|
|
3250
|
25
|
|
|
25
|
|
74
|
for my $method (qw(deserializer schema_url services useragent stub cache_dir cache_ttl)) { |
3251
|
175
|
|
|
|
|
356
|
my $field = '_' . $method; |
3252
|
|
|
|
|
|
|
*$method = sub { |
3253
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3254
|
0
|
0
|
|
|
|
0
|
@_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; |
3255
|
|
|
|
|
|
|
} |
3256
|
175
|
|
|
|
|
35652
|
} |
3257
|
|
|
|
|
|
|
} |
3258
|
|
|
|
|
|
|
|
3259
|
|
|
|
|
|
|
sub parse { |
3260
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3261
|
0
|
|
|
|
|
0
|
my $s = $self->deserializer->deserialize($self->access)->root; |
3262
|
|
|
|
|
|
|
# here should be something that defines what schema description we want to use |
3263
|
0
|
|
|
|
|
0
|
$self->services({SOAP::Schema::WSDL->base($self->schema_url)->useragent($self->useragent)->parse($s, @_)}); |
3264
|
|
|
|
|
|
|
|
3265
|
|
|
|
|
|
|
} |
3266
|
|
|
|
|
|
|
|
3267
|
|
|
|
|
|
|
sub refresh_cache { |
3268
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
3269
|
0
|
|
|
|
|
0
|
my ($filename,$contents) = @_; |
3270
|
0
|
0
|
|
|
|
0
|
open CACHE,">$filename" or Carp::croak "Could not open cache file for writing: $!"; |
3271
|
0
|
|
|
|
|
0
|
print CACHE $contents; |
3272
|
0
|
|
|
|
|
0
|
close CACHE; |
3273
|
|
|
|
|
|
|
} |
3274
|
|
|
|
|
|
|
|
3275
|
|
|
|
|
|
|
sub load { |
3276
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3277
|
0
|
|
|
|
|
0
|
local $^W; # suppress warnings about redefining |
3278
|
0
|
0
|
|
|
|
0
|
foreach (keys %{$self->services || Carp::croak 'Nothing to load. Schema is not specified'}) { |
|
0
|
|
|
|
|
0
|
|
3279
|
|
|
|
|
|
|
# TODO - check age of cached file, and delete if older than configured amount |
3280
|
0
|
0
|
|
|
|
0
|
if ($self->cache_dir) { |
3281
|
0
|
|
|
|
|
0
|
my $cached_file = File::Spec->catfile($self->cache_dir,$_.".pm"); |
3282
|
0
|
|
0
|
|
|
0
|
my $ttl = $self->cache_ttl || $SOAP::Constants::DEFAULT_CACHE_TTL; |
3283
|
0
|
|
|
|
|
0
|
open (CACHE, "<$cached_file"); |
3284
|
0
|
0
|
|
|
|
0
|
my @stat = stat($cached_file) unless eof(CACHE); |
3285
|
0
|
|
|
|
|
0
|
close CACHE; |
3286
|
0
|
0
|
|
|
|
0
|
if (@stat) { |
3287
|
|
|
|
|
|
|
# Cache exists |
3288
|
0
|
|
|
|
|
0
|
my $cache_lived = time() - $stat[9]; |
3289
|
0
|
0
|
0
|
|
|
0
|
if ($ttl > 0 && $cache_lived > $ttl) { |
3290
|
0
|
|
|
|
|
0
|
$self->refresh_cache($cached_file,$self->generate_stub($_)); |
3291
|
|
|
|
|
|
|
} |
3292
|
|
|
|
|
|
|
} |
3293
|
|
|
|
|
|
|
else { |
3294
|
|
|
|
|
|
|
# Cache doesn't exist |
3295
|
0
|
|
|
|
|
0
|
$self->refresh_cache($cached_file,$self->generate_stub($_)); |
3296
|
|
|
|
|
|
|
} |
3297
|
0
|
|
|
|
|
0
|
push @INC,$self->cache_dir; |
3298
|
0
|
0
|
|
|
|
0
|
eval "require $_" or Carp::croak "Could not load cached file: $@"; |
3299
|
|
|
|
|
|
|
} |
3300
|
|
|
|
|
|
|
else { |
3301
|
0
|
0
|
|
|
|
0
|
eval $self->generate_stub($_) or Carp::croak "Bad stub: $@"; |
3302
|
|
|
|
|
|
|
} |
3303
|
|
|
|
|
|
|
} |
3304
|
0
|
|
|
|
|
0
|
$self; |
3305
|
|
|
|
|
|
|
} |
3306
|
|
|
|
|
|
|
|
3307
|
|
|
|
|
|
|
sub access { |
3308
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3309
|
0
|
|
0
|
|
|
0
|
my $url = shift || $self->schema_url || Carp::croak 'Nothing to access. URL is not specified'; |
3310
|
0
|
0
|
|
|
|
0
|
$self->useragent->env_proxy if $ENV{'HTTP_proxy'}; |
3311
|
|
|
|
|
|
|
|
3312
|
0
|
|
|
|
|
0
|
my $req = HTTP::Request->new(GET => $url); |
3313
|
0
|
0
|
0
|
|
|
0
|
$req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'}) |
3314
|
|
|
|
|
|
|
if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'}); |
3315
|
|
|
|
|
|
|
|
3316
|
0
|
|
|
|
|
0
|
my $resp = $self->useragent->request($req); |
3317
|
0
|
0
|
|
|
|
0
|
$resp->is_success ? $resp->content : die "Service description '$url' can't be loaded: ", $resp->status_line, "\n"; |
3318
|
|
|
|
|
|
|
} |
3319
|
|
|
|
|
|
|
|
3320
|
|
|
|
|
|
|
sub generate_stub { |
3321
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3322
|
0
|
|
|
|
|
0
|
my $package = shift; |
3323
|
0
|
|
|
|
|
0
|
my $services = $self->services->{$package}; |
3324
|
0
|
|
|
|
|
0
|
my $schema_url = $self->schema_url; |
3325
|
|
|
|
|
|
|
|
3326
|
0
|
|
|
|
|
0
|
$self->{'_stub'} = <<"EOP"; |
3327
|
0
|
|
|
|
|
0
|
package $package; |
3328
|
|
|
|
|
|
|
# Generated by SOAP::Lite (v$SOAP::Lite::VERSION) for Perl -- soaplite.com |
3329
|
|
|
|
|
|
|
# Copyright (C) 2000-2006 Paul Kulchenko, Byrne Reese |
3330
|
|
|
|
|
|
|
# -- generated at [@{[scalar localtime]}] |
3331
|
|
|
|
|
|
|
EOP |
3332
|
0
|
0
|
|
|
|
0
|
$self->{'_stub'} .= "# -- generated from $schema_url\n" if $schema_url; |
3333
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= 'my %methods = ('."\n"; |
3334
|
0
|
|
|
|
|
0
|
foreach my $service (keys %$services) { |
3335
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= "'$service' => {\n"; |
3336
|
0
|
|
|
|
|
0
|
foreach (qw(endpoint soapaction namespace)) { |
3337
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= " $_ => '".$services->{$service}{$_}."',\n"; |
3338
|
|
|
|
|
|
|
} |
3339
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= " parameters => [\n"; |
3340
|
0
|
|
|
|
|
0
|
foreach (@{$services->{$service}{parameters}}) { |
|
0
|
|
|
|
|
0
|
|
3341
|
|
|
|
|
|
|
# This is a workaround for https://sourceforge.net/tracker/index.php?func=detail&aid=2001592&group_id=66000&atid=513017 |
3342
|
0
|
0
|
|
|
|
0
|
next unless ref $_; |
3343
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= " SOAP::Data->new(name => '".$_->name."', type => '".$_->type."', attr => {"; |
3344
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= do { |
3345
|
0
|
|
|
|
|
0
|
my %attr = %{$_->attr}; |
|
0
|
|
|
|
|
0
|
|
3346
|
0
|
|
|
|
|
0
|
join(', ', map {"'$_' => '$attr{$_}'"} |
|
0
|
|
|
|
|
0
|
|
3347
|
0
|
|
|
|
|
0
|
grep {/^xmlns:(?!-)/} |
3348
|
|
|
|
|
|
|
keys %attr); |
3349
|
|
|
|
|
|
|
}; |
3350
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= "}),\n"; |
3351
|
|
|
|
|
|
|
} |
3352
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= " ], # end parameters\n"; |
3353
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= " }, # end $service\n"; |
3354
|
|
|
|
|
|
|
} |
3355
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= "); # end my %methods\n"; |
3356
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= <<'EOP'; |
3357
|
|
|
|
|
|
|
|
3358
|
|
|
|
|
|
|
use SOAP::Lite; |
3359
|
|
|
|
|
|
|
use Exporter; |
3360
|
|
|
|
|
|
|
use Carp (); |
3361
|
|
|
|
|
|
|
|
3362
|
|
|
|
|
|
|
use vars qw(@ISA $AUTOLOAD @EXPORT_OK %EXPORT_TAGS); |
3363
|
|
|
|
|
|
|
@ISA = qw(Exporter SOAP::Lite); |
3364
|
|
|
|
|
|
|
@EXPORT_OK = (keys %methods); |
3365
|
|
|
|
|
|
|
%EXPORT_TAGS = ('all' => [@EXPORT_OK]); |
3366
|
|
|
|
|
|
|
|
3367
|
|
|
|
|
|
|
sub _call { |
3368
|
|
|
|
|
|
|
my ($self, $method) = (shift, shift); |
3369
|
|
|
|
|
|
|
my $name = UNIVERSAL::isa($method => 'SOAP::Data') ? $method->name : $method; |
3370
|
|
|
|
|
|
|
my %method = %{$methods{$name}}; |
3371
|
|
|
|
|
|
|
$self->proxy($method{endpoint} || Carp::croak "No server address (proxy) specified") |
3372
|
|
|
|
|
|
|
unless $self->proxy; |
3373
|
|
|
|
|
|
|
my @templates = @{$method{parameters}}; |
3374
|
|
|
|
|
|
|
my @parameters = (); |
3375
|
|
|
|
|
|
|
foreach my $param (@_) { |
3376
|
|
|
|
|
|
|
if (@templates) { |
3377
|
|
|
|
|
|
|
my $template = shift @templates; |
3378
|
|
|
|
|
|
|
my ($prefix,$typename) = SOAP::Utils::splitqname($template->type); |
3379
|
|
|
|
|
|
|
my $method = 'as_'.$typename; |
3380
|
|
|
|
|
|
|
# TODO - if can('as_'.$typename) {...} |
3381
|
|
|
|
|
|
|
my $result = $self->serializer->$method($param, $template->name, $template->type, $template->attr); |
3382
|
|
|
|
|
|
|
push(@parameters, $template->value($result->[2])); |
3383
|
|
|
|
|
|
|
} |
3384
|
|
|
|
|
|
|
else { |
3385
|
|
|
|
|
|
|
push(@parameters, $param); |
3386
|
|
|
|
|
|
|
} |
3387
|
|
|
|
|
|
|
} |
3388
|
|
|
|
|
|
|
$self->endpoint($method{endpoint}) |
3389
|
|
|
|
|
|
|
->ns($method{namespace}) |
3390
|
|
|
|
|
|
|
->on_action(sub{qq!"$method{soapaction}"!}); |
3391
|
|
|
|
|
|
|
EOP |
3392
|
0
|
|
|
|
|
0
|
my $namespaces = $self->deserializer->ids->[1]; |
3393
|
0
|
|
|
|
|
0
|
foreach my $key (keys %{$namespaces}) { |
|
0
|
|
|
|
|
0
|
|
3394
|
0
|
|
|
|
|
0
|
my ($ns,$prefix) = SOAP::Utils::splitqname($key); |
3395
|
0
|
0
|
0
|
|
|
0
|
$self->{'_stub'} .= ' $self->serializer->register_ns("'.$namespaces->{$key}.'","'.$prefix.'");'."\n" |
3396
|
|
|
|
|
|
|
if (defined $ns && ($ns eq "xmlns")); |
3397
|
|
|
|
|
|
|
} |
3398
|
0
|
|
|
|
|
0
|
$self->{'_stub'} .= <<'EOP'; |
3399
|
|
|
|
|
|
|
my $som = $self->SUPER::call($method => @parameters); |
3400
|
|
|
|
|
|
|
if ($self->want_som) { |
3401
|
|
|
|
|
|
|
return $som; |
3402
|
|
|
|
|
|
|
} |
3403
|
|
|
|
|
|
|
UNIVERSAL::isa($som => 'SOAP::SOM') ? wantarray ? $som->paramsall : $som->result : $som; |
3404
|
|
|
|
|
|
|
} |
3405
|
|
|
|
|
|
|
|
3406
|
|
|
|
|
|
|
sub BEGIN { |
3407
|
|
|
|
|
|
|
no strict 'refs'; |
3408
|
|
|
|
|
|
|
for my $method (qw(want_som)) { |
3409
|
|
|
|
|
|
|
my $field = '_' . $method; |
3410
|
|
|
|
|
|
|
*$method = sub { |
3411
|
|
|
|
|
|
|
my $self = shift->new; |
3412
|
|
|
|
|
|
|
@_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; |
3413
|
|
|
|
|
|
|
} |
3414
|
|
|
|
|
|
|
} |
3415
|
|
|
|
|
|
|
} |
3416
|
|
|
|
|
|
|
no strict 'refs'; |
3417
|
|
|
|
|
|
|
for my $method (@EXPORT_OK) { |
3418
|
|
|
|
|
|
|
my %method = %{$methods{$method}}; |
3419
|
|
|
|
|
|
|
*$method = sub { |
3420
|
|
|
|
|
|
|
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__) |
3421
|
|
|
|
|
|
|
? ref $_[0] |
3422
|
|
|
|
|
|
|
? shift # OBJECT |
3423
|
|
|
|
|
|
|
# CLASS, either get self or create new and assign to self |
3424
|
|
|
|
|
|
|
: (shift->self || __PACKAGE__->self(__PACKAGE__->new)) |
3425
|
|
|
|
|
|
|
# function call, either get self or create new and assign to self |
3426
|
|
|
|
|
|
|
: (__PACKAGE__->self || __PACKAGE__->self(__PACKAGE__->new)); |
3427
|
|
|
|
|
|
|
$self->_call($method, @_); |
3428
|
|
|
|
|
|
|
} |
3429
|
|
|
|
|
|
|
} |
3430
|
|
|
|
|
|
|
|
3431
|
|
|
|
|
|
|
sub AUTOLOAD { |
3432
|
|
|
|
|
|
|
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); |
3433
|
|
|
|
|
|
|
return if $method eq 'DESTROY' || $method eq 'want_som'; |
3434
|
|
|
|
|
|
|
die "Unrecognized method '$method'. List of available method(s): @EXPORT_OK\n"; |
3435
|
|
|
|
|
|
|
} |
3436
|
|
|
|
|
|
|
|
3437
|
|
|
|
|
|
|
1; |
3438
|
|
|
|
|
|
|
EOP |
3439
|
0
|
|
|
|
|
0
|
return $self->stub; |
3440
|
|
|
|
|
|
|
} |
3441
|
|
|
|
|
|
|
|
3442
|
|
|
|
|
|
|
# ====================================================================== |
3443
|
|
|
|
|
|
|
|
3444
|
|
|
|
|
|
|
package SOAP; |
3445
|
|
|
|
|
|
|
|
3446
|
25
|
|
|
25
|
|
264
|
use vars qw($AUTOLOAD); |
|
25
|
|
|
|
|
60
|
|
|
25
|
|
|
|
|
1485
|
|
3447
|
|
|
|
|
|
|
require URI; |
3448
|
|
|
|
|
|
|
|
3449
|
|
|
|
|
|
|
my $soap; # shared between SOAP and SOAP::Lite packages |
3450
|
|
|
|
|
|
|
|
3451
|
|
|
|
|
|
|
{ |
3452
|
25
|
|
|
25
|
|
146
|
no strict 'refs'; |
|
25
|
|
|
|
|
43
|
|
|
25
|
|
|
|
|
13347
|
|
3453
|
|
|
|
|
|
|
*AUTOLOAD = sub { |
3454
|
0
|
|
|
0
|
|
0
|
local($1,$2); |
3455
|
0
|
|
|
|
|
0
|
my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/; |
3456
|
0
|
0
|
|
|
|
0
|
return if $method eq 'DESTROY'; |
3457
|
|
|
|
|
|
|
|
3458
|
0
|
0
|
0
|
|
|
0
|
my $soap = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite') |
|
|
|
0
|
|
|
|
|
3459
|
|
|
|
|
|
|
? $_[0] |
3460
|
|
|
|
|
|
|
: $soap |
3461
|
|
|
|
|
|
|
|| die "SOAP:: prefix shall only be used in combination with +autodispatch option\n"; |
3462
|
|
|
|
|
|
|
|
3463
|
0
|
|
|
|
|
0
|
my $uri = URI->new($soap->uri); |
3464
|
0
|
|
|
|
|
0
|
my $currenturi = $uri->path; |
3465
|
0
|
0
|
0
|
|
|
0
|
$package = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite') |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
3466
|
|
|
|
|
|
|
? $currenturi |
3467
|
|
|
|
|
|
|
: $package eq 'SOAP' |
3468
|
|
|
|
|
|
|
? ref $_[0] || ($_[0] eq 'SOAP' |
3469
|
|
|
|
|
|
|
? $currenturi || Carp::croak "URI is not specified for method call" |
3470
|
|
|
|
|
|
|
: $_[0]) |
3471
|
|
|
|
|
|
|
: $package eq 'main' |
3472
|
|
|
|
|
|
|
? $currenturi || $package |
3473
|
|
|
|
|
|
|
: $package; |
3474
|
|
|
|
|
|
|
|
3475
|
|
|
|
|
|
|
# drop first parameter if it's a class name |
3476
|
|
|
|
|
|
|
{ |
3477
|
0
|
|
|
|
|
0
|
my $pack = $package; |
|
0
|
|
|
|
|
0
|
|
3478
|
0
|
|
|
|
|
0
|
for ($pack) { s!^/!!; s!/!::!g; } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3479
|
0
|
0
|
0
|
|
|
0
|
shift @_ if @_ && !ref $_[0] && ($_[0] eq $pack || $_[0] eq 'SOAP') |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
3480
|
|
|
|
|
|
|
|| ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite'); |
3481
|
|
|
|
|
|
|
} |
3482
|
|
|
|
|
|
|
|
3483
|
0
|
|
|
|
|
0
|
for ($package) { s!::!/!g; s!^/?!/!; } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3484
|
0
|
|
|
|
|
0
|
$uri->path($package); |
3485
|
|
|
|
|
|
|
|
3486
|
0
|
|
|
|
|
0
|
my $som = $soap->uri($uri->as_string)->call($method => @_); |
3487
|
0
|
0
|
|
|
|
0
|
UNIVERSAL::isa($som => 'SOAP::SOM') |
|
|
0
|
|
|
|
|
|
3488
|
|
|
|
|
|
|
? wantarray |
3489
|
|
|
|
|
|
|
? $som->paramsall |
3490
|
|
|
|
|
|
|
: $som->result |
3491
|
|
|
|
|
|
|
: $som; |
3492
|
|
|
|
|
|
|
}; |
3493
|
|
|
|
|
|
|
} |
3494
|
|
|
|
|
|
|
|
3495
|
|
|
|
|
|
|
# ====================================================================== |
3496
|
|
|
|
|
|
|
|
3497
|
|
|
|
|
|
|
package SOAP::Lite; |
3498
|
|
|
|
|
|
|
|
3499
|
25
|
|
|
25
|
|
159
|
use vars qw($AUTOLOAD @ISA); |
|
25
|
|
|
|
|
65
|
|
|
25
|
|
|
|
|
1373
|
|
3500
|
25
|
|
|
25
|
|
144
|
use Carp (); |
|
25
|
|
|
|
|
58
|
|
|
25
|
|
|
|
|
513
|
|
3501
|
|
|
|
|
|
|
|
3502
|
25
|
|
|
25
|
|
167
|
use SOAP::Lite::Utils; |
|
25
|
|
|
|
|
48
|
|
|
25
|
|
|
|
|
222
|
|
3503
|
25
|
|
|
25
|
|
31353
|
use SOAP::Constants; |
|
25
|
|
|
|
|
85
|
|
|
25
|
|
|
|
|
1038
|
|
3504
|
25
|
|
|
25
|
|
24562
|
use SOAP::Packager; |
|
25
|
|
|
|
|
88
|
|
|
25
|
|
|
|
|
982
|
|
3505
|
|
|
|
|
|
|
|
3506
|
25
|
|
|
25
|
|
169
|
use Scalar::Util qw(weaken blessed); |
|
25
|
|
|
|
|
163
|
|
|
25
|
|
|
|
|
11600
|
|
3507
|
|
|
|
|
|
|
|
3508
|
|
|
|
|
|
|
@ISA = qw(SOAP::Cloneable); |
3509
|
|
|
|
|
|
|
|
3510
|
|
|
|
|
|
|
# provide access to global/autodispatched object |
3511
|
|
|
|
|
|
|
sub self { |
3512
|
0
|
0
|
|
0
|
1
|
0
|
@_ > 1 |
3513
|
|
|
|
|
|
|
? $soap = $_[1] |
3514
|
|
|
|
|
|
|
: $soap |
3515
|
|
|
|
|
|
|
} |
3516
|
|
|
|
|
|
|
|
3517
|
|
|
|
|
|
|
# no more warnings about "used only once" |
3518
|
|
|
|
|
|
|
*UNIVERSAL::AUTOLOAD if 0; |
3519
|
|
|
|
|
|
|
|
3520
|
0
|
|
|
0
|
0
|
0
|
sub autodispatched { \&{*UNIVERSAL::AUTOLOAD} eq \&{*SOAP::AUTOLOAD} }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3521
|
|
|
|
|
|
|
|
3522
|
|
|
|
|
|
|
sub soapversion { |
3523
|
51
|
|
|
51
|
1
|
124
|
my $self = shift; |
3524
|
51
|
100
|
|
|
|
674
|
my $version = shift or return $SOAP::Constants::SOAP_VERSION; |
3525
|
|
|
|
|
|
|
|
3526
|
0
|
|
|
|
|
0
|
($version) = grep { |
3527
|
25
|
50
|
|
|
|
445
|
$SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV} eq $version |
3528
|
|
|
|
|
|
|
} keys %SOAP::Constants::SOAP_VERSIONS |
3529
|
|
|
|
|
|
|
unless exists $SOAP::Constants::SOAP_VERSIONS{$version}; |
3530
|
|
|
|
|
|
|
|
3531
|
25
|
50
|
33
|
|
|
372
|
die qq!$SOAP::Constants::WRONG_VERSION Supported versions:\n@{[ |
|
0
|
|
|
|
|
0
|
|
3532
|
0
|
|
|
|
|
0
|
join "\n", map {" $_ ($SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV})"} keys %SOAP::Constants::SOAP_VERSIONS |
3533
|
|
|
|
|
|
|
]}\n! |
3534
|
|
|
|
|
|
|
unless defined($version) && defined(my $def = $SOAP::Constants::SOAP_VERSIONS{$version}); |
3535
|
|
|
|
|
|
|
|
3536
|
25
|
|
|
|
|
150
|
foreach (keys %$def) { |
3537
|
125
|
|
|
|
|
7184
|
eval "\$SOAP::Constants::$_ = '$SOAP::Constants::SOAP_VERSIONS{$version}->{$_}'"; |
3538
|
|
|
|
|
|
|
} |
3539
|
|
|
|
|
|
|
|
3540
|
25
|
|
|
|
|
258
|
$SOAP::Constants::SOAP_VERSION = $version; |
3541
|
|
|
|
|
|
|
|
3542
|
25
|
|
|
|
|
1066
|
return $self; |
3543
|
|
|
|
|
|
|
} |
3544
|
|
|
|
|
|
|
|
3545
|
25
|
|
|
25
|
|
165
|
BEGIN { SOAP::Lite->soapversion(1.1) } |
3546
|
|
|
|
|
|
|
|
3547
|
|
|
|
|
|
|
sub import { |
3548
|
44
|
|
|
44
|
|
287
|
my $pkg = shift; |
3549
|
44
|
|
|
|
|
224
|
my $caller = caller; |
3550
|
25
|
|
|
25
|
|
140
|
no strict 'refs'; |
|
25
|
|
|
|
|
46
|
|
|
25
|
|
|
|
|
3868
|
|
3551
|
|
|
|
|
|
|
# emulate 'use SOAP::Lite 0.99' behavior |
3552
|
44
|
50
|
66
|
|
|
335
|
$pkg->require_version(shift) if defined $_[0] && $_[0] =~ /^\d/; |
3553
|
|
|
|
|
|
|
|
3554
|
44
|
|
|
|
|
75199
|
while (@_) { |
3555
|
8
|
|
|
|
|
17
|
my $command = shift; |
3556
|
|
|
|
|
|
|
|
3557
|
0
|
|
|
|
|
0
|
my @parameters = UNIVERSAL::isa($_[0] => 'ARRAY') |
3558
|
8
|
50
|
66
|
|
|
105
|
? @{shift()} |
|
|
100
|
|
|
|
|
|
3559
|
|
|
|
|
|
|
: shift |
3560
|
|
|
|
|
|
|
if @_ && $command ne 'autodispatch'; |
3561
|
|
|
|
|
|
|
|
3562
|
8
|
100
|
66
|
|
|
140
|
if ($command eq 'autodispatch' || $command eq 'dispatch_from') { |
|
|
50
|
33
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3563
|
1
|
|
33
|
|
|
9
|
$soap = ($soap||$pkg)->new; |
3564
|
25
|
|
|
25
|
|
145
|
no strict 'refs'; |
|
25
|
|
|
|
|
46
|
|
|
25
|
|
|
|
|
16641
|
|
3565
|
1
|
50
|
|
|
|
6
|
foreach ($command eq 'autodispatch' |
3566
|
|
|
|
|
|
|
? 'UNIVERSAL' |
3567
|
|
|
|
|
|
|
: @parameters |
3568
|
|
|
|
|
|
|
) { |
3569
|
1
|
|
|
|
|
2
|
my $sub = "${_}::AUTOLOAD"; |
3570
|
1
|
|
|
|
|
13
|
defined &{*$sub} |
|
0
|
|
|
|
|
0
|
|
3571
|
1
|
0
|
|
|
|
3
|
? (\&{*$sub} eq \&{*SOAP::AUTOLOAD} |
|
0
|
50
|
|
|
|
0
|
|
3572
|
|
|
|
|
|
|
? () |
3573
|
|
|
|
|
|
|
: Carp::croak "$sub already assigned and won't work with DISPATCH. Died") |
3574
|
|
|
|
|
|
|
: (*$sub = *SOAP::AUTOLOAD); |
3575
|
|
|
|
|
|
|
} |
3576
|
|
|
|
|
|
|
} |
3577
|
|
|
|
|
|
|
elsif ($command eq 'service') { |
3578
|
0
|
|
|
|
|
0
|
foreach (keys %{SOAP::Schema->schema_url(shift(@parameters))->parse(@parameters)->load->services}) { |
|
0
|
|
|
|
|
0
|
|
3579
|
0
|
|
|
|
|
0
|
$_->export_to_level(1, undef, ':all'); |
3580
|
|
|
|
|
|
|
} |
3581
|
|
|
|
|
|
|
} |
3582
|
|
|
|
|
|
|
elsif ($command eq 'debug' || $command eq 'trace') { |
3583
|
0
|
0
|
|
|
|
0
|
SOAP::Trace->import(@parameters ? @parameters : 'all'); |
3584
|
|
|
|
|
|
|
} |
3585
|
|
|
|
|
|
|
elsif ($command eq 'import') { |
3586
|
0
|
|
|
|
|
0
|
local $^W; # suppress warnings about redefining |
3587
|
0
|
|
|
|
|
0
|
my $package = shift(@parameters); |
3588
|
0
|
0
|
|
|
|
0
|
$package->export_to_level(1, undef, @parameters ? @parameters : ':all') if $package; |
|
|
0
|
|
|
|
|
|
3589
|
|
|
|
|
|
|
} |
3590
|
|
|
|
|
|
|
else { |
3591
|
7
|
50
|
66
|
|
|
42
|
Carp::carp "Odd (wrong?) number of parameters in import(), still continue" if $^W && !(@parameters & 1); |
3592
|
7
|
|
66
|
|
|
129
|
$soap = ($soap||$pkg)->$command(@parameters); |
3593
|
|
|
|
|
|
|
} |
3594
|
|
|
|
|
|
|
} |
3595
|
|
|
|
|
|
|
} |
3596
|
|
|
|
|
|
|
|
3597
|
14
|
|
|
14
|
|
526
|
sub DESTROY { SOAP::Trace::objects('()') } |
3598
|
|
|
|
|
|
|
|
3599
|
|
|
|
|
|
|
sub new { |
3600
|
208
|
|
|
208
|
1
|
3271
|
my $self = shift; |
3601
|
208
|
100
|
|
|
|
702
|
return $self if ref $self; |
3602
|
19
|
50
|
|
|
|
80
|
unless (ref $self) { |
3603
|
19
|
|
|
|
|
79
|
my $class = $self; |
3604
|
|
|
|
|
|
|
# Check whether we can clone. Only the SAME class allowed, no inheritance |
3605
|
|
|
|
|
|
|
$self = ref($soap) eq $class ? $soap->clone : { |
3606
|
|
|
|
|
|
|
_transport => SOAP::Transport->new, |
3607
|
|
|
|
|
|
|
_serializer => SOAP::Serializer->new, |
3608
|
|
|
|
|
|
|
_deserializer => SOAP::Deserializer->new, |
3609
|
|
|
|
|
|
|
_packager => SOAP::Packager::MIME->new, |
3610
|
|
|
|
|
|
|
_schema => undef, |
3611
|
|
|
|
|
|
|
_autoresult => 0, |
3612
|
12
|
|
100
|
12
|
|
181
|
_on_action => sub { sprintf '"%s#%s"', shift || '', shift }, |
3613
|
1
|
50
|
|
1
|
|
7
|
_on_fault => sub {ref $_[1] ? return $_[1] : Carp::croak $_[0]->transport->is_success ? $_[1] : $_[0]->transport->status}, |
|
|
50
|
|
|
|
|
|
3614
|
19
|
100
|
|
|
|
251
|
}; |
3615
|
19
|
|
|
|
|
73
|
bless $self => $class; |
3616
|
19
|
|
66
|
|
|
96
|
$self->on_nonserialized($self->on_nonserialized || $self->serializer->on_nonserialized); |
3617
|
19
|
|
|
|
|
113
|
SOAP::Trace::objects('()'); |
3618
|
|
|
|
|
|
|
} |
3619
|
|
|
|
|
|
|
|
3620
|
19
|
50
|
66
|
|
|
105
|
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1); |
3621
|
25
|
|
|
25
|
|
185
|
no strict qw(refs); |
|
25
|
|
|
|
|
57
|
|
|
25
|
|
|
|
|
8393
|
|
3622
|
19
|
|
|
|
|
81
|
while (@_) { |
3623
|
3
|
|
|
|
|
10
|
my($method, $params) = splice(@_,0,2); |
3624
|
3
|
50
|
0
|
|
|
38
|
$self->can($method) |
|
|
50
|
|
|
|
|
|
3625
|
|
|
|
|
|
|
? $self->$method(ref $params eq 'ARRAY' ? @$params : $params) |
3626
|
|
|
|
|
|
|
: $^W && Carp::carp "Unrecognized parameter '$method' in new()" |
3627
|
|
|
|
|
|
|
} |
3628
|
|
|
|
|
|
|
|
3629
|
19
|
|
|
|
|
55
|
return $self; |
3630
|
|
|
|
|
|
|
} |
3631
|
|
|
|
|
|
|
|
3632
|
|
|
|
|
|
|
sub init_context { |
3633
|
12
|
|
|
12
|
0
|
54
|
my $self = shift->new; |
3634
|
12
|
|
|
|
|
101
|
$self->{'_deserializer'}->{'_context'} = $self; |
3635
|
|
|
|
|
|
|
# weaken circular reference to avoid a memory hole |
3636
|
12
|
|
|
|
|
87
|
weaken $self->{'_deserializer'}->{'_context'}; |
3637
|
|
|
|
|
|
|
|
3638
|
12
|
|
|
|
|
41
|
$self->{'_serializer'}->{'_context'} = $self; |
3639
|
|
|
|
|
|
|
# weaken circular reference to avoid a memory hole |
3640
|
12
|
|
|
|
|
71
|
weaken $self->{'_serializer'}->{'_context'}; |
3641
|
|
|
|
|
|
|
} |
3642
|
|
|
|
|
|
|
|
3643
|
|
|
|
|
|
|
# Naming? wsdl_parser |
3644
|
|
|
|
|
|
|
sub schema { |
3645
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
3646
|
0
|
0
|
|
|
|
0
|
if (@_) { |
3647
|
0
|
|
|
|
|
0
|
$self->{'_schema'} = shift; |
3648
|
0
|
|
|
|
|
0
|
return $self; |
3649
|
|
|
|
|
|
|
} |
3650
|
|
|
|
|
|
|
else { |
3651
|
0
|
0
|
|
|
|
0
|
if (!defined $self->{'_schema'}) { |
3652
|
0
|
|
|
|
|
0
|
$self->{'_schema'} = SOAP::Schema->new; |
3653
|
|
|
|
|
|
|
} |
3654
|
0
|
|
|
|
|
0
|
return $self->{'_schema'}; |
3655
|
|
|
|
|
|
|
} |
3656
|
|
|
|
|
|
|
} |
3657
|
|
|
|
|
|
|
|
3658
|
|
|
|
|
|
|
sub BEGIN { |
3659
|
25
|
|
|
25
|
|
150
|
no strict 'refs'; |
|
25
|
|
|
|
|
163
|
|
|
25
|
|
|
|
|
8066
|
|
3660
|
25
|
|
|
25
|
|
77
|
for my $method (qw(serializer deserializer)) { |
3661
|
50
|
|
|
|
|
128
|
my $field = '_' . $method; |
3662
|
|
|
|
|
|
|
*$method = sub { |
3663
|
52
|
|
|
52
|
|
190
|
my $self = shift->new; |
3664
|
52
|
50
|
|
|
|
164
|
if (@_) { |
3665
|
0
|
|
|
|
|
0
|
my $context = $self->{$field}->{'_context'}; # save the old context |
3666
|
0
|
|
|
|
|
0
|
$self->{$field} = shift; |
3667
|
0
|
|
|
|
|
0
|
$self->{$field}->{'_context'} = $context; # restore the old context |
3668
|
0
|
|
|
|
|
0
|
return $self; |
3669
|
|
|
|
|
|
|
} |
3670
|
|
|
|
|
|
|
else { |
3671
|
52
|
|
|
|
|
339
|
return $self->{$field}; |
3672
|
|
|
|
|
|
|
} |
3673
|
|
|
|
|
|
|
} |
3674
|
50
|
|
|
|
|
532
|
} |
3675
|
|
|
|
|
|
|
|
3676
|
|
|
|
|
|
|
__PACKAGE__->__mk_accessors( |
3677
|
25
|
|
|
|
|
192
|
qw(endpoint transport outputxml autoresult packager) |
3678
|
|
|
|
|
|
|
); |
3679
|
|
|
|
|
|
|
# for my $method () { |
3680
|
|
|
|
|
|
|
# my $field = '_' . $method; |
3681
|
|
|
|
|
|
|
# *$method = sub { |
3682
|
|
|
|
|
|
|
# my $self = shift->new; |
3683
|
|
|
|
|
|
|
# @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; |
3684
|
|
|
|
|
|
|
# } |
3685
|
|
|
|
|
|
|
# } |
3686
|
25
|
|
|
|
|
70
|
for my $method (qw(on_action on_fault on_nonserialized)) { |
3687
|
75
|
|
|
|
|
154
|
my $field = '_' . $method; |
3688
|
|
|
|
|
|
|
*$method = sub { |
3689
|
90
|
|
|
90
|
|
325
|
my $self = shift->new; |
3690
|
90
|
100
|
|
|
|
629
|
return $self->{$field} unless @_; |
3691
|
35
|
|
|
|
|
74
|
local $@; |
3692
|
|
|
|
|
|
|
# commented out because that 'eval' was unsecure |
3693
|
|
|
|
|
|
|
# > ref $_[0] eq 'CODE' ? shift : eval shift; |
3694
|
|
|
|
|
|
|
# Am I paranoid enough? |
3695
|
35
|
|
|
|
|
92
|
$self->{$field} = shift; |
3696
|
35
|
50
|
|
|
|
166
|
Carp::croak $@ if $@; |
3697
|
35
|
50
|
|
|
|
153
|
Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)" |
3698
|
|
|
|
|
|
|
unless ref $self->{$field} eq 'CODE'; |
3699
|
35
|
|
|
|
|
356
|
return $self; |
3700
|
|
|
|
|
|
|
} |
3701
|
75
|
|
|
|
|
718
|
} |
3702
|
|
|
|
|
|
|
# SOAP::Transport Shortcuts |
3703
|
|
|
|
|
|
|
# TODO - deprecate proxy() in favor of new language endpoint_url() |
3704
|
25
|
|
|
25
|
|
196
|
no strict qw(refs); |
|
25
|
|
|
|
|
49
|
|
|
25
|
|
|
|
|
7004
|
|
3705
|
25
|
|
|
|
|
58
|
for my $method (qw(proxy)) { |
3706
|
|
|
|
|
|
|
*$method = sub { |
3707
|
37
|
|
|
37
|
|
297
|
my $self = shift->new; |
3708
|
37
|
100
|
|
|
|
223
|
@_ ? ($self->transport->$method(@_), return $self) : return $self->transport->$method(); |
3709
|
|
|
|
|
|
|
} |
3710
|
25
|
|
|
|
|
186
|
} |
3711
|
|
|
|
|
|
|
|
3712
|
|
|
|
|
|
|
# SOAP::Seriailizer Shortcuts |
3713
|
25
|
|
|
|
|
65
|
for my $method (qw(autotype readable envprefix encodingStyle |
3714
|
|
|
|
|
|
|
encprefix multirefinplace encoding |
3715
|
|
|
|
|
|
|
typelookup header maptype xmlschema |
3716
|
|
|
|
|
|
|
uri ns_prefix ns_uri use_prefix use_default_ns |
3717
|
|
|
|
|
|
|
ns default_ns)) { |
3718
|
|
|
|
|
|
|
*$method = sub { |
3719
|
14
|
|
|
14
|
|
145
|
my $self = shift->new; |
3720
|
14
|
100
|
|
|
|
94
|
@_ ? ($self->serializer->$method(@_), return $self) : return $self->serializer->$method(); |
3721
|
|
|
|
|
|
|
} |
3722
|
450
|
|
|
|
|
3048
|
} |
3723
|
|
|
|
|
|
|
|
3724
|
|
|
|
|
|
|
# SOAP::Schema Shortcuts |
3725
|
25
|
|
|
|
|
59
|
for my $method (qw(cache_dir cache_ttl)) { |
3726
|
|
|
|
|
|
|
*$method = sub { |
3727
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
3728
|
0
|
0
|
|
|
|
0
|
@_ ? ($self->schema->$method(@_), return $self) : return $self->schema->$method(); |
3729
|
|
|
|
|
|
|
} |
3730
|
50
|
|
|
|
|
7352
|
} |
3731
|
|
|
|
|
|
|
} |
3732
|
|
|
|
|
|
|
|
3733
|
|
|
|
|
|
|
sub parts { |
3734
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
3735
|
0
|
|
|
|
|
0
|
$self->packager->parts(@_); |
3736
|
0
|
|
|
|
|
0
|
return $self; |
3737
|
|
|
|
|
|
|
} |
3738
|
|
|
|
|
|
|
|
3739
|
|
|
|
|
|
|
# Naming? wsdl |
3740
|
|
|
|
|
|
|
sub service { |
3741
|
0
|
|
|
0
|
1
|
0
|
my $self = shift->new; |
3742
|
0
|
0
|
|
|
|
0
|
return $self->{'_service'} unless @_; |
3743
|
0
|
|
|
|
|
0
|
$self->schema->schema_url($self->{'_service'} = shift); |
3744
|
0
|
|
|
|
|
0
|
my %services = %{$self->schema->parse(@_)->load->services}; |
|
0
|
|
|
|
|
0
|
|
3745
|
|
|
|
|
|
|
|
3746
|
0
|
0
|
|
|
|
0
|
Carp::croak "More than one service in service description. Service and port names have to be specified\n" |
3747
|
|
|
|
|
|
|
if keys %services > 1; |
3748
|
0
|
|
|
|
|
0
|
my $service = (keys %services)[0]->new; |
3749
|
0
|
|
|
|
|
0
|
return $service; |
3750
|
|
|
|
|
|
|
} |
3751
|
|
|
|
|
|
|
|
3752
|
|
|
|
|
|
|
sub AUTOLOAD { |
3753
|
11
|
|
|
11
|
|
219
|
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); |
3754
|
11
|
50
|
|
|
|
64
|
return if $method eq 'DESTROY'; |
3755
|
|
|
|
|
|
|
|
3756
|
11
|
50
|
|
|
|
62
|
ref $_[0] or Carp::croak qq!Can\'t locate class method "$method" via package \"! . __PACKAGE__ .'\"'; |
3757
|
|
|
|
|
|
|
|
3758
|
25
|
|
|
25
|
|
151
|
no strict 'refs'; |
|
25
|
|
|
|
|
43
|
|
|
25
|
|
|
|
|
33040
|
|
3759
|
|
|
|
|
|
|
*$AUTOLOAD = sub { |
3760
|
11
|
|
|
11
|
|
36
|
my $self = shift; |
3761
|
11
|
|
|
|
|
87
|
my $som = $self->call($method => @_); |
3762
|
11
|
0
|
33
|
|
|
127
|
return $self->autoresult && UNIVERSAL::isa($som => 'SOAP::SOM') |
|
|
50
|
|
|
|
|
|
3763
|
|
|
|
|
|
|
? wantarray ? $som->paramsall : $som->result |
3764
|
|
|
|
|
|
|
: $som; |
3765
|
11
|
|
|
|
|
94
|
}; |
3766
|
11
|
|
|
|
|
46
|
goto &$AUTOLOAD; |
3767
|
|
|
|
|
|
|
} |
3768
|
|
|
|
|
|
|
|
3769
|
|
|
|
|
|
|
sub call { |
3770
|
12
|
|
|
12
|
1
|
76
|
SOAP::Trace::trace('()'); |
3771
|
12
|
|
|
|
|
26
|
my $self = shift; |
3772
|
|
|
|
|
|
|
|
3773
|
12
|
50
|
33
|
|
|
56
|
die "A service address has not been specified either by using SOAP::Lite->proxy() or a service description)\n" |
3774
|
|
|
|
|
|
|
unless defined $self->proxy && UNIVERSAL::isa($self->proxy => 'SOAP::Client'); |
3775
|
|
|
|
|
|
|
|
3776
|
12
|
|
|
|
|
74
|
$self->init_context(); |
3777
|
|
|
|
|
|
|
|
3778
|
12
|
|
|
|
|
63
|
my $serializer = $self->serializer; |
3779
|
12
|
|
|
|
|
74
|
$serializer->on_nonserialized($self->on_nonserialized); |
3780
|
|
|
|
|
|
|
|
3781
|
12
|
|
|
|
|
57
|
my $response = $self->transport->send_receive( |
3782
|
|
|
|
|
|
|
context => $self, # this is provided for context |
3783
|
|
|
|
|
|
|
endpoint => $self->endpoint, |
3784
|
|
|
|
|
|
|
action => scalar($self->on_action->($serializer->uriformethod($_[0]))), |
3785
|
|
|
|
|
|
|
# leave only parameters so we can later update them if required |
3786
|
|
|
|
|
|
|
envelope => $serializer->envelope(method => shift, @_), |
3787
|
|
|
|
|
|
|
encoding => $serializer->encoding, |
3788
|
12
|
50
|
|
|
|
58
|
parts => @{$self->packager->parts} ? $self->packager->parts : undef, |
3789
|
|
|
|
|
|
|
); |
3790
|
|
|
|
|
|
|
|
3791
|
12
|
50
|
|
|
|
647
|
return $response if $self->outputxml; |
3792
|
|
|
|
|
|
|
|
3793
|
12
|
50
|
|
|
|
73
|
my $result = eval { $self->deserializer->deserialize($response) } |
|
12
|
|
|
|
|
64
|
|
3794
|
|
|
|
|
|
|
if $response; |
3795
|
|
|
|
|
|
|
|
3796
|
12
|
50
|
66
|
|
|
124
|
if (!$self->transport->is_success || # transport fault |
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
3797
|
|
|
|
|
|
|
$@ || # not deserializible |
3798
|
|
|
|
|
|
|
# fault message even if transport OK |
3799
|
|
|
|
|
|
|
# or no transport error (for example, fo TCP, POP3, IO implementations) |
3800
|
|
|
|
|
|
|
UNIVERSAL::isa($result => 'SOAP::SOM') && $result->fault) { |
3801
|
12
|
|
33
|
|
|
240
|
return ($self->on_fault->($self, $@ |
3802
|
|
|
|
|
|
|
? $@ . ($response || '') |
3803
|
|
|
|
|
|
|
: $result) |
3804
|
|
|
|
|
|
|
|| $result |
3805
|
|
|
|
|
|
|
); |
3806
|
|
|
|
|
|
|
# ? # trick editors |
3807
|
|
|
|
|
|
|
} |
3808
|
|
|
|
|
|
|
# this might be trouble for connection close... |
3809
|
0
|
0
|
|
|
|
|
return unless $response; # nothing to do for one-ways |
3810
|
|
|
|
|
|
|
|
3811
|
|
|
|
|
|
|
# little bit tricky part that binds in/out parameters |
3812
|
0
|
0
|
0
|
|
|
|
if (UNIVERSAL::isa($result => 'SOAP::SOM') |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
3813
|
|
|
|
|
|
|
&& ($result->paramsout || $result->headers) |
3814
|
|
|
|
|
|
|
&& $serializer->signature) { |
3815
|
0
|
|
|
|
|
|
my $num = 0; |
3816
|
0
|
|
|
|
|
|
my %signatures = map {$_ => $num++} @{$serializer->signature}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
3817
|
0
|
|
|
|
|
|
for ($result->dataof(SOAP::SOM::paramsout), $result->dataof(SOAP::SOM::headers)) { |
3818
|
0
|
|
0
|
|
|
|
my $signature = join $;, $_->name, $_->type || ''; |
3819
|
0
|
0
|
|
|
|
|
if (exists $signatures{$signature}) { |
3820
|
0
|
|
|
|
|
|
my $param = $signatures{$signature}; |
3821
|
0
|
|
|
|
|
|
my($value) = $_->value; # take first value |
3822
|
|
|
|
|
|
|
|
3823
|
|
|
|
|
|
|
# fillup parameters |
3824
|
0
|
|
|
|
|
|
UNIVERSAL::isa($_[$param] => 'SOAP::Data') |
3825
|
|
|
|
|
|
|
? $_[$param]->SOAP::Data::value($value) |
3826
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[$param] => 'ARRAY') |
3827
|
0
|
|
|
|
|
|
? (@{$_[$param]} = @$value) |
3828
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[$param] => 'HASH') |
3829
|
0
|
|
|
|
|
|
? (%{$_[$param]} = %$value) |
3830
|
|
|
|
|
|
|
: UNIVERSAL::isa($_[$param] => 'SCALAR') |
3831
|
0
|
0
|
|
|
|
|
? (${$_[$param]} = $$value) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3832
|
|
|
|
|
|
|
: ($_[$param] = $value) |
3833
|
|
|
|
|
|
|
} |
3834
|
|
|
|
|
|
|
} |
3835
|
|
|
|
|
|
|
} |
3836
|
0
|
|
|
|
|
|
return $result; |
3837
|
|
|
|
|
|
|
} # end of call() |
3838
|
|
|
|
|
|
|
|
3839
|
|
|
|
|
|
|
# ====================================================================== |
3840
|
|
|
|
|
|
|
|
3841
|
|
|
|
|
|
|
package SOAP::Lite::COM; |
3842
|
|
|
|
|
|
|
|
3843
|
|
|
|
|
|
|
require SOAP::Lite; |
3844
|
|
|
|
|
|
|
|
3845
|
|
|
|
|
|
|
sub required { |
3846
|
0
|
|
|
0
|
|
|
foreach (qw( |
3847
|
|
|
|
|
|
|
URI::_foreign URI::http URI::https |
3848
|
|
|
|
|
|
|
LWP::Protocol::http LWP::Protocol::https LWP::Authen::Basic LWP::Authen::Digest |
3849
|
|
|
|
|
|
|
HTTP::Daemon Compress::Zlib SOAP::Transport::HTTP |
3850
|
|
|
|
|
|
|
XMLRPC::Lite XMLRPC::Transport::HTTP |
3851
|
|
|
|
|
|
|
)) { |
3852
|
0
|
|
|
|
|
|
eval join ';', 'local $SIG{__DIE__}', "require $_"; |
3853
|
|
|
|
|
|
|
} |
3854
|
|
|
|
|
|
|
} |
3855
|
|
|
|
|
|
|
|
3856
|
0
|
|
|
0
|
|
|
sub new { required; SOAP::Lite->new(@_) } |
|
0
|
|
|
|
|
|
|
3857
|
|
|
|
|
|
|
|
3858
|
|
|
|
|
|
|
sub create; *create = \&new; # make alias. Somewhere 'new' is registered keyword |
3859
|
|
|
|
|
|
|
|
3860
|
|
|
|
|
|
|
sub soap; *soap = \&new; # also alias. Just to be consistent with .xmlrpc call |
3861
|
|
|
|
|
|
|
|
3862
|
0
|
|
|
0
|
|
|
sub xmlrpc { required; XMLRPC::Lite->new(@_) } |
|
0
|
|
|
|
|
|
|
3863
|
|
|
|
|
|
|
|
3864
|
0
|
|
|
0
|
|
|
sub server { required; shift->new(@_) } |
|
0
|
|
|
|
|
|
|
3865
|
|
|
|
|
|
|
|
3866
|
0
|
|
|
0
|
|
|
sub data { SOAP::Data->new(@_) } |
3867
|
|
|
|
|
|
|
|
3868
|
0
|
|
|
0
|
|
|
sub header { SOAP::Header->new(@_) } |
3869
|
|
|
|
|
|
|
|
3870
|
0
|
|
|
0
|
|
|
sub hash { +{@_} } |
3871
|
|
|
|
|
|
|
|
3872
|
|
|
|
|
|
|
sub instanceof { |
3873
|
0
|
|
|
0
|
|
|
my $class = shift; |
3874
|
0
|
0
|
|
|
|
|
die "Incorrect class name" unless $class =~ /^(\w[\w:]*)$/; |
3875
|
0
|
|
|
|
|
|
eval "require $class"; |
3876
|
0
|
|
|
|
|
|
$class->new(@_); |
3877
|
|
|
|
|
|
|
} |
3878
|
|
|
|
|
|
|
|
3879
|
|
|
|
|
|
|
# ====================================================================== |
3880
|
|
|
|
|
|
|
|
3881
|
|
|
|
|
|
|
1; |
3882
|
|
|
|
|
|
|
|
3883
|
|
|
|
|
|
|
__END__ |