~ubuntu-branches/ubuntu/utopic/libsoap-lite-perl/utopic-proposed
» Revision
10
: .pc/perl5.18-test.patch/lib/SOAP/Lite.pm
« back to all changes in this revision
Viewing changes to .pc/perl5.18-test.patch/lib/SOAP/Lite.pm
- browse files at revision 10
- compare with another revision
- download diff
- download tarball
- view history from revision 10
- Committer: Package Import Robot
- Author(s): gregor herrmann, Salvatore Bonaccorso, Xavier Guimard, gregor herrmann
- Date: 2013-08-12 15:24:53 UTC
- mfrom: (1.1.5)
- Revision ID: package-import@ubuntu.com-20130812152453-29f8t3rok22pkakm
Tags: 0.716-1
[ Salvatore Bonaccorso ]
* Change Vcs-Git to canonical URI (git://anonscm.debian.org)
* Change search.cpan.org based URIs to metacpan.org based URIs
[ Xavier Guimard ]
* Imported Upstream version 0.716
* Add myself to uploaders and copyright
* Bump Standards-Version to 3.9.3
* Update copyright (format 1.0 and years)
* Report spelling patch on CPAN (#78639)
* Remove spelling patch now included in upstream
* Add patch to correct test plan
* Modify patch hashref_crash.patch: it was rejected by upstream. The new
patch may really close the bug (Closes: #602056)
[ gregor herrmann ]
* Add patch to fix hash randomization caused test failure in perl 5.18.
(Closes: #710992)
* Declare compliance with Debian Policy 3.9.4.
* Update years of packaging copyright.
* Change Vcs-Git to canonical URI (git://anonscm.debian.org)
* Change search.cpan.org based URIs to metacpan.org based URIs
[ Xavier Guimard ]
* Imported Upstream version 0.716
* Add myself to uploaders and copyright
* Bump Standards-Version to 3.9.3
* Update copyright (format 1.0 and years)
* Report spelling patch on CPAN (#78639)
* Remove spelling patch now included in upstream
* Add patch to correct test plan
* Modify patch hashref_crash.patch: it was rejected by upstream. The new
patch may really close the bug (Closes: #602056)
[ gregor herrmann ]
* Add patch to fix hash randomization caused test failure in perl 5.18.
(Closes: #710992)
* Declare compliance with Debian Policy 3.9.4.
* Update years of packaging copyright.
- files added:
- .pc/.quilt_patches
- .pc/perl5.18-test.patch
- .pc/perl5.18-test.patch/lib
- .pc/perl5.18-test.patch/lib/SOAP
- .pc/perl5.18-test.patch/t
- .pc/update-test-plan.patch
- .pc/update-test-plan.patch/t
- files removed:
- .pc/spelling.patch
- .pc/spelling.patch/lib
- .pc/spelling.patch/lib/SOAP
- .pc/spelling.patch/lib/XML
- .pc/spelling.patch/lib/XML/Parser
- lib/IO
- t/IO
- files modified:
- .pc/applied-patches
added
removed
.pc/perl5.18-test.patch/lib/SOAP/Lite.pm
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
# $Id$
8
#
9
# ======================================================================
10
11
# Formatting hint:
12
# Target is the source code format laid out in Perl Best Practices (4 spaces
13
# indent, opening brace on condition line, no cuddled else).
14
#
15
# October 2007, Martin Kutter
16
17
package SOAP::Lite;
18
19
use 5.006; #weak references require perl 5.6
20
use strict;
21
our $VERSION = 0.716;
22
# ======================================================================
23
24
package SOAP::XMLSchemaApacheSOAP::Deserializer;
25
26
sub as_map {
27
my $self = shift;
28
return {
29
map {
30
my $hash = ($self->decode_object($_))[1];
31
($hash->{key} => $hash->{value})
32
} @{$_[3] || []}
33
};
34
}
35
sub as_Map; *as_Map = \&as_map;
36
37
# Thank to Kenneth Draper for this contribution
38
sub as_vector {
39
my $self = shift;
40
return [ map { scalar(($self->decode_object($_))[1]) } @{$_[3] || []} ];
41
}
42
sub as_Vector; *as_Vector = \&as_vector;
43
44
# ----------------------------------------------------------------------
45
46
package SOAP::XMLSchema::Serializer;
47
48
use vars qw(@ISA);
49
50
sub xmlschemaclass {
51
my $self = shift;
52
return $ISA[0] unless @_;
53
@ISA = (shift);
54
return $self;
55
}
56
57
# ----------------------------------------------------------------------
58
59
package SOAP::XMLSchema1999::Serializer;
60
61
use vars qw(@EXPORT $AUTOLOAD);
62
63
sub AUTOLOAD {
64
local($1,$2);
65
my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
66
return if $method eq 'DESTROY';
67
no strict 'refs';
68
69
my $export_var = $package . '::EXPORT';
70
my @export = @$export_var;
71
72
# Removed in 0.69 - this is a total hack. For some reason this is failing
73
# despite not being a fatal error condition.
74
# die "Type '$method' can't be found in a schema class '$package'\n"
75
# unless $method =~ s/^as_// && grep {$_ eq $method} @{$export_var};
76
77
# This was added in its place - it is still a hack, but it performs the
78
# necessary substitution. It just does not die.
79
if ($method =~ s/^as_// && grep {$_ eq $method} @{$export_var}) {
80
# print STDERR "method is now '$method'\n";
81
} else {
82
return;
83
}
84
85
$method =~ s/_/-/; # fix ur-type
86
87
*$AUTOLOAD = sub {
88
my $self = shift;
89
my($value, $name, $type, $attr) = @_;
90
return [$name, {'xsi:type' => "xsd:$method", %$attr}, $value];
91
};
92
goto &$AUTOLOAD;
93
}
94
95
BEGIN {
96
@EXPORT = qw(ur_type
97
float double decimal timeDuration recurringDuration uriReference
98
integer nonPositiveInteger negativeInteger long int short byte
99
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
100
positiveInteger timeInstant time timePeriod date month year century
101
recurringDate recurringDay language
102
base64 hex string boolean
103
);
104
# TODO: replace by symbol table operations...
105
# predeclare subs, so ->can check will be positive
106
foreach (@EXPORT) { eval "sub as_$_" }
107
}
108
109
sub nilValue { 'null' }
110
111
sub anyTypeValue { 'ur-type' }
112
113
sub as_base64 {
114
my ($self, $value, $name, $type, $attr) = @_;
115
116
# Fixes #30271 for 5.8 and above.
117
# Won't fix for 5.6 and below - perl can't handle unicode before
118
# 5.8, and applying pack() to everything is just a slowdown.
119
if (eval "require Encode; 1") {
120
if (Encode::is_utf8($value)) {
121
if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions.
122
Encode::_utf8_off($value);
123
}
124
else {
125
$value = pack('C*',unpack('C*',$value)); # the slow but safe way,
126
# but this fallback works always.
127
}
128
}
129
}
130
131
require MIME::Base64;
132
return [
133
$name,
134
{
135
'xsi:type' => SOAP::Utils::qualify($self->encprefix => 'base64'),
136
%$attr
137
},
138
MIME::Base64::encode_base64($value,'')
139
];
140
}
141
142
sub as_hex {
143
my ($self, $value, $name, $type, $attr) = @_;
144
return [
145
$name,
146
{
147
'xsi:type' => 'xsd:hex', %$attr
148
},
149
join '', map {
150
uc sprintf "%02x", ord
151
} split '', $value
152
];
153
}
154
155
sub as_long {
156
my($self, $value, $name, $type, $attr) = @_;
157
return [
158
$name,
159
{'xsi:type' => 'xsd:long', %$attr},
160
$value
161
];
162
}
163
164
sub as_dateTime {
165
my ($self, $value, $name, $type, $attr) = @_;
166
return [$name, {'xsi:type' => 'xsd:dateTime', %$attr}, $value];
167
}
168
169
sub as_string {
170
my ($self, $value, $name, $type, $attr) = @_;
171
die "String value expected instead of @{[ref $value]} reference\n"
172
if ref $value;
173
return [
174
$name,
175
{'xsi:type' => 'xsd:string', %$attr},
176
SOAP::Utils::encode_data($value)
177
];
178
}
179
180
sub as_anyURI {
181
my($self, $value, $name, $type, $attr) = @_;
182
die "String value expected instead of @{[ref $value]} reference\n" if ref $value;
183
return [
184
$name,
185
{'xsi:type' => 'xsd:anyURI', %$attr},
186
SOAP::Utils::encode_data($value)
187
];
188
}
189
190
sub as_undef { $_[1] ? '1' : '0' }
191
192
sub as_boolean {
193
my $self = shift;
194
my($value, $name, $type, $attr) = @_;
195
# fix [ 1204279 ] Boolean serialization error
196
return [
197
$name,
198
{'xsi:type' => 'xsd:boolean', %$attr},
199
( $value && $value ne 'false' ) ? 'true' : 'false'
200
];
201
}
202
203
sub as_float {
204
my($self, $value, $name, $type, $attr) = @_;
205
return [
206
$name,
207
{'xsi:type' => 'xsd:float', %$attr},
208
$value
209
];
210
}
211
212
# ----------------------------------------------------------------------
213
214
package SOAP::XMLSchema2001::Serializer;
215
216
use vars qw(@EXPORT);
217
218
# no more warnings about "used only once"
219
*AUTOLOAD if 0;
220
221
*AUTOLOAD = \&SOAP::XMLSchema1999::Serializer::AUTOLOAD;
222
223
BEGIN {
224
@EXPORT = qw(anyType anySimpleType float double decimal dateTime
225
timePeriod gMonth gYearMonth gYear century
226
gMonthDay gDay duration recurringDuration anyURI
227
language integer nonPositiveInteger negativeInteger
228
long int short byte nonNegativeInteger unsignedLong
229
unsignedInt unsignedShort unsignedByte positiveInteger
230
date time string hex base64 boolean
231
QName
232
);
233
# Add QName to @EXPORT
234
# predeclare subs, so ->can check will be positive
235
foreach (@EXPORT) { eval "sub as_$_" }
236
}
237
238
sub nilValue { 'nil' }
239
240
sub anyTypeValue { 'anyType' }
241
242
sub as_long; *as_long = \&SOAP::XMLSchema1999::Serializer::as_long;
243
sub as_float; *as_float = \&SOAP::XMLSchema1999::Serializer::as_float;
244
sub as_string; *as_string = \&SOAP::XMLSchema1999::Serializer::as_string;
245
sub as_anyURI; *as_anyURI = \&SOAP::XMLSchema1999::Serializer::as_anyURI;
246
247
# TODO - QNames still don't work for 2001 schema!
248
sub as_QName; *as_QName = \&SOAP::XMLSchema1999::Serializer::as_string;
249
sub as_hex; *as_hex = \&as_hexBinary;
250
sub as_base64; *as_base64 = \&as_base64Binary;
251
sub as_timeInstant; *as_timeInstant = \&as_dateTime;
252
253
# only 0 and 1 allowed - that's easy...
254
sub as_undef {
255
$_[1]
256
? 'true'
257
: 'false'
258
}
259
260
sub as_hexBinary {
261
my ($self, $value, $name, $type, $attr) = @_;
262
return [
263
$name,
264
{'xsi:type' => 'xsd:hexBinary', %$attr},
265
join '', map {
266
uc sprintf "%02x", ord
267
} split '', $value
268
];
269
}
270
271
sub as_base64Binary {
272
my ($self, $value, $name, $type, $attr) = @_;
273
274
# Fixes #30271 for 5.8 and above.
275
# Won't fix for 5.6 and below - perl can't handle unicode before
276
# 5.8, and applying pack() to everything is just a slowdown.
277
if (eval "require Encode; 1") {
278
if (Encode::is_utf8($value)) {
279
if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions.
280
Encode::_utf8_off($value);
281
}
282
else {
283
$value = pack('C*',unpack('C*',$value)); # the slow but safe way,
284
# but this fallback works always.
285
}
286
}
287
}
288
289
require MIME::Base64;
290
return [
291
$name,
292
{
293
'xsi:type' => 'xsd:base64Binary', %$attr
294
},
295
MIME::Base64::encode_base64($value,'')
296
];
297
}
298
299
sub as_boolean {
300
my ($self, $value, $name, $type, $attr) = @_;
301
# fix [ 1204279 ] Boolean serialization error
302
return [
303
$name,
304
{
305
'xsi:type' => 'xsd:boolean', %$attr
306
},
307
( $value && ($value ne 'false') )
308
? 'true'
309
: 'false'
310
];
311
}
312
313
314
# ======================================================================
315
316
package SOAP::Utils;
317
318
sub qualify {
319
$_[1]
320
? $_[1] =~ /:/
321
? $_[1]
322
: join(':', $_[0] || (), $_[1])
323
: defined $_[1]
324
? $_[0]
325
: ''
326
}
327
328
sub overqualify (&$) {
329
for ($_[1]) {
330
&{$_[0]};
331
s/^:|:$//g
332
}
333
}
334
335
sub disqualify {
336
(my $qname = shift) =~ s/^($SOAP::Constants::NSMASK?)://;
337
return $qname;
338
}
339
340
sub splitqname {
341
local($1,$2);
342
$_[0] =~ /^(?:([^:]+):)?(.+)$/;
343
return ($1,$2)
344
}
345
346
sub longname {
347
defined $_[0]
348
? sprintf('{%s}%s', $_[0], $_[1])
349
: $_[1]
350
}
351
352
sub splitlongname {
353
local($1,$2);
354
$_[0] =~ /^(?:\{(.*)\})?(.+)$/;
355
return ($1,$2)
356
}
357
358
# Q: why only '&' and '<' are encoded, but not '>'?
359
# A: because it is not required according to XML spec.
360
#
361
# [http://www.w3.org/TR/REC-xml#syntax]
362
# The ampersand character (&) and the left angle bracket (<) may appear in
363
# their literal form only when used as markup delimiters, or within a comment,
364
# a processing instruction, or a CDATA section. If they are needed elsewhere,
365
# they must be escaped using either numeric character references or the
366
# strings "&" and "<" respectively. The right angle bracket (>) may be
367
# represented using the string ">", and must, for compatibility, be
368
# escaped using ">" or a character reference when it appears in the
369
# string "]]>" in content, when that string is not marking the end of a
370
# CDATA section.
371
372
my %encode_attribute = ('&' => '&', '>' => '>', '<' => '<', '"' => '"');
373
sub encode_attribute { (my $e = $_[0]) =~ s/([&<>\"])/$encode_attribute{$1}/g; $e }
374
375
my %encode_data = ('&' => '&', '>' => '>', '<' => '<', "\xd" => '
');
376
sub encode_data {
377
my $e = $_[0];
378
if ($e) {
379
$e =~ s/([&<>\015])/$encode_data{$1}/g;
380
$e =~ s/\]\]>/\]\]>/g;
381
}
382
$e
383
}
384
385
# methods for internal tree (SOAP::Deserializer, SOAP::SOM and SOAP::Serializer)
386
387
sub o_qname { $_[0]->[0] }
388
sub o_attr { $_[0]->[1] }
389
sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef }
390
sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] }
391
# $_[0]->[3] is not used. Serializer stores object ID there
392
sub o_value { $_[0]->[4] }
393
sub o_lname { $_[0]->[5] }
394
sub o_lattr { $_[0]->[6] }
395
396
sub format_datetime {
397
my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5];
398
my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s);
399
return $time;
400
}
401
402
# make bytelength that calculates length in bytes regardless of utf/byte settings
403
# either we can do 'use bytes' or length will count bytes already
404
BEGIN {
405
sub bytelength;
406
*bytelength = eval('use bytes; 1') # 5.6.0 and later?
407
? sub { use bytes; length(@_ ? $_[0] : $_) }
408
: sub { length(@_ ? $_[0] : $_) };
409
}
410
411
# ======================================================================
412
413
package SOAP::Cloneable;
414
415
sub clone {
416
my $self = shift;
417
418
return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__);
419
420
my $clone = bless {} => ref($self) || $self;
421
for (keys %$self) {
422
my $value = $self->{$_};
423
$clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value;
424
}
425
return $clone;
426
}
427
428
# ======================================================================
429
430
package SOAP::Transport;
431
432
use vars qw($AUTOLOAD @ISA);
433
@ISA = qw(SOAP::Cloneable);
434
435
use Class::Inspector;
436
437
438
sub DESTROY { SOAP::Trace::objects('()') }
439
440
sub new {
441
my $self = shift;
442
return $self if ref $self;
443
my $class = ref($self) || $self;
444
445
SOAP::Trace::objects('()');
446
return bless {} => $class;
447
}
448
449
sub proxy {
450
my $self = shift;
451
$self = $self->new() if not ref $self;
452
453
my $class = ref $self;
454
455
return $self->{_proxy} unless @_;
456
457
$_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
458
my $protocol = uc "$1"; # untainted now
459
460
# HTTPS is handled by HTTP class
461
$protocol =~s/^HTTPS$/HTTP/;
462
463
(my $protocol_class = "${class}::$protocol") =~ s/-/_/g;
464
465
no strict 'refs';
466
unless (Class::Inspector->loaded("$protocol_class\::Client")
467
&& UNIVERSAL::can("$protocol_class\::Client" => 'new')
468
) {
469
eval "require $protocol_class";
470
die "Unsupported protocol '$protocol'\n"
471
if $@ =~ m!^Can\'t locate SOAP/Transport/!;
472
die if $@;
473
}
474
475
$protocol_class .= "::Client";
476
return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_);
477
}
478
479
sub AUTOLOAD {
480
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
481
return if $method eq 'DESTROY';
482
483
no strict 'refs';
484
*$AUTOLOAD = sub { shift->proxy->$method(@_) };
485
goto &$AUTOLOAD;
486
}
487
488
# ======================================================================
489
490
package SOAP::Fault;
491
492
use Carp ();
493
494
use overload fallback => 1, '""' => "stringify";
495
496
sub DESTROY { SOAP::Trace::objects('()') }
497
498
sub new {
499
my $self = shift;
500
501
unless (ref $self) {
502
my $class = $self;
503
$self = bless {} => $class;
504
SOAP::Trace::objects('()');
505
}
506
507
Carp::carp "Odd (wrong?) number of parameters in new()"
508
if $^W && (@_ & 1);
509
510
no strict qw(refs);
511
while (@_) {
512
my $method = shift;
513
$self->$method(shift)
514
if $self->can($method)
515
}
516
517
return $self;
518
}
519
520
sub stringify {
521
my $self = shift;
522
return join ': ', $self->faultcode, $self->faultstring;
523
}
524
525
sub BEGIN {
526
no strict 'refs';
527
for my $method (qw(faultcode faultstring faultactor faultdetail)) {
528
my $field = '_' . $method;
529
*$method = sub {
530
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
531
? shift->new
532
: __PACKAGE__->new;
533
if (@_) {
534
$self->{$field} = shift;
535
return $self
536
}
537
return $self->{$field};
538
}
539
}
540
*detail = \&faultdetail;
541
}
542
543
# ======================================================================
544
545
package SOAP::Data;
546
547
use vars qw(@ISA @EXPORT_OK);
548
use Exporter;
549
use Carp ();
550
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
551
552
@ISA = qw(Exporter);
553
@EXPORT_OK = qw(name type attr value uri);
554
555
sub DESTROY { SOAP::Trace::objects('()') }
556
557
sub new {
558
my $self = shift;
559
560
unless (ref $self) {
561
my $class = $self;
562
$self = bless {_attr => {}, _value => [], _signature => []} => $class;
563
SOAP::Trace::objects('()');
564
}
565
no strict qw(refs);
566
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
567
while (@_) {
568
my $method = shift;
569
$self->$method(shift) if $self->can($method)
570
}
571
572
return $self;
573
}
574
575
sub name {
576
my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
577
if (@_) {
578
my $name = shift;
579
my ($uri, $prefix); # predeclare, because can't declare in assign
580
if ($name) {
581
($uri, $name) = SOAP::Utils::splitlongname($name);
582
unless (defined $uri) {
583
($prefix, $name) = SOAP::Utils::splitqname($name);
584
$self->prefix($prefix) if defined $prefix;
585
} else {
586
$self->uri($uri);
587
}
588
}
589
$self->{_name} = $name;
590
591
$self->value(@_) if @_;
592
return $self;
593
}
594
return $self->{_name};
595
}
596
597
sub attr {
598
my $self = ref $_[0]
599
? shift
600
: UNIVERSAL::isa($_[0] => __PACKAGE__)
601
? shift->new()
602
: __PACKAGE__->new();
603
if (@_) {
604
$self->{_attr} = shift;
605
return $self->value(@_) if @_;
606
return $self
607
}
608
return $self->{_attr};
609
}
610
611
sub type {
612
my $self = ref $_[0]
613
? shift
614
: UNIVERSAL::isa($_[0] => __PACKAGE__)
615
? shift->new()
616
: __PACKAGE__->new();
617
if (@_) {
618
$self->{_type} = shift;
619
$self->value(@_) if @_;
620
return $self;
621
}
622
if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) {
623
$self->{_type} = (SOAP::Utils::splitlongname(delete $self->{_attr}->{shift(@types)}))[1];
624
}
625
return $self->{_type};
626
}
627
628
BEGIN {
629
no strict 'refs';
630
for my $method (qw(root mustUnderstand)) {
631
my $field = '_' . $method;
632
*$method = sub {
633
my $attr = $method eq 'root'
634
? "{$SOAP::Constants::NS_ENC}$method"
635
: "{$SOAP::Constants::NS_ENV}$method";
636
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
637
? shift->new
638
: __PACKAGE__->new;
639
if (@_) {
640
$self->{_attr}->{$attr} = $self->{$field} = shift() ? 1 : 0;
641
$self->value(@_) if @_;
642
return $self;
643
}
644
$self->{$field} = SOAP::Lite::Deserializer::XMLSchemaSOAP1_2->as_boolean($self->{_attr}->{$attr})
645
if !defined $self->{$field} && defined $self->{_attr}->{$attr};
646
return $self->{$field};
647
}
648
}
649
650
for my $method (qw(actor encodingStyle)) {
651
my $field = '_' . $method;
652
*$method = sub {
653
my $attr = "{$SOAP::Constants::NS_ENV}$method";
654
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
655
? shift->new()
656
: __PACKAGE__->new();
657
if (@_) {
658
$self->{_attr}->{$attr} = $self->{$field} = shift;
659
$self->value(@_) if @_;
660
return $self;
661
}
662
$self->{$field} = $self->{_attr}->{$attr}
663
if !defined $self->{$field} && defined $self->{_attr}->{$attr};
664
return $self->{$field};
665
}
666
}
667
}
668
669
sub prefix {
670
my $self = ref $_[0]
671
? shift
672
: UNIVERSAL::isa($_[0] => __PACKAGE__)
673
? shift->new()
674
: __PACKAGE__->new();
675
return $self->{_prefix} unless @_;
676
$self->{_prefix} = shift;
677
if (scalar @_) {
678
return $self->value(@_);
679
}
680
return $self;
681
}
682
683
sub uri {
684
my $self = ref $_[0]
685
? shift
686
: UNIVERSAL::isa($_[0] => __PACKAGE__)
687
? shift->new()
688
: __PACKAGE__->new();
689
return $self->{_uri} unless @_;
690
my $uri = $self->{_uri} = shift;
691
warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n"
692
if defined $uri && $^W && $uri =~ /::/;
693
if (scalar @_) {
694
return $self->value(@_);
695
}
696
return $self;
697
}
698
699
sub set_value {
700
my $self = ref $_[0]
701
? shift
702
: UNIVERSAL::isa($_[0] => __PACKAGE__)
703
? shift->new()
704
: __PACKAGE__->new();
705
$self->{_value} = [@_];
706
return $self;
707
}
708
709
sub value {
710
my $self = ref $_[0] ? shift
711
: UNIVERSAL::isa($_[0] => __PACKAGE__)
712
? shift->new()
713
: __PACKAGE__->new;
714
if (@_) {
715
return $self->set_value(@_);
716
}
717
else {
718
return wantarray
719
? @{$self->{_value}}
720
: $self->{_value}->[0];
721
}
722
}
723
724
sub signature {
725
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
726
? shift->new()
727
: __PACKAGE__->new();
728
(@_)
729
? ($self->{_signature} = shift, return $self)
730
: (return $self->{_signature});
731
}
732
733
# ======================================================================
734
735
package SOAP::Header;
736
737
use vars qw(@ISA);
738
@ISA = qw(SOAP::Data);
739
740
# ======================================================================
741
742
package SOAP::Serializer;
743
use SOAP::Lite::Utils;
744
use Carp ();
745
use vars qw(@ISA);
746
747
@ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer);
748
749
BEGIN {
750
# namespaces and anonymous data structures
751
my $ns = 0;
752
my $name = 0;
753
my $prefix = 'c-';
754
sub gen_ns { 'namesp' . ++$ns }
755
sub gen_name { join '', $prefix, 'gensym', ++$name }
756
sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; }
757
}
758
759
sub BEGIN {
760
no strict 'refs';
761
762
__PACKAGE__->__mk_accessors(qw(readable level seen autotype attr maptype
763
namespaces multirefinplace encoding signature on_nonserialized context
764
ns_uri ns_prefix use_default_ns));
765
766
for my $method (qw(method fault freeform)) { # aliases for envelope
767
*$method = sub { shift->envelope($method => @_) }
768
}
769
770
# Is this necessary? Seems like work for nothing when a user could just use
771
# SOAP::Utils directly.
772
# for my $method (qw(qualify overqualify disqualify)) { # import from SOAP::Utils
773
# *$method = \&{'SOAP::Utils::'.$method};
774
# }
775
}
776
777
sub DESTROY { SOAP::Trace::objects('()') }
778
779
sub new {
780
my $self = shift;
781
return $self if ref $self;
782
783
my $class = $self;
784
$self = bless {
785
_level => 0,
786
_autotype => 1,
787
_readable => 0,
788
_ns_uri => '',
789
_ns_prefix => '',
790
_use_default_ns => 1,
791
_multirefinplace => 0,
792
_seen => {},
793
_encoding => 'UTF-8',
794
_objectstack => {},
795
_signature => [],
796
_maptype => {},
797
_on_nonserialized => sub {Carp::carp "Cannot marshall @{[ref shift]} reference" if $^W; return},
798
_encodingStyle => $SOAP::Constants::NS_ENC,
799
_attr => {
800
"{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
801
},
802
_namespaces => {},
803
_soapversion => SOAP::Lite->soapversion,
804
} => $class;
805
$self->typelookup({
806
'base64Binary' =>
807
[10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/ }, 'as_base64Binary'],
808
'zerostring' =>
809
[12, sub { $_[0] =~ /^0\d+$/ }, 'as_string'],
810
# int (and actually long too) are subtle: the negative range is one greater...
811
'int' =>
812
[20, sub {$_[0] =~ /^([+-]?\d+)$/ && ($1 <= 2147483647) && ($1 >= -2147483648); }, 'as_int'],
813
'long' =>
814
[25, sub {$_[0] =~ /^([+-]?\d+)$/ && $1 <= 9223372036854775807;}, 'as_long'],
815
'float' =>
816
[30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+|NaN|INF)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_float'],
817
'gMonth' =>
818
[35, sub { $_[0] =~ /^--\d\d--(-\d\d:\d\d)?$/; }, 'as_gMonth'],
819
'gDay' =>
820
[40, sub { $_[0] =~ /^---\d\d(-\d\d:\d\d)?$/; }, 'as_gDay'],
821
'gYear' =>
822
[45, sub { $_[0] =~ /^-?\d\d\d\d(-\d\d:\d\d)?$/; }, 'as_gYear'],
823
'gMonthDay' =>
824
[50, sub { $_[0] =~ /^-\d\d-\d\d(-\d\d:\d\d)?$/; }, 'as_gMonthDay'],
825
'gYearMonth' =>
826
[55, sub { $_[0] =~ /^-?\d\d\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_gYearMonth'],
827
'date' =>
828
[60, sub { $_[0] =~ /^-?\d\d\d\d-\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_date'],
829
'time' =>
830
[70, sub { $_[0] =~ /^\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_time'],
831
'dateTime' =>
832
[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'],
833
'duration' =>
834
[80, sub { $_[0] !~m{^-?PT?$} && $_[0] =~ m{^
835
-? # a optional - sign
836
P
837
(:? \d+Y )?
838
(:? \d+M )?
839
(:? \d+D )?
840
(:?
841
T(:?\d+H)?
842
(:?\d+M)?
843
(:?\d+S)?
844
)?
845
$
846
}x;
847
}, 'as_duration'],
848
'boolean' =>
849
[90, sub { $_[0] =~ /^(true|false)$/i; }, 'as_boolean'],
850
'anyURI' =>
851
[95, sub { $_[0] =~ /^(urn:|http:\/\/)/i; }, 'as_anyURI'],
852
'string' =>
853
[100, sub {1}, 'as_string'],
854
});
855
$self->register_ns($SOAP::Constants::NS_ENC,$SOAP::Constants::PREFIX_ENC);
856
$self->register_ns($SOAP::Constants::NS_ENV,$SOAP::Constants::PREFIX_ENV)
857
if $SOAP::Constants::PREFIX_ENV;
858
$self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);
859
SOAP::Trace::objects('()');
860
861
no strict qw(refs);
862
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
863
while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }
864
865
return $self;
866
}
867
868
sub typelookup {
869
my ($self, $lookup) = @_;
870
if (defined $lookup) {
871
$self->{ _typelookup } = $lookup;
872
$self->{ _typelookup_order } = [ sort { $lookup->{$a}->[0] <=> $lookup->{$b}->[0] } keys %{ $lookup } ];
873
return $self;
874
}
875
return $self->{ _typelookup };
876
}
877
878
sub ns {
879
my $self = shift;
880
$self = $self->new() if not ref $self;
881
if (@_) {
882
my ($u,$p) = @_;
883
my $prefix;
884
885
if ($p) {
886
$prefix = $p;
887
}
888
elsif (!$p && !($prefix = $self->find_prefix($u))) {
889
$prefix = gen_ns;
890
}
891
892
$self->{'_ns_uri'} = $u;
893
$self->{'_ns_prefix'} = $prefix;
894
$self->{'_use_default_ns'} = 0;
895
# $self->register_ns($u,$prefix);
896
$self->{'_namespaces'}->{$u} = $prefix;
897
return $self;
898
}
899
return $self->{'_ns_uri'};
900
}
901
902
sub default_ns {
903
my $self = shift;
904
$self = $self->new() if not ref $self;
905
if (@_) {
906
my ($u) = @_;
907
$self->{'_ns_uri'} = $u;
908
$self->{'_ns_prefix'} = '';
909
$self->{'_use_default_ns'} = 1;
910
return $self;
911
}
912
return $self->{'_ns_uri'};
913
}
914
915
sub use_prefix {
916
my $self = shift;
917
$self = $self->new() if not ref $self;
918
warn 'use_prefix has been deprecated. if you wish to turn off or on the '
919
. 'use of a default namespace, then please use either ns(uri) or default_ns(uri)';
920
if (@_) {
921
my $use = shift;
922
$self->{'_use_default_ns'} = !$use || 0;
923
return $self;
924
} else {
925
return $self->{'_use_default_ns'};
926
}
927
}
928
sub uri {
929
my $self = shift;
930
$self = $self->new() if not ref $self;
931
# 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)';
932
if (@_) {
933
my $ns = shift;
934
if ($self->{_use_default_ns}) {
935
$self->default_ns($ns);
936
}
937
else {
938
$self->ns($ns);
939
}
940
# $self->{'_ns_uri'} = $ns;
941
# $self->register_ns($self->{'_ns_uri'}) if (!$self->{_use_default_ns});
942
return $self;
943
}
944
return $self->{'_ns_uri'};
945
}
946
947
sub encodingStyle {
948
my $self = shift;
949
$self = $self->new() if not ref $self;
950
return $self->{'_encodingStyle'} unless @_;
951
952
my $cur_style = $self->{'_encodingStyle'};
953
delete($self->{'_namespaces'}->{$cur_style});
954
955
my $new_style = shift;
956
if ($new_style eq "") {
957
delete($self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"});
958
}
959
else {
960
$self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"} = $new_style;
961
$self->{'_namespaces'}->{$new_style} = $SOAP::Constants::PREFIX_ENC;
962
}
963
}
964
965
# TODO - changing SOAP version can affect previously set encodingStyle
966
sub soapversion {
967
my $self = shift;
968
return $self->{_soapversion} unless @_;
969
return $self if $self->{_soapversion} eq SOAP::Lite->soapversion;
970
$self->{_soapversion} = shift;
971
972
$self->attr({
973
"{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
974
});
975
$self->namespaces({
976
$SOAP::Constants::NS_ENC => $SOAP::Constants::PREFIX_ENC,
977
$SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (),
978
});
979
$self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);
980
981
return $self;
982
}
983
984
sub xmlschema {
985
my $self = shift->new;
986
return $self->{_xmlschema} unless @_;
987
988
my @schema;
989
if ($_[0]) {
990
@schema = grep {/XMLSchema/ && /$_[0]/} keys %SOAP::Constants::XML_SCHEMAS;
991
Carp::croak "More than one schema match parameter '$_[0]': @{[join ', ', @schema]}" if @schema > 1;
992
Carp::croak "No schema match parameter '$_[0]'" if @schema != 1;
993
}
994
995
# do nothing if current schema is the same as new
996
# return $self if $self->{_xmlschema} && $self->{_xmlschema} eq $schema[0];
997
998
my $ns = $self->namespaces;
999
# delete current schema from namespaces
1000
if (my $schema = $self->{_xmlschema}) {
1001
delete $ns->{$schema};
1002
delete $ns->{"$schema-instance"};
1003
}
1004
1005
# add new schema into namespaces
1006
if (my $schema = $self->{_xmlschema} = shift @schema) {
1007
$ns->{$schema} = 'xsd';
1008
$ns->{"$schema-instance"} = 'xsi';
1009
}
1010
1011
# and here is the class serializer should work with
1012
my $class = exists $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}}
1013
? $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} . '::Serializer'
1014
: $self;
1015
1016
$self->xmlschemaclass($class);
1017
1018
return $self;
1019
}
1020
1021
sub envprefix {
1022
my $self = shift->new();
1023
return $self->namespaces->{$SOAP::Constants::NS_ENV} unless @_;
1024
$self->namespaces->{$SOAP::Constants::NS_ENV} = shift;
1025
return $self;
1026
}
1027
1028
sub encprefix {
1029
my $self = shift->new();
1030
return $self->namespaces->{$SOAP::Constants::NS_ENC} unless @_;
1031
$self->namespaces->{$SOAP::Constants::NS_ENC} = shift;
1032
return $self;
1033
}
1034
1035
sub gen_id { sprintf "%U", $_[1] }
1036
1037
sub multiref_object {
1038
my ($self, $object) = @_;
1039
my $id = $self->gen_id($object);
1040
if (! exists $self->{ _seen }->{ $id }) {
1041
$self->{ _seen }->{ $id } = {
1042
count => 1,
1043
multiref => 0,
1044
value => $object,
1045
recursive => 0
1046
};
1047
}
1048
else {
1049
my $id_seen = $self->{ _seen }->{ $id };
1050
$id_seen->{count}++;
1051
$id_seen->{multiref} = 1;
1052
$id_seen->{value} = $object;
1053
$id_seen->{recursive} ||= 0;
1054
}
1055
return $id;
1056
}
1057
1058
sub recursive_object {
1059
my $self = shift;
1060
$self->seen->{$self->gen_id(shift)}->{recursive} = 1;
1061
}
1062
1063
sub is_href {
1064
my $self = shift;
1065
my $seen = $self->seen->{shift || return} or return;
1066
return 1 if $seen->{id};
1067
return $seen->{multiref}
1068
&& !($seen->{id} = (shift
1069
|| $seen->{recursive}
1070
|| $seen->{multiref} && $self->multirefinplace));
1071
}
1072
1073
sub multiref_anchor {
1074
my ($self, $id) = @_;
1075
no warnings qw(uninitialized);
1076
if ($self->{ _seen }->{ $id }->{multiref}) {
1077
return "ref-$id"
1078
}
1079
else {
1080
return undef;
1081
}
1082
}
1083
1084
sub encode_multirefs {
1085
my $self = shift;
1086
return if $self->multirefinplace();
1087
1088
my $seen = $self->{ _seen };
1089
map { $_->[1]->{_id} = 1; $_ }
1090
map { $self->encode_object($seen->{$_}->{value}) }
1091
grep { $seen->{$_}->{multiref} && !$seen->{$_}->{recursive} }
1092
keys %$seen;
1093
}
1094
1095
sub maptypetouri {
1096
my($self, $type, $simple) = @_;
1097
1098
return $type unless defined $type;
1099
my($prefix, $name) = SOAP::Utils::splitqname($type);
1100
1101
unless (defined $prefix) {
1102
$name =~ s/__|\./::/g;
1103
$self->maptype->{$name} = $simple
1104
? die "Schema/namespace for type '$type' is not specified\n"
1105
: $SOAP::Constants::NS_SL_PERLTYPE
1106
unless exists $self->maptype->{$name};
1107
$type = $self->maptype->{$name}
1108
? SOAP::Utils::qualify($self->namespaces->{$self->maptype->{$name}} ||= gen_ns, $type)
1109
: undef;
1110
}
1111
return $type;
1112
}
1113
1114
sub encode_object {
1115
my($self, $object, $name, $type, $attr) = @_;
1116
1117
$attr ||= {};
1118
return $self->encode_scalar($object, $name, $type, $attr)
1119
unless ref $object;
1120
1121
my $id = $self->multiref_object($object);
1122
1123
use vars '%objectstack'; # we'll play with symbol table
1124
local %objectstack = %objectstack; # want to see objects ONLY in the current tree
1125
1126
# did we see this object in current tree? Seems to be recursive refs
1127
# same as call to $self->recursive_object($object) - but
1128
# recursive_object($object) has to re-compute the object's id
1129
if (++$objectstack{ $id } > 1) {
1130
$self->{ _seen }->{ $id }->{recursive} = 1
1131
}
1132
1133
# return if we already saw it twice. It should be already properly serialized
1134
return if $objectstack{$id} > 2;
1135
1136
if (UNIVERSAL::isa($object => 'SOAP::Data')) {
1137
# use $object->SOAP::Data:: to enable overriding name() and others in inherited classes
1138
$object->SOAP::Data::name($name)
1139
unless defined $object->SOAP::Data::name;
1140
1141
# apply ->uri() and ->prefix() which can modify name and attributes of
1142
# element, but do not modify SOAP::Data itself
1143
my($name, $attr) = $self->fixattrs($object);
1144
$attr = $self->attrstoqname($attr);
1145
1146
my @realvalues = $object->SOAP::Data::value;
1147
return [$name || gen_name, $attr] unless @realvalues;
1148
1149
my $method = "as_" . ($object->SOAP::Data::type || '-'); # dummy type if not defined
1150
# try to call method specified for this type
1151
no strict qw(refs);
1152
my @values = map {
1153
# store null/nil attribute if value is undef
1154
local $attr->{SOAP::Utils::qualify(xsi => $self->xmlschemaclass->nilValue)} = $self->xmlschemaclass->as_undef(1)
1155
unless defined;
1156
$self->can($method) && $self->$method($_, $name || gen_name, $object->SOAP::Data::type, $attr)
1157
|| $self->typecast($_, $name || gen_name, $object->SOAP::Data::type, $attr)
1158
|| $self->encode_object($_, $name, $object->SOAP::Data::type, $attr)
1159
} @realvalues;
1160
$object->SOAP::Data::signature([map {join $;, $_->[0], SOAP::Utils::disqualify($_->[1]->{'xsi:type'} || '')} @values]) if @values;
1161
return wantarray ? @values : $values[0];
1162
}
1163
1164
my $class = ref $object;
1165
1166
if ($class !~ /^(?:SCALAR|ARRAY|HASH|REF)$/o) {
1167
# we could also check for CODE|GLOB|LVALUE, but we cannot serialize
1168
# them anyway, so they'll be cought by check below
1169
$class =~ s/::/__/g;
1170
1171
$name = $class if !defined $name;
1172
$type = $class if !defined $type && $self->autotype;
1173
1174
my $method = 'as_' . $class;
1175
if ($self->can($method)) {
1176
no strict qw(refs);
1177
my $encoded = $self->$method($object, $name, $type, $attr);
1178
return $encoded if ref $encoded;
1179
# return only if handled, otherwise handle with default handlers
1180
}
1181
}
1182
1183
if (UNIVERSAL::isa($object => 'REF') || UNIVERSAL::isa($object => 'SCALAR')) {
1184
return $self->encode_scalar($object, $name, $type, $attr);
1185
}
1186
elsif (UNIVERSAL::isa($object => 'ARRAY')) {
1187
# Added in SOAP::Lite 0.65_6 to fix an XMLRPC bug
1188
return $self->encodingStyle eq ""
1189
|| $self->isa('XMLRPC::Serializer')
1190
? $self->encode_array($object, $name, $type, $attr)
1191
: $self->encode_literal_array($object, $name, $type, $attr);
1192
}
1193
elsif (UNIVERSAL::isa($object => 'HASH')) {
1194
return $self->encode_hash($object, $name, $type, $attr);
1195
}
1196
else {
1197
return $self->on_nonserialized->($object);
1198
}
1199
}
1200
1201
sub encode_scalar {
1202
my($self, $value, $name, $type, $attr) = @_;
1203
$name ||= gen_name;
1204
1205
my $schemaclass = $self->xmlschemaclass;
1206
1207
# null reference
1208
return [$name, {%$attr, SOAP::Utils::qualify(xsi => $schemaclass->nilValue) => $schemaclass->as_undef(1)}] unless defined $value;
1209
1210
# object reference
1211
return [$name, {'xsi:type' => $self->maptypetouri($type), %$attr}, [$self->encode_object($$value)], $self->gen_id($value)] if ref $value;
1212
1213
# autodefined type
1214
if ($self->{ _autotype}) {
1215
my $lookup = $self->{_typelookup};
1216
no strict qw(refs);
1217
#for (sort {$lookup->{$a}->[0] <=> $lookup->{$b}->[0]} keys %$lookup) {
1218
for (@{ $self->{ _typelookup_order } }) {
1219
my $method = $lookup->{$_}->[2];
1220
return $self->can($method) && $self->$method($value, $name, $type, $attr)
1221
|| $method->($value, $name, $type, $attr)
1222
if $lookup->{$_}->[1]->($value);
1223
}
1224
}
1225
1226
# invariant
1227
return [$name, $attr, $value];
1228
}
1229
1230
sub encode_array {
1231
my ($self, $array, $name, $type, $attr) = @_;
1232
my $items = 'item';
1233
1234
# If typing is disabled, just serialize each of the array items
1235
# with no type information, each using the specified name,
1236
# and do not crete a wrapper array tag.
1237
if (!$self->autotype) {
1238
$name ||= gen_name;
1239
return map {$self->encode_object($_, $name)} @$array;
1240
}
1241
1242
# TODO: add support for multidimensional, partially transmitted and sparse arrays
1243
my @items = map {$self->encode_object($_, $items)} @$array;
1244
my $num = @items;
1245
my($arraytype, %types) = '-';
1246
for (@items) { $arraytype = $_->[1]->{'xsi:type'} || '-'; $types{$arraytype}++ }
1247
$arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue) : $arraytype;
1248
1249
# $type = SOAP::Utils::qualify($self->encprefix => 'Array') if $self->autotype && !defined $type;
1250
$type = qualify($self->encprefix => 'Array') if !defined $type;
1251
return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
1252
{
1253
SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype,
1254
'xsi:type' => $self->maptypetouri($type), %$attr
1255
},
1256
[@items],
1257
$self->gen_id($array)
1258
];
1259
}
1260
1261
# Will encode arrays using doc-literal style
1262
sub encode_literal_array {
1263
my($self, $array, $name, $type, $attr) = @_;
1264
1265
if ($self->autotype) {
1266
my $items = 'item';
1267
1268
# TODO: add support for multidimensional, partially transmitted and sparse arrays
1269
my @items = map {$self->encode_object($_, $items)} @$array;
1270
1271
1272
my $num = @items;
1273
my($arraytype, %types) = '-';
1274
for (@items) {
1275
$arraytype = $_->[1]->{'xsi:type'} || '-';
1276
$types{$arraytype}++
1277
}
1278
$arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-'
1279
? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue)
1280
: $arraytype;
1281
1282
$type = SOAP::Utils::qualify($self->encprefix => 'Array')
1283
if !defined $type;
1284
1285
return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
1286
{
1287
SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype,
1288
'xsi:type' => $self->maptypetouri($type), %$attr
1289
},
1290
[ @items ],
1291
$self->gen_id($array)
1292
];
1293
}
1294
else {
1295
#
1296
# literal arrays are different - { array => [ 5,6 ] }
1297
# results in <array>5</array><array>6</array>
1298
# This means that if there's a literal inside the array (not a
1299
# reference), we have to encode it this way. If there's only
1300
# nested tags, encode as
1301
# <array><foo>1</foo><foo>2</foo></array>
1302
#
1303
1304
my $literal = undef;
1305
my @items = map {
1306
ref $_
1307
? $self->encode_object($_)
1308
: do {
1309
$literal++;
1310
$_
1311
}
1312
1313
} @$array;
1314
1315
if ($literal) {
1316
return map { [ $name , $attr , $_, $self->gen_id($array) ] } @items;
1317
}
1318
else {
1319
return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
1320
$attr,
1321
[ @items ],
1322
$self->gen_id($array)
1323
];
1324
}
1325
}
1326
}
1327
1328
sub encode_hash {
1329
my($self, $hash, $name, $type, $attr) = @_;
1330
1331
if ($self->autotype && grep {!/$SOAP::Constants::ELMASK/o} keys %$hash) {
1332
warn qq!Cannot encode @{[$name ? "'$name'" : 'unnamed']} element as 'hash'. Will be encoded as 'map' instead\n! if $^W;
1333
return $self->as_map($hash, $name || gen_name, $type, $attr);
1334
}
1335
1336
$type = 'SOAPStruct'
1337
if $self->autotype && !defined($type) && exists $self->maptype->{SOAPStruct};
1338
return [$name || gen_name,
1339
$self->autotype ? {'xsi:type' => $self->maptypetouri($type), %$attr} : { %$attr },
1340
[map {$self->encode_object($hash->{$_}, $_)} keys %$hash],
1341
$self->gen_id($hash)
1342
];
1343
}
1344
1345
sub as_ordered_hash {
1346
my ($self, $value, $name, $type, $attr) = @_;
1347
die "Not an ARRAY reference for 'ordered_hash' type" unless UNIVERSAL::isa($value => 'ARRAY');
1348
return [ $name, $attr,
1349
[map{$self->encode_object(@{$value}[2*$_+1,2*$_])} 0..$#$value/2 ],
1350
$self->gen_id($value)
1351
];
1352
}
1353
1354
sub as_map {
1355
my ($self, $value, $name, $type, $attr) = @_;
1356
die "Not a HASH reference for 'map' type" unless UNIVERSAL::isa($value => 'HASH');
1357
my $prefix = ($self->namespaces->{$SOAP::Constants::NS_APS} ||= 'apachens');
1358
my @items = map {
1359
$self->encode_object(
1360
SOAP::Data->type(
1361
ordered_hash => [
1362
key => $_,
1363
value => $value->{$_}
1364
]
1365
),
1366
'item',
1367
''
1368
)} keys %$value;
1369
return [
1370
$name,
1371
{'xsi:type' => "$prefix:Map", %$attr},
1372
[@items],
1373
$self->gen_id($value)
1374
];
1375
}
1376
1377
sub as_xml {
1378
my $self = shift;
1379
my($value, $name, $type, $attr) = @_;
1380
return [$name, {'_xml' => 1}, $value];
1381
}
1382
1383
sub typecast {
1384
my $self = shift;
1385
my($value, $name, $type, $attr) = @_;
1386
return if ref $value; # skip complex object, caller knows how to deal with it
1387
return if $self->autotype && !defined $type; # we don't know, autotype knows
1388
return [$name,
1389
{(defined $type && $type gt '' ? ('xsi:type' => $self->maptypetouri($type, 'simple type')) : ()), %$attr},
1390
$value
1391
];
1392
}
1393
1394
sub register_ns {
1395
my $self = shift->new();
1396
my ($ns,$prefix) = @_;
1397
$prefix = gen_ns if !$prefix;
1398
$self->{'_namespaces'}->{$ns} = $prefix if $ns;
1399
}
1400
1401
sub find_prefix {
1402
my ($self, $ns) = @_;
1403
return (exists $self->{'_namespaces'}->{$ns})
1404
? $self->{'_namespaces'}->{$ns}
1405
: ();
1406
}
1407
1408
sub fixattrs {
1409
my ($self, $data) = @_;
1410
my ($name, $attr) = ($data->SOAP::Data::name, {%{$data->SOAP::Data::attr}});
1411
my ($xmlns, $prefix) = ($data->uri, $data->prefix);
1412
unless (defined($xmlns) || defined($prefix)) {
1413
$self->register_ns($xmlns,$prefix) unless ($self->use_default_ns);
1414
return ($name, $attr);
1415
}
1416
$name ||= gen_name(); # local name
1417
$prefix = gen_ns() if !defined $prefix && $xmlns gt '';
1418
$prefix = ''
1419
if defined $xmlns && $xmlns eq ''
1420
|| defined $prefix && $prefix eq '';
1421
1422
$attr->{join ':', xmlns => $prefix || ()} = $xmlns if defined $xmlns;
1423
$name = join ':', $prefix, $name if $prefix;
1424
1425
$self->register_ns($xmlns,$prefix) unless ($self->use_default_ns);
1426
1427
return ($name, $attr);
1428
1429
}
1430
1431
sub toqname {
1432
my $self = shift;
1433
my $long = shift;
1434
1435
return $long unless $long =~ /^\{(.*)\}(.+)$/;
1436
return SOAP::Utils::qualify $self->namespaces->{$1} ||= gen_ns, $2;
1437
}
1438
1439
sub attrstoqname {
1440
my $self = shift;
1441
my $attrs = shift;
1442
1443
return {
1444
map { /^\{(.*)\}(.+)$/
1445
? ($self->toqname($_) => $2 eq 'type'
1446
|| $2 eq 'arrayType'
1447
? $self->toqname($attrs->{$_})
1448
: $attrs->{$_})
1449
: ($_ => $attrs->{$_})
1450
} keys %$attrs
1451
};
1452
}
1453
1454
sub tag {
1455
my ($self, $tag, $attrs, @values) = @_;
1456
1457
my $readable = $self->{ _readable };
1458
1459
my $value = join '', @values;
1460
my $indent = $readable ? ' ' x (($self->{ _level }-1)*2) : '';
1461
1462
# check for special attribute
1463
return "$indent$value" if exists $attrs->{_xml} && delete $attrs->{_xml};
1464
1465
die "Element '$tag' can't be allowed in valid XML message. Died."
1466
if $tag !~ /^$SOAP::Constants::NSMASK$/o;
1467
1468
warn "Element '$tag' uses the reserved prefix 'XML' (in any case)"
1469
if $tag !~ /^(?![Xx][Mm][Ll])/;
1470
1471
my $prolog = $readable ? "\n" : "";
1472
my $epilog = $readable ? "\n" : "";
1473
my $tagjoiner = " ";
1474
if ($self->{ _level } == 1) {
1475
my $namespaces = $self->namespaces;
1476
foreach (keys %$namespaces) {
1477
$attrs->{SOAP::Utils::qualify(xmlns => $namespaces->{$_})} = $_
1478
}
1479
$prolog = qq!<?xml version="1.0" encoding="@{[$self->encoding]}"?>!
1480
if defined $self->encoding;
1481
$prolog .= "\n" if $readable;
1482
$tagjoiner = " \n".(' ' x 4 ) if $readable;
1483
}
1484
my $tagattrs = join($tagjoiner, '',
1485
map { sprintf '%s="%s"', $_, SOAP::Utils::encode_attribute($attrs->{$_}) }
1486
grep { $_ && defined $attrs->{$_} && ($_ ne 'xsi:type' || $attrs->{$_} ne '') }
1487
keys %$attrs);
1488
1489
if ($value gt '') {
1490
return sprintf("$prolog$indent<%s%s>%s%s</%s>$epilog",$tag,$tagattrs,$value,($value =~ /^\s*</ ? $indent : ""),$tag);
1491
}
1492
else {
1493
return sprintf("$prolog$indent<%s%s />$epilog$indent",$tag,$tagattrs);
1494
}
1495
}
1496
1497
sub xmlize {
1498
my $self = shift;
1499
my($name, $attrs, $values, $id) = @{$_[0]};
1500
$attrs ||= {};
1501
1502
local $self->{_level} = $self->{_level} + 1;
1503
1504
return $self->tag($name, $attrs)
1505
unless defined $values;
1506
1507
return $self->tag($name, $attrs, $values)
1508
unless ref $values eq "ARRAY";
1509
1510
return $self->tag($name, {%$attrs, href => '#'.$self->multiref_anchor($id)})
1511
if $self->is_href($id, delete($attrs->{_id}));
1512
1513
# we have seen this element as a reference
1514
if (defined $id && $self->{ _seen }->{ $id }->{ multiref}) {
1515
return $self->tag($name,
1516
{
1517
%$attrs, id => $self->multiref_anchor($id)
1518
},
1519
map {$self->xmlize($_)} @$values
1520
);
1521
}
1522
else {
1523
return $self->tag($name, $attrs, map {$self->xmlize($_)} @$values);
1524
}
1525
}
1526
1527
sub uriformethod {
1528
my $self = shift;
1529
1530
my $method_is_data = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Data');
1531
1532
# drop prefix from method that could be string or SOAP::Data object
1533
my($prefix, $method) = $method_is_data
1534
? ($_[0]->prefix, $_[0]->name)
1535
: SOAP::Utils::splitqname($_[0]);
1536
1537
my $attr = {reverse %{$self->namespaces}};
1538
# try to define namespace that could be stored as
1539
# a) method is SOAP::Data
1540
# ? attribute in method's element as xmlns= or xmlns:${prefix}=
1541
# : uri
1542
# b) attribute in Envelope element as xmlns= or xmlns:${prefix}=
1543
# c) no prefix or prefix equal serializer->envprefix
1544
# ? '', but see coment below
1545
# : die with error message
1546
my $uri = $method_is_data
1547
? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri)
1548
: $self->uri;
1549
1550
defined $uri or $uri = $attr->{$prefix || ''};
1551
1552
defined $uri or $uri = !$prefix || $prefix eq $self->envprefix
1553
# still in doubts what should namespace be in this case
1554
# but will keep it like this for now and be compatible with our server
1555
? ( $method_is_data
1556
&& $^W
1557
&& warn("URI is not provided as an attribute for method ($method)\n"),
1558
''
1559
)
1560
: die "Can't find namespace for method ($prefix:$method)\n";
1561
1562
return ($uri, $method);
1563
}
1564
1565
sub serialize { SOAP::Trace::trace('()');
1566
my $self = shift->new;
1567
@_ == 1 or Carp::croak "serialize() method accepts one parameter";
1568
1569
$self->seen({}); # reinitialize multiref table
1570
my($encoded) = $self->encode_object($_[0]);
1571
1572
# now encode multirefs if any
1573
# v -------------- subelements of Envelope
1574
push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2];
1575
return $self->xmlize($encoded);
1576
}
1577
1578
sub envelope {
1579
SOAP::Trace::trace('()');
1580
my $self = shift->new;
1581
my $type = shift;
1582
my(@parameters, @header);
1583
for (@_) {
1584
# Find all the SOAP Headers
1585
if (defined($_) && ref($_) && UNIVERSAL::isa($_ => 'SOAP::Header')) {
1586
push(@header, $_);
1587
}
1588
# Find all the SOAP Message Parts (attachments)
1589
elsif (defined($_) && ref($_) && $self->context
1590
&& $self->context->packager->is_supported_part($_)
1591
) {
1592
$self->context->packager->push_part($_);
1593
}
1594
# Find all the SOAP Body elements
1595
else {
1596
# proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope
1597
push(@parameters, $_);
1598
# push (@parameters, SOAP::Utils::encode_data($_));
1599
}
1600
}
1601
my $header = @header ? SOAP::Data->set_value(@header) : undef;
1602
my($body,$parameters);
1603
if ($type eq 'method' || $type eq 'response') {
1604
SOAP::Trace::method(@parameters);
1605
1606
my $method = shift(@parameters);
1607
# or die "Unspecified method for SOAP call\n";
1608
1609
$parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
1610
if (!defined($method)) {}
1611
elsif (UNIVERSAL::isa($method => 'SOAP::Data')) {
1612
$body = $method;
1613
}
1614
elsif ($self->use_default_ns) {
1615
if ($self->{'_ns_uri'}) {
1616
$body = SOAP::Data->name($method)
1617
->attr({'xmlns' => $self->{'_ns_uri'} } );
1618
}
1619
else {
1620
$body = SOAP::Data->name($method);
1621
}
1622
}
1623
else {
1624
# Commented out by Byrne on 1/4/2006 - to address default namespace problems
1625
# $body = SOAP::Data->name($method)->uri($self->{'_ns_uri'});
1626
# $body = $body->prefix($self->{'_ns_prefix'}) if ($self->{'_ns_prefix'});
1627
1628
# Added by Byrne on 1/4/2006 - to avoid the unnecessary creation of a new
1629
# namespace
1630
# Begin New Code (replaces code commented out above)
1631
$body = SOAP::Data->name($method);
1632
my $pre = $self->find_prefix($self->{'_ns_uri'});
1633
$body = $body->prefix($pre) if ($self->{'_ns_prefix'});
1634
# End new code
1635
}
1636
1637
# This is breaking a unit test right now...
1638
# proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope
1639
# $body->set_value(SOAP::Utils::encode_data($parameters ? \$parameters : ()))
1640
# if $body;
1641
# must call encode_data on nothing to enforce xsi:nil="true" to be set.
1642
$body->set_value($parameters ? \$parameters : SOAP::Utils::encode_data()) if $body;
1643
}
1644
elsif ($type eq 'fault') {
1645
SOAP::Trace::fault(@parameters);
1646
# -> attr({'xmlns' => ''})
1647
# Parameter order fixed thanks to Tom Fischer
1648
$body = SOAP::Data-> name(SOAP::Utils::qualify($self->envprefix => 'Fault'))
1649
-> value(\SOAP::Data->set_value(
1650
SOAP::Data->name(faultcode => SOAP::Utils::qualify($self->envprefix => $parameters[0]))->type(""),
1651
SOAP::Data->name(faultstring => SOAP::Utils::encode_data($parameters[1]))->type(""),
1652
defined($parameters[3])
1653
? SOAP::Data->name(faultactor => $parameters[3])->type("")
1654
: (),
1655
defined($parameters[2])
1656
? SOAP::Data->name(detail => do{
1657
my $detail = $parameters[2];
1658
ref $detail
1659
? \$detail
1660
: SOAP::Utils::encode_data($detail)
1661
})
1662
: (),
1663
));
1664
}
1665
elsif ($type eq 'freeform') {
1666
SOAP::Trace::freeform(@parameters);
1667
$body = SOAP::Data->set_value(@parameters);
1668
}
1669
elsif (!defined($type)) {
1670
# This occurs when the Body is intended to be null. When no method has been
1671
# passed in of any kind.
1672
}
1673
else {
1674
die "Wrong type of envelope ($type) for SOAP call\n";
1675
}
1676
1677
$self->{ _seen } = {}; # reinitialize multiref table
1678
1679
# Build the envelope
1680
# Right now it is possible for $body to be a SOAP::Data element that has not
1681
# XML escaped any values. How do you remedy this?
1682
my($encoded) = $self->encode_object(
1683
SOAP::Data->name(
1684
SOAP::Utils::qualify($self->envprefix => 'Envelope') => \SOAP::Data->value(
1685
($header
1686
? SOAP::Data->name( SOAP::Utils::qualify($self->envprefix => 'Header') => \$header)
1687
: ()
1688
),
1689
($body
1690
? SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body') => \$body)
1691
: SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body')) ),
1692
)
1693
)->attr($self->attr)
1694
);
1695
1696
$self->signature($parameters->signature) if ref $parameters;
1697
1698
# IMHO multirefs should be encoded after Body, but only some
1699
# toolkits understand this encoding, so we'll keep them for now (04/15/2001)
1700
# as the last element inside the Body
1701
# v -------------- subelements of Envelope
1702
# vv -------- last of them (Body)
1703
# v --- subelements
1704
push(@{$encoded->[2]->[-1]->[2]}, $self->encode_multirefs) if ref $encoded->[2]->[-1]->[2];
1705
1706
# Sometimes SOAP::Serializer is invoked statically when there is no context.
1707
# So first check to see if a context exists.
1708
# TODO - a context needs to be initialized by a constructor?
1709
if ($self->context && $self->context->packager->parts) {
1710
# TODO - this needs to be called! Calling it though wraps the payload twice!
1711
# return $self->context->packager->package($self->xmlize($encoded));
1712
}
1713
1714
return $self->xmlize($encoded);
1715
}
1716
1717
# ======================================================================
1718
1719
package SOAP::Parser;
1720
1721
sub DESTROY { SOAP::Trace::objects('()') }
1722
1723
sub xmlparser {
1724
my $self = shift;
1725
return eval {
1726
$SOAP::Constants::DO_NOT_USE_XML_PARSER
1727
? undef
1728
: do {
1729
require XML::Parser;
1730
XML::Parser->new() }
1731
}
1732
|| eval { require XML::Parser::Lite; XML::Parser::Lite->new }
1733
|| die "XML::Parser is not @{[$SOAP::Constants::DO_NOT_USE_XML_PARSER ? 'used' : 'available']} and ", $@;
1734
}
1735
1736
sub parser {
1737
my $self = shift->new;
1738
@_
1739
? do {
1740
$self->{'_parser'} = shift;
1741
return $self;
1742
}
1743
: return ($self->{'_parser'} ||= $self->xmlparser);
1744
}
1745
1746
sub new {
1747
my $self = shift;
1748
return $self if ref $self;
1749
my $class = $self;
1750
SOAP::Trace::objects('()');
1751
return bless {_parser => shift}, $class;
1752
}
1753
1754
sub decode { SOAP::Trace::trace('()');
1755
my $self = shift;
1756
1757
$self->parser->setHandlers(
1758
Final => sub { shift; $self->final(@_) },
1759
Start => sub { shift; $self->start(@_) },
1760
End => sub { shift; $self->end(@_) },
1761
Char => sub { shift; $self->char(@_) },
1762
ExternEnt => sub { shift; die "External entity (pointing to '$_[1]') is not allowed" },
1763
);
1764
# my $parsed = $self->parser->parse($_[0]);
1765
# return $parsed;
1766
#
1767
my $ret = undef;
1768
eval {
1769
$ret = $self->parser->parse($_[0]);
1770
};
1771
if ($@) {
1772
$self->final; # Clean up in the event of an error
1773
die $@; # Pass back the error
1774
}
1775
return $ret;
1776
}
1777
1778
sub final {
1779
my $self = shift;
1780
1781
# clean handlers, otherwise SOAP::Parser won't be deleted:
1782
# it refers to XML::Parser which refers to subs from SOAP::Parser
1783
# Thanks to Ryan Adams <iceman@mit.edu>
1784
# and Craig Johnston <craig.johnston@pressplay.com>
1785
# checked by number of tests in t/02-payload.t
1786
1787
undef $self->{_values};
1788
$self->parser->setHandlers(
1789
Final => undef,
1790
Start => undef,
1791
End => undef,
1792
Char => undef,
1793
ExternEnt => undef,
1794
);
1795
$self->{_done};
1796
}
1797
1798
sub start { push @{shift->{_values}}, [shift, {@_}] }
1799
1800
# string concatenation changed to arrays which should improve performance
1801
# for strings with many entity-encoded elements.
1802
# Thanks to Mathieu Longtin <mrdamnfrenchy@yahoo.com>
1803
sub char { push @{shift->{_values}->[-1]->[3]}, shift }
1804
1805
sub end {
1806
my $self = shift;
1807
my $done = pop @{$self->{_values}};
1808
$done->[2] = defined $done->[3]
1809
? join('',@{$done->[3]})
1810
: '' unless ref $done->[2];
1811
undef $done->[3];
1812
@{$self->{_values}}
1813
? (push @{$self->{_values}->[-1]->[2]}, $done)
1814
: ($self->{_done} = $done);
1815
}
1816
1817
# ======================================================================
1818
1819
package SOAP::SOM;
1820
1821
use Carp ();
1822
use SOAP::Lite::Utils;
1823
1824
sub BEGIN {
1825
no strict 'refs';
1826
my %path = (
1827
root => '/',
1828
envelope => '/Envelope',
1829
body => '/Envelope/Body',
1830
header => '/Envelope/Header',
1831
headers => '/Envelope/Header/[>0]',
1832
fault => '/Envelope/Body/Fault',
1833
faultcode => '/Envelope/Body/Fault/faultcode',
1834
faultstring => '/Envelope/Body/Fault/faultstring',
1835
faultactor => '/Envelope/Body/Fault/faultactor',
1836
faultdetail => '/Envelope/Body/Fault/detail',
1837
);
1838
for my $method (keys %path) {
1839
*$method = sub {
1840
my $self = shift;
1841
ref $self or return $path{$method};
1842
Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
1843
return $self->valueof($path{$method});
1844
};
1845
}
1846
my %results = (
1847
method => '/Envelope/Body/[1]',
1848
result => '/Envelope/Body/[1]/[1]',
1849
freeform => '/Envelope/Body/[>0]',
1850
paramsin => '/Envelope/Body/[1]/[>0]',
1851
paramsall => '/Envelope/Body/[1]/[>0]',
1852
paramsout => '/Envelope/Body/[1]/[>1]'
1853
);
1854
for my $method (keys %results) {
1855
*$method = sub {
1856
my $self = shift;
1857
ref $self or return $results{$method};
1858
Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
1859
defined $self->fault ? return : return $self->valueof($results{$method});
1860
};
1861
}
1862
1863
for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils
1864
*$method = \&{'SOAP::Utils::'.$method};
1865
}
1866
1867
__PACKAGE__->__mk_accessors('context');
1868
1869
}
1870
1871
# use object in boolean context return true/false on last match
1872
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success';
1873
use overload fallback => 1, 'bool' => sub { @{shift->{_current}} > 0 };
1874
1875
sub DESTROY { SOAP::Trace::objects('()') }
1876
1877
sub new {
1878
my $self = shift;
1879
my $class = ref($self) || $self;
1880
my $content = shift;
1881
SOAP::Trace::objects('()');
1882
return bless { _content => $content, _current => [$content] } => $class;
1883
}
1884
1885
sub parts {
1886
my $self = shift;
1887
if (@_) {
1888
$self->context->packager->parts(@_);
1889
return $self;
1890
}
1891
else {
1892
return $self->context->packager->parts;
1893
}
1894
}
1895
1896
sub is_multipart {
1897
my $self = shift;
1898
return defined($self->parts);
1899
}
1900
1901
sub current {
1902
my $self = shift;
1903
$self->{_current} = [@_], return $self if @_;
1904
return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
1905
}
1906
1907
sub valueof {
1908
my $self = shift;
1909
local $self->{_current} = $self->{_current};
1910
$self->match(shift) if @_;
1911
return wantarray
1912
? map {o_value($_)} @{$self->{_current}}
1913
: @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef;
1914
}
1915
1916
sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
1917
wantarray
1918
? map { bless $_ => 'SOAP::Header' } shift->dataof(@_)
1919
: do { # header returned by ->dataof can be undef in scalar context
1920
my $header = shift->dataof(@_);
1921
ref $header ? bless($header => 'SOAP::Header') : undef;
1922
};
1923
}
1924
1925
sub dataof {
1926
my $self = shift;
1927
local $self->{_current} = $self->{_current};
1928
$self->match(shift) if @_;
1929
return wantarray
1930
? map {$self->_as_data($_)} @{$self->{_current}}
1931
: @{$self->{_current}}
1932
? $self->_as_data($self->{_current}->[0])
1933
: undef;
1934
}
1935
1936
sub namespaceuriof {
1937
my $self = shift;
1938
local $self->{_current} = $self->{_current};
1939
$self->match(shift) if @_;
1940
return wantarray
1941
? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}}
1942
: @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef;
1943
}
1944
1945
#sub _as_data {
1946
# my $self = shift;
1947
# my $pointer = shift;
1948
#
1949
# SOAP::Data
1950
# -> new(prefix => '', name => o_qname($pointer), name => o_lname($pointer), attr => o_lattr($pointer))
1951
# -> set_value(o_value($pointer));
1952
#}
1953
1954
sub _as_data {
1955
my $self = shift;
1956
my $node = shift;
1957
1958
my $data = SOAP::Data->new( prefix => '',
1959
# name => o_qname has side effect: sets namespace !
1960
name => o_qname($node),
1961
name => o_lname($node),
1962
attr => o_lattr($node) );
1963
1964
if ( defined o_child($node) ) {
1965
my @children;
1966
foreach my $child ( @{ o_child($node) } ) {
1967
push( @children, $self->_as_data($child) );
1968
}
1969
$data->set_value( \SOAP::Data->value(@children) );
1970
}
1971
else {
1972
$data->set_value( o_value($node) );
1973
}
1974
1975
return $data;
1976
}
1977
1978
1979
sub match {
1980
my $self = shift;
1981
my $path = shift;
1982
$self->{_current} = [
1983
$path =~ s!^/!! || !@{$self->{_current}}
1984
? $self->_traverse($self->{_content}, 1 => split '/' => $path)
1985
: map {$self->_traverse_tree(o_child($_), split '/' => $path)} @{$self->{_current}}
1986
];
1987
return $self;
1988
}
1989
1990
sub _traverse {
1991
my ($self, $pointer, $itself, $path, @path) = @_;
1992
1993
die "Incorrect parameter" unless $itself =~/^\d+$/;
1994
1995
if ($path && substr($path, 0, 1) eq '{') {
1996
$path = join '/', $path, shift @path while @path && $path !~ /}/;
1997
}
1998
1999
my($op, $num) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/ if defined $path;
2000
2001
return $pointer unless defined $path;
2002
2003
if (! $op) {
2004
$op = '==';
2005
}
2006
elsif ($op eq '=' || $op eq '!') {
2007
$op .= '=';
2008
}
2009
my $numok = defined $num && eval "$itself $op $num";
2010
my $nameok = (o_lname($pointer) || '') =~ /(?:^|\})$path$/ if defined $path; # name can be with namespace
2011
2012
my $anynode = $path eq '';
2013
unless ($anynode) {
2014
if (@path) {
2015
return if defined $num && !$numok || !defined $num && !$nameok;
2016
}
2017
else {
2018
return $pointer if defined $num && $numok || !defined $num && $nameok;
2019
return;
2020
}
2021
}
2022
2023
my @walk;
2024
push @walk, $self->_traverse_tree([$pointer], @path) if $anynode;
2025
push @walk, $self->_traverse_tree(o_child($pointer), $anynode ? ($path, @path) : @path);
2026
return @walk;
2027
}
2028
2029
sub _traverse_tree {
2030
my ($self, $pointer, @path) = @_;
2031
2032
# can be list of children or value itself. Traverse only children
2033
return unless ref $pointer eq 'ARRAY';
2034
2035
my $itself = 1;
2036
2037
grep {defined}
2038
map {$self->_traverse($_, $itself++, @path)}
2039
grep {!ref o_lattr($_) ||
2040
!exists o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ||
2041
o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ne '0'}
2042
@$pointer;
2043
}
2044
2045
# ======================================================================
2046
2047
package SOAP::Deserializer;
2048
2049
use vars qw(@ISA);
2050
use SOAP::Lite::Utils;
2051
use Class::Inspector;
2052
2053
@ISA = qw(SOAP::Cloneable);
2054
2055
sub DESTROY { SOAP::Trace::objects('()') }
2056
2057
sub BEGIN {
2058
__PACKAGE__->__mk_accessors( qw(ids hrefs parts parser
2059
base xmlschemas xmlschema context) );
2060
}
2061
2062
# Cache (slow) Class::Inspector results
2063
my %_class_loaded=();
2064
2065
sub new {
2066
my $self = shift;
2067
return $self if ref $self;
2068
my $class = $self;
2069
SOAP::Trace::objects('()');
2070
return bless {
2071
'_ids' => {},
2072
'_hrefs' => {},
2073
'_parser' => SOAP::Parser->new,
2074
'_xmlschemas' => {
2075
$SOAP::Constants::NS_APS => 'SOAP::XMLSchemaApacheSOAP::Deserializer',
2076
# map {
2077
# $_ => $SOAP::Constants::XML_SCHEMAS{$_} . '::Deserializer'
2078
# } keys %SOAP::Constants::XML_SCHEMAS
2079
map {
2080
$_ => 'SOAP::Lite::Deserializer::' . $SOAP::Constants::XML_SCHEMA_OF{$_}
2081
} keys %SOAP::Constants::XML_SCHEMA_OF
2082
2083
},
2084
}, $class;
2085
}
2086
2087
sub is_xml {
2088
# Added check for envelope delivery. Fairly standard with MMDF and sendmail
2089
# Thanks to Chris Davies <Chris.Davies@ManheimEurope.com>
2090
$_[1] =~ /^\s*</ || $_[1] !~ /^(?:[\w-]+:|From )/;
2091
}
2092
2093
sub baselocation {
2094
my $self = shift;
2095
my $location = shift;
2096
if ($location) {
2097
my $uri = URI->new($location);
2098
# make absolute location if relative
2099
$location = $uri->abs($self->base || 'thismessage:/')->as_string unless $uri->scheme;
2100
}
2101
return $location;
2102
}
2103
2104
# Returns the envelope and populates SOAP::Packager with parts
2105
sub decode_parts {
2106
my $self = shift;
2107
my $env = $self->context->packager->unpackage($_[0],$self->context);
2108
my $body = $self->parser->decode($env);
2109
# TODO - This shouldn't be here! This is packager specific!
2110
# However this does need to pull out all the cid's
2111
# to populate ids hash with.
2112
foreach (@{$self->context->packager->parts}) {
2113
my $data = $_->bodyhandle->as_string;
2114
my $type = $_->head->mime_attr('Content-Type');
2115
my $location = $_->head->mime_attr('Content-Location');
2116
my $id = $_->head->mime_attr('Content-Id');
2117
$location = $self->baselocation($location);
2118
my $part = lc($type) eq 'text/xml' && !$SOAP::Constants::DO_NOT_PROCESS_XML_IN_MIME
2119
? $self->parser->decode($data)
2120
: ['mimepart', {}, $data];
2121
# This below looks like unnecessary bloat!!!
2122
# I should probably dereference the mimepart, provide a callback to get the string data
2123
$id =~ s/^<([^>]*)>$/$1/; # string any leading and trailing brackets
2124
$self->ids->{$id} = $part if $id;
2125
$self->ids->{$location} = $part if $location;
2126
}
2127
return $body;
2128
}
2129
2130
# decode returns a parsed body in the form of an ARRAY
2131
# each element of the ARRAY is a HASH, ARRAY or SCALAR
2132
sub decode {
2133
my $self = shift->new; # this actually is important
2134
return $self->is_xml($_[0])
2135
? $self->parser->decode($_[0])
2136
: $self->decode_parts($_[0]);
2137
}
2138
2139
# deserialize returns a SOAP::SOM object and parses straight
2140
# text as input
2141
sub deserialize {
2142
SOAP::Trace::trace('()');
2143
my $self = shift->new;
2144
2145
# initialize
2146
$self->hrefs({});
2147
$self->ids({});
2148
2149
# If the document is XML, then ids will be empty
2150
# If the document is MIME, then ids will hold a list of cids
2151
my $parsed = $self->decode($_[0]);
2152
2153
# Having this code here makes multirefs in the Body work, but multirefs
2154
# that reference XML fragments in a MIME part do not work.
2155
if (keys %{$self->ids()}) {
2156
$self->traverse_ids($parsed);
2157
}
2158
else {
2159
# delay - set ids to be traversed later in decode_object, they only get
2160
# traversed if an href is found that is referencing an id.
2161
$self->ids($parsed);
2162
}
2163
$self->decode_object($parsed);
2164
my $som = SOAP::SOM->new($parsed);
2165
$som->context($self->context); # TODO - try removing this and see if it works!
2166
return $som;
2167
}
2168
2169
sub traverse_ids {
2170
my $self = shift;
2171
my $ref = shift;
2172
my($undef, $attrs, $children) = @$ref;
2173
# ^^^^^^ to fix nasty error on Mac platform (Carl K. Cunningham)
2174
$self->ids->{$attrs->{'id'}} = $ref if exists $attrs->{'id'};
2175
return unless ref $children;
2176
for (@$children) {
2177
$self->traverse_ids($_)
2178
};
2179
}
2180
2181
use constant _ATTRS => 6;
2182
use constant _NAME => 5;
2183
2184
sub decode_object {
2185
my $self = shift;
2186
my $ref = shift;
2187
my($name, $attrs_ref, $children, $value) = @$ref;
2188
2189
my %attrs = %{ $attrs_ref };
2190
2191
$ref->[ _ATTRS ] = \%attrs; # make a copy for long attributes
2192
2193
use vars qw(%uris);
2194
local %uris = (%uris, map {
2195
do { (my $ns = $_) =~ s/^xmlns:?//; $ns } => delete $attrs{$_}
2196
} grep {/^xmlns(:|$)/} keys %attrs);
2197
2198
foreach (keys %attrs) {
2199
next unless m/^($SOAP::Constants::NSMASK?):($SOAP::Constants::NSMASK)$/;
2200
2201
$1 =~ /^[xX][mM][lL]/ ||
2202
$uris{$1} &&
2203
do {
2204
$attrs{SOAP::Utils::longname($uris{$1}, $2)} = do {
2205
my $value = $attrs{$_};
2206
$2 ne 'type' && $2 ne 'arrayType'
2207
? $value
2208
: SOAP::Utils::longname($value =~ m/^($SOAP::Constants::NSMASK?):(${SOAP::Constants::NSMASK}(?:\[[\d,]*\])*)/
2209
? ($uris{$1} || die("Unresolved prefix '$1' for attribute value '$value'\n"), $2)
2210
: ($uris{''} || die("Unspecified namespace for type '$value'\n"), $value)
2211
);
2212
};
2213
1;
2214
}
2215
|| die "Unresolved prefix '$1' for attribute '$_'\n";
2216
}
2217
2218
# and now check the element
2219
my $ns = ($name =~ s/^($SOAP::Constants::NSMASK?):// ? $1 : '');
2220
$ref->[ _NAME ] = SOAP::Utils::longname(
2221
$ns
2222
? ($uris{$ns} || die "Unresolved prefix '$ns' for element '$name'\n")
2223
: (defined $uris{''} ? $uris{''} : undef),
2224
$name
2225
);
2226
2227
($children, $value) = (undef, $children) unless ref $children;
2228
2229
return $name => ($ref->[4] = $self->decode_value(
2230
[$ref->[ _NAME ], \%attrs, $children, $value]
2231
));
2232
}
2233
2234
sub decode_value {
2235
my $self = shift;
2236
my($name, $attrs, $children, $value) = @{ $_[0] };
2237
2238
# check SOAP version if applicable
2239
use vars '$level'; local $level = $level || 0;
2240
if (++$level == 1) {
2241
my($namespace, $envelope) = SOAP::Utils::splitlongname($name);
2242
SOAP::Lite->soapversion($namespace) if $envelope eq 'Envelope' && $namespace;
2243
}
2244
2245
if (exists $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}) {
2246
# check encodingStyle
2247
# future versions may bind deserializer to encodingStyle
2248
my $encodingStyle = $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"};
2249
# TODO - SOAP 1.2 and 1.1 have different rules about valid encodingStyle values
2250
# For example, in 1.1 - any http://schemas.xmlsoap.org/soap/encoding/*
2251
# value is valid
2252
if (defined $encodingStyle && length($encodingStyle)) {
2253
my %styles = map { $_ => undef } @SOAP::Constants::SUPPORTED_ENCODING_STYLES;
2254
my $found = 0;
2255
foreach my $e (split(/ +/,$encodingStyle)) {
2256
if (exists $styles{$e}) {
2257
$found ++;
2258
}
2259
}
2260
die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'"
2261
if (! $found) && !(SOAP::Lite->soapversion == 1.1 && $encodingStyle =~ /(?:^|\b)$SOAP::Constants::NS_ENC/);
2262
}
2263
}
2264
use vars '$arraytype'; # type of Array element specified on Array itself
2265
# either specified with xsi:type, or <enc:name/> or array element
2266
my ($type) = grep { defined }
2267
map($attrs->{$_}, sort grep {/^\{$SOAP::Constants::NS_XSI_ALL\}type$/o} keys %$attrs),
2268
$name =~ /^\{$SOAP::Constants::NS_ENC\}/ ? $name : $arraytype;
2269
local $arraytype; # it's used only for one level, we don't need it anymore
2270
2271
# $name is not used here since type should be encoded as type, not as name
2272
my ($schema, $class) = SOAP::Utils::splitlongname($type) if $type;
2273
my $schemaclass = defined($schema) && $self->{ _xmlschemas }->{$schema}
2274
|| $self;
2275
2276
if (! exists $_class_loaded{$schemaclass}) {
2277
no strict qw(refs);
2278
if (! Class::Inspector->loaded($schemaclass) ) {
2279
eval "require $schemaclass" or die $@ if not ref $schemaclass;
2280
}
2281
$_class_loaded{$schemaclass} = undef;
2282
}
2283
2284
# store schema that is used in parsed message
2285
$self->{ _xmlschema } = $schema if ($schema) && $schema =~ /XMLSchema/;
2286
2287
# don't use class/type if anyType/ur-type is specified on wire
2288
undef $class
2289
if $schemaclass->can('anyTypeValue')
2290
&& $schemaclass->anyTypeValue eq $class;
2291
2292
my $method = 'as_' . ($class || '-'); # dummy type if not defined
2293
$class =~ s/__|\./::/g if $class;
2294
2295
my $id = $attrs->{id};
2296
if (defined $id && exists $self->hrefs->{$id}) {
2297
return $self->hrefs->{$id};
2298
}
2299
elsif (exists $attrs->{href}) {
2300
(my $id = delete $attrs->{href}) =~ s/^(#|cid:|uuid:)?//;
2301
# convert to absolute if not internal '#' or 'cid:'
2302
$id = $self->baselocation($id) unless $1;
2303
return $self->hrefs->{$id} if exists $self->hrefs->{$id};
2304
# First time optimization. we don't traverse IDs unless asked for it.
2305
# This is where traversing id's is delayed from before
2306
# - the first time through - ids should contain a copy of the parsed XML
2307
# structure! seems silly to make so many copies
2308
my $ids = $self->ids;
2309
if (ref($ids) ne 'HASH') {
2310
$self->ids({}); # reset list of ids first time through
2311
$self->traverse_ids($ids);
2312
}
2313
if (exists($self->ids->{$id})) {
2314
my $obj = ($self->decode_object(delete($self->ids->{$id})))[1];
2315
return $self->hrefs->{$id} = $obj;
2316
}
2317
else {
2318
die "Unresolved (wrong?) href ($id) in element '$name'\n";
2319
}
2320
}
2321
2322
return undef if grep {
2323
/^$SOAP::Constants::NS_XSI_NILS$/ && do {
2324
my $class = $self->xmlschemas->{ $1 || $2 };
2325
eval "require $class" or die @$;;
2326
$class->as_undef($attrs->{$_})
2327
}
2328
} keys %$attrs;
2329
2330
# try to handle with typecasting
2331
my $res = $self->typecast($value, $name, $attrs, $children, $type);
2332
return $res if defined $res;
2333
2334
# ok, continue with others
2335
if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) {
2336
my $res = [];
2337
$self->hrefs->{$id} = $res if defined $id;
2338
2339
# check for arrayType which could be [1], [,2][5] or []
2340
# [,][1] will NOT be allowed right now (multidimensional sparse array)
2341
my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}
2342
=~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/
2343
or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!;
2344
2345
my @dimensions = map { $_ || undef } split /,/, $multisize;
2346
my $size = 1;
2347
foreach (@dimensions) { $size *= $_ || 0 }
2348
2349
# TODO ähm, shouldn't this local be my?
2350
local $arraytype = $type;
2351
2352
# multidimensional
2353
if ($multisize =~ /,/) {
2354
@$res = splitarray(
2355
[@dimensions],
2356
[map { scalar(($self->decode_object($_))[1]) } @{$children || []}]
2357
);
2358
}
2359
# normal
2360
else {
2361
@$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []};
2362
}
2363
2364
# sparse (position)
2365
if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) {
2366
my @new;
2367
for (my $pos = 0; $pos < @$children; $pos++) {
2368
# TBD implement position in multidimensional array
2369
my($position) = SOAP::Utils::o_lattr($children->[$pos])->{"{$SOAP::Constants::NS_ENC}position"} =~ /^\[(\d+)\]$/
2370
or die "Position must be specified for all elements of sparse array\n";
2371
$new[$position] = $res->[$pos];
2372
}
2373
@$res = @new;
2374
}
2375
2376
# partially transmitted (offset)
2377
# TBD implement offset in multidimensional array
2378
my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/
2379
if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"};
2380
unshift(@$res, (undef) x $offset) if $offset;
2381
2382
die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n"
2383
if $multisize && $size < @$res;
2384
2385
# extend the array if number of elements is specified
2386
$#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0];
2387
2388
return defined $class && $class ne 'Array' ? bless($res => $class) : $res;
2389
2390
}
2391
elsif ($name =~ /^\{$SOAP::Constants::NS_ENC\}Struct$/
2392
|| !$schemaclass->can($method)
2393
&& (ref $children || defined $class && $value =~ /^\s*$/)) {
2394
my $res = {};
2395
$self->hrefs->{$id} = $res if defined $id;
2396
2397
# Patch code introduced in 0.65 - deserializes array properly
2398
# Decode each element of the struct.
2399
my %child_count_of = ();
2400
foreach my $child (@{$children || []}) {
2401
my ($child_name, $child_value) = $self->decode_object($child);
2402
# Store the decoded element in the struct. If the element name is
2403
# repeated, replace the previous scalar value with a new array
2404
# containing both values.
2405
if (not $child_count_of{$child_name}) {
2406
# first time to see this value: use scalar
2407
$res->{$child_name} = $child_value;
2408
}
2409
elsif ($child_count_of{$child_name} == 1) {
2410
# second time to see this value: convert scalar to array
2411
$res->{$child_name} = [ $res->{$child_name}, $child_value ];
2412
}
2413
else {
2414
# already have an array: append to it
2415
push @{$res->{$child_name}}, $child_value;
2416
}
2417
$child_count_of{$child_name}++;
2418
}
2419
# End patch code
2420
2421
return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res;
2422
}
2423
else {
2424
my $res;
2425
if (my $method_ref = $schemaclass->can($method)) {
2426
$res = $method_ref->($self, $value, $name, $attrs, $children, $type);
2427
}
2428
else {
2429
$res = $self->typecast($value, $name, $attrs, $children, $type);
2430
$res = $class ? die "Unrecognized type '$type'\n" : $value
2431
unless defined $res;
2432
}
2433
$self->hrefs->{$id} = $res if defined $id;
2434
return $res;
2435
}
2436
}
2437
2438
sub splitarray {
2439
my @sizes = @{+shift};
2440
my $size = shift @sizes;
2441
my $array = shift;
2442
2443
return splice(@$array, 0, $size) unless @sizes;
2444
my @array = ();
2445
push @array, [
2446
splitarray([@sizes], $array)
2447
] while @$array && (!defined $size || $size--);
2448
return @array;
2449
}
2450
2451
sub typecast { } # typecast is called for both objects AND scalar types
2452
# check ref of the second parameter (first is the object)
2453
# return undef if you don't want to handle it
2454
2455
# ======================================================================
2456
2457
package SOAP::Client;
2458
2459
2460
use SOAP::Lite::Utils;
2461
2462
$VERSION = $SOAP::Lite::VERSION;
2463
sub BEGIN {
2464
__PACKAGE__->__mk_accessors(qw(endpoint code message
2465
is_success status options));
2466
}
2467
2468
# ======================================================================
2469
2470
package SOAP::Server::Object;
2471
2472
sub gen_id; *gen_id = \&SOAP::Serializer::gen_id;
2473
2474
my %alive;
2475
my %objects;
2476
2477
sub objects_by_reference {
2478
shift;
2479
while (@_) {
2480
@alive{shift()} = ref $_[0]
2481
? shift
2482
: sub {
2483
$_[1]-$_[$_[5] ? 5 : 4] > $SOAP::Constants::OBJS_BY_REF_KEEPALIVE
2484
}
2485
}
2486
keys %alive;
2487
}
2488
2489
sub reference {
2490
my $self = shift;
2491
my $stamp = time;
2492
my $object = shift;
2493
my $id = $stamp . $self->gen_id($object);
2494
2495
# this is code for garbage collection
2496
my $time = time;
2497
my $type = ref $object;
2498
my @objects = grep { $objects{$_}->[1] eq $type } keys %objects;
2499
for (grep { $alive{$type}->(scalar @objects, $time, @{$objects{$_}}) } @objects) {
2500
delete $objects{$_};
2501
}
2502
2503
$objects{$id} = [$object, $type, $stamp];
2504
bless { id => $id } => ref $object;
2505
}
2506
2507
sub references {
2508
my $self = shift;
2509
return @_ unless %alive; # small optimization
2510
return map {
2511
ref($_) && exists $alive{ref $_}
2512
? $self->reference($_)
2513
: $_
2514
} @_;
2515
}
2516
2517
sub object {
2518
my $self = shift;
2519
my $class = ref($self) || $self;
2520
my $object = shift;
2521
return $object unless ref($object) && $alive{ref $object} && exists $object->{id};
2522
2523
my $reference = $objects{$object->{id}};
2524
die "Object with specified id couldn't be found\n" unless ref $reference->[0];
2525
2526
$reference->[3] = time; # last access time
2527
return $reference->[0]; # reference to actual object
2528
}
2529
2530
sub objects {
2531
my $self = shift;
2532
return @_ unless %alive; # small optimization
2533
return map {
2534
ref($_) && exists $alive{ref $_} && exists $_->{id}
2535
? $self->object($_)
2536
: $_
2537
} @_;
2538
}
2539
2540
# ======================================================================
2541
2542
package SOAP::Server::Parameters;
2543
2544
sub byNameOrOrder {
2545
unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
2546
warn "Last parameter is expected to be envelope\n" if $^W;
2547
pop;
2548
return @_;
2549
}
2550
my $params = pop->method;
2551
my @mandatory = ref $_[0] eq 'ARRAY'
2552
? @{shift()}
2553
: die "list of parameters expected as the first parameter for byName";
2554
my $byname = 0;
2555
my @res = map { $byname += exists $params->{$_}; $params->{$_} } @mandatory;
2556
return $byname
2557
? @res
2558
: @_;
2559
}
2560
2561
sub byName {
2562
unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
2563
warn "Last parameter is expected to be envelope\n" if $^W;
2564
pop;
2565
return @_;
2566
}
2567
return @{pop->method}{ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName"};
2568
}
2569
2570
# ======================================================================
2571
2572
package SOAP::Server;
2573
2574
use Carp ();
2575
use Scalar::Util qw(weaken);
2576
sub DESTROY { SOAP::Trace::objects('()') }
2577
2578
sub initialize {
2579
return (
2580
packager => SOAP::Packager::MIME->new,
2581
transport => SOAP::Transport->new,
2582
serializer => SOAP::Serializer->new,
2583
deserializer => SOAP::Deserializer->new,
2584
on_action => sub { ; },
2585
on_dispatch => sub {
2586
return;
2587
},
2588
);
2589
}
2590
2591
sub new {
2592
my $self = shift;
2593
return $self if ref $self;
2594
2595
unless (ref $self) {
2596
my $class = $self;
2597
my(@params, @methods);
2598
2599
while (@_) {
2600
my($method, $params) = splice(@_,0,2);
2601
$class->can($method)
2602
? push(@methods, $method, $params)
2603
: $^W && Carp::carp "Unrecognized parameter '$method' in new()";
2604
}
2605
2606
$self = bless {
2607
_dispatch_to => [],
2608
_dispatch_with => {},
2609
_dispatched => [],
2610
_action => '',
2611
_options => {},
2612
} => $class;
2613
unshift(@methods, $self->initialize);
2614
no strict qw(refs);
2615
while (@methods) {
2616
my($method, $params) = splice(@methods,0,2);
2617
$self->$method(ref $params eq 'ARRAY' ? @$params : $params)
2618
}
2619
SOAP::Trace::objects('()');
2620
}
2621
2622
Carp::carp "Odd (wrong?) number of parameters in new()"
2623
if $^W && (@_ & 1);
2624
2625
no strict qw(refs);
2626
while (@_) {
2627
my($method, $params) = splice(@_,0,2);
2628
$self->can($method)
2629
? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
2630
: $^W && Carp::carp "Unrecognized parameter '$method' in new()"
2631
}
2632
2633
return $self;
2634
}
2635
2636
sub init_context {
2637
my $self = shift;
2638
$self->{'_deserializer'}->{'_context'} = $self;
2639
# weaken circular reference to avoid a memory hole
2640
weaken($self->{'_deserializer'}->{'_context'});
2641
2642
$self->{'_serializer'}->{'_context'} = $self;
2643
# weaken circular reference to avoid a memory hole
2644
weaken($self->{'_serializer'}->{'_context'});
2645
}
2646
2647
sub BEGIN {
2648
no strict 'refs';
2649
for my $method (qw(serializer deserializer transport)) {
2650
my $field = '_' . $method;
2651
*$method = sub {
2652
my $self = shift->new();
2653
if (@_) {
2654
my $context = $self->{$field}->{'_context'}; # save the old context
2655
$self->{$field} = shift;
2656
$self->{$field}->{'_context'} = $context; # restore the old context
2657
return $self;
2658
}
2659
else {
2660
return $self->{$field};
2661
}
2662
}
2663
}
2664
2665
for my $method (qw(action myuri options dispatch_with packager)) {
2666
my $field = '_' . $method;
2667
*$method = sub {
2668
my $self = shift->new();
2669
(@_)
2670
? do {
2671
$self->{$field} = shift;
2672
return $self;
2673
}
2674
: return $self->{$field};
2675
}
2676
}
2677
for my $method (qw(on_action on_dispatch)) {
2678
my $field = '_' . $method;
2679
*$method = sub {
2680
my $self = shift->new;
2681
# my $self = shift;
2682
return $self->{$field} unless @_;
2683
local $@;
2684
# commented out because that 'eval' was unsecure
2685
# > ref $_[0] eq 'CODE' ? shift : eval shift;
2686
# Am I paranoid enough?
2687
$self->{$field} = shift;
2688
Carp::croak $@ if $@;
2689
Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)"
2690
unless ref $self->{$field} eq 'CODE';
2691
return $self;
2692
}
2693
}
2694
2695
# __PACKAGE__->__mk_accessors( qw(dispatch_to) );
2696
for my $method (qw(dispatch_to)) {
2697
my $field = '_' . $method;
2698
*$method = sub {
2699
my $self = shift->new;
2700
# my $self = shift;
2701
(@_)
2702
? do {
2703
$self->{$field} = [@_];
2704
return $self;
2705
}
2706
: return @{ $self->{$field} };
2707
}
2708
}
2709
}
2710
2711
sub objects_by_reference {
2712
my $self = shift;
2713
$self = $self->new() if not ref $self;
2714
@_
2715
? (SOAP::Server::Object->objects_by_reference(@_), return $self)
2716
: SOAP::Server::Object->objects_by_reference;
2717
}
2718
2719
sub dispatched {
2720
my $self = shift;
2721
$self = $self->new() if not ref $self;
2722
@_
2723
? (push(@{$self->{_dispatched}}, @_), return $self)
2724
: return @{$self->{_dispatched}};
2725
}
2726
2727
sub find_target {
2728
my $self = shift;
2729
my $request = shift;
2730
2731
# try to find URI/method from on_dispatch call first
2732
my($method_uri, $method_name) = $self->on_dispatch->($request);
2733
2734
# if nothing there, then get it from envelope itself
2735
$request->match((ref $request)->method);
2736
($method_uri, $method_name) = ($request->namespaceuriof || '', $request->dataof->name)
2737
unless $method_name;
2738
2739
$self->on_action->(my $action = $self->action, $method_uri, $method_name);
2740
2741
# check to avoid security vulnerability: Protected->Unprotected::method(@parameters)
2742
# see for more details: http://www.phrack.org/phrack/58/p58-0x09
2743
die "Denied access to method ($method_name)\n" unless $method_name =~ /^\w+$/;
2744
2745
my ($class, $static);
2746
# try to bind directly
2747
if (defined($class = $self->dispatch_with->{$method_uri}
2748
|| $self->dispatch_with->{$action || ''}
2749
|| (defined($action) && $action =~ /^"(.+)"$/
2750
? $self->dispatch_with->{$1}
2751
: undef))) {
2752
# return object, nothing else to do here
2753
return ($class, $method_uri, $method_name) if ref $class;
2754
$static = 1;
2755
}
2756
else {
2757
die "URI path shall map to class" unless defined ($class = URI->new($method_uri)->path);
2758
2759
for ($class) { s!^/|/$!!g; s!/!::!g; s/^$/main/; }
2760
die "Failed to access class ($class)" unless $class =~ /^(\w[\w:]*)$/;
2761
2762
my $fullname = "$class\::$method_name";
2763
foreach ($self->dispatch_to) {
2764
return ($_, $method_uri, $method_name) if ref eq $class; # $OBJECT
2765
next if ref; # skip other objects
2766
# will ignore errors, because it may complain on
2767
# d:\foo\bar, which is PATH and not regexp
2768
eval {
2769
$static ||= $class =~ /^$_$/ # MODULE
2770
|| $fullname =~ /^$_$/ # MODULE::method
2771
|| $method_name =~ /^$_$/ && ($class eq 'main'); # method ('main' assumed)
2772
};
2773
}
2774
}
2775
2776
no strict 'refs';
2777
2778
# TODO - sort this mess out:
2779
# The task is to test whether the class in question has already been loaded.
2780
#
2781
# SOAP::Lite 0.60:
2782
# unless (defined %{"${class}::"}) {
2783
# Patch to SOAP::Lite 0.60:
2784
# The following patch does not work for packages defined within a BEGIN block
2785
# unless (exists($INC{join '/', split /::/, $class.'.pm'})) {
2786
# Combination of 0.60 and patch did not work reliably, either.
2787
#
2788
# Now we do the following: Check whether the class is main (always loaded)
2789
# or the class implements the method in question
2790
# or the package exists as file in %INC.
2791
#
2792
# This is still sort of a hack - but I don't know anything better
2793
# If you have some idea, please help me out...
2794
#
2795
unless (($class eq 'main') || $class->can($method_name)
2796
|| exists($INC{join '/', split /::/, $class . '.pm'})) {
2797
2798
# allow all for static and only specified path for dynamic bindings
2799
local @INC = (($static ? @INC : ()), grep {!ref && m![/\\.]!} $self->dispatch_to());
2800
eval 'local $^W; ' . "require $class";
2801
die "Failed to access class ($class): $@" if $@;
2802
$self->dispatched($class) unless $static;
2803
}
2804
2805
die "Denied access to method ($method_name) in class ($class)"
2806
unless $static || grep {/^$class$/} $self->dispatched;
2807
2808
return ($class, $method_uri, $method_name);
2809
}
2810
2811
sub handle {
2812
SOAP::Trace::trace('()');
2813
my $self = shift;
2814
$self = $self->new if !ref $self; # inits the server when called in a static context
2815
$self->init_context();
2816
# we want to restore it when we are done
2817
local $SOAP::Constants::DEFAULT_XML_SCHEMA
2818
= $SOAP::Constants::DEFAULT_XML_SCHEMA;
2819
2820
# SOAP version WILL NOT be restored when we are done.
2821
# is it problem?
2822
2823
my $result = eval {
2824
local $SIG{__DIE__};
2825
# why is this here:
2826
$self->serializer->soapversion(1.1);
2827
my $request = eval { $self->deserializer->deserialize($_[0]) };
2828
2829
die SOAP::Fault
2830
->faultcode($SOAP::Constants::FAULT_VERSION_MISMATCH)
2831
->faultstring($@)
2832
if $@ && $@ =~ /^$SOAP::Constants::WRONG_VERSION/;
2833
2834
die "Application failed during request deserialization: $@" if $@;
2835
my $som = ref $request;
2836
die "Can't find root element in the message"
2837
unless $request->match($som->envelope);
2838
$self->serializer->soapversion(SOAP::Lite->soapversion);
2839
$self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA
2840
= $self->deserializer->xmlschema)
2841
if $self->deserializer->xmlschema;
2842
2843
die SOAP::Fault
2844
->faultcode($SOAP::Constants::FAULT_MUST_UNDERSTAND)
2845
->faultstring("Unrecognized header has mustUnderstand attribute set to 'true'")
2846
if !$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND &&
2847
grep {
2848
$_->mustUnderstand
2849
&& (!$_->actor || $_->actor eq $SOAP::Constants::NEXT_ACTOR)
2850
} $request->dataof($som->headers);
2851
2852
die "Can't find method element in the message"
2853
unless $request->match($som->method);
2854
# TODO - SOAP::Dispatcher plugs in here
2855
# my $handler = $self->dispatcher->find_handler($request);
2856
my($class, $method_uri, $method_name) = $self->find_target($request);
2857
my @results = eval {
2858
local $^W;
2859
my @parameters = $request->paramsin;
2860
2861
# SOAP::Trace::dispatch($fullname);
2862
SOAP::Trace::parameters(@parameters);
2863
2864
push @parameters, $request
2865
if UNIVERSAL::isa($class => 'SOAP::Server::Parameters');
2866
2867
no strict qw(refs);
2868
SOAP::Server::Object->references(
2869
defined $parameters[0]
2870
&& ref $parameters[0]
2871
&& UNIVERSAL::isa($parameters[0] => $class)
2872
? do {
2873
my $object = shift @parameters;
2874
SOAP::Server::Object->object(ref $class
2875
? $class
2876
: $object
2877
)->$method_name(SOAP::Server::Object->objects(@parameters)),
2878
2879
# send object back as a header
2880
# preserve name, specify URI
2881
SOAP::Header
2882
->uri($SOAP::Constants::NS_SL_HEADER => $object)
2883
->name($request->dataof($som->method.'/[1]')->name)
2884
} # end do block
2885
2886
# SOAP::Dispatcher will plug-in here as well
2887
# $handler->dispatch(SOAP::Server::Object->objects(@parameters)
2888
: $class->$method_name(SOAP::Server::Object->objects(@parameters)) );
2889
}; # end eval block
2890
SOAP::Trace::result(@results);
2891
2892
# let application errors pass through with 'Server' code
2893
die ref $@
2894
? $@
2895
: $@ =~ /^Can\'t locate object method "$method_name"/
2896
? "Failed to locate method ($method_name) in class ($class)"
2897
: SOAP::Fault->faultcode($SOAP::Constants::FAULT_SERVER)->faultstring($@)
2898
if $@;
2899
2900
my $result = $self->serializer
2901
->prefix('s') # distinguish generated element names between client and server
2902
->uri($method_uri)
2903
->envelope(response => $method_name . 'Response', @results);
2904
return $result;
2905
};
2906
2907
# void context
2908
return unless defined wantarray;
2909
2910
# normal result
2911
return $result unless $@;
2912
2913
# check fails, something wrong with message
2914
return $self->make_fault($SOAP::Constants::FAULT_CLIENT, $@) unless ref $@;
2915
2916
# died with SOAP::Fault
2917
return $self->make_fault($@->faultcode || $SOAP::Constants::FAULT_SERVER,
2918
$@->faultstring || 'Application error',
2919
$@->faultdetail, $@->faultactor)
2920
if UNIVERSAL::isa($@ => 'SOAP::Fault');
2921
2922
# died with complex detail
2923
return $self->make_fault($SOAP::Constants::FAULT_SERVER, 'Application error' => $@);
2924
2925
} # end of handle()
2926
2927
sub make_fault {
2928
my $self = shift;
2929
my($code, $string, $detail, $actor) = @_;
2930
$self->serializer->fault($code, $string, $detail, $actor || $self->myuri);
2931
}
2932
2933
# ======================================================================
2934
2935
package SOAP::Trace;
2936
2937
use Carp ();
2938
2939
my @list = qw(
2940
transport dispatch result
2941
parameters headers objects
2942
method fault freeform
2943
trace debug);
2944
{
2945
no strict 'refs';
2946
for (@list) {
2947
*$_ = sub {}
2948
}
2949
}
2950
2951
sub defaultlog {
2952
my $caller = (caller(1))[3]; # the 4th element returned by caller is the subroutine namea
2953
$caller = (caller(2))[3] if $caller =~ /eval/;
2954
chomp(my $msg = join ' ', @_);
2955
printf STDERR "%s: %s\n", $caller, $msg;
2956
}
2957
2958
sub import {
2959
no strict 'refs';
2960
local $^W;
2961
my $pack = shift;
2962
my(@notrace, @symbols);
2963
for (@_) {
2964
if (ref eq 'CODE') {
2965
my $call = $_;
2966
foreach (@symbols) { *$_ = sub { $call->(@_) } }
2967
@symbols = ();
2968
}
2969
else {
2970
local $_ = $_;
2971
my $minus = s/^-//;
2972
my $all = $_ eq 'all';
2973
Carp::carp "Illegal symbol for tracing ($_)" unless $all || $pack->can($_);
2974
$minus ? push(@notrace, $all ? @list : $_) : push(@symbols, $all ? @list : $_);
2975
}
2976
}
2977
# TODO - I am getting a warning here about redefining a subroutine
2978
foreach (@symbols) { *$_ = \&defaultlog }
2979
foreach (@notrace) { *$_ = sub {} }
2980
}
2981
2982
# ======================================================================
2983
2984
package SOAP::Custom::XML::Data;
2985
2986
use vars qw(@ISA $AUTOLOAD);
2987
@ISA = qw(SOAP::Data);
2988
2989
use overload fallback => 1, '""' => sub { shift->value };
2990
2991
sub _compileit {
2992
no strict 'refs';
2993
my $method = shift;
2994
*$method = sub {
2995
return __PACKAGE__->SUPER::name($method => $_[0]->attr->{$method})
2996
if exists $_[0]->attr->{$method};
2997
my @elems = grep {
2998
ref $_ && UNIVERSAL::isa($_ => __PACKAGE__)
2999
&& $_->SUPER::name =~ /(^|:)$method$/
3000
} $_[0]->value;
3001
return wantarray? @elems : $elems[0];
3002
};
3003
}
3004
3005
sub BEGIN { foreach (qw(name type import use)) { _compileit($_) } }
3006
3007
sub AUTOLOAD {
3008
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
3009
return if $method eq 'DESTROY';
3010
3011
_compileit($method);
3012
goto &$AUTOLOAD;
3013
}
3014
3015
# ======================================================================
3016
3017
package SOAP::Custom::XML::Deserializer;
3018
3019
use vars qw(@ISA);
3020
@ISA = qw(SOAP::Deserializer);
3021
3022
sub decode_value {
3023
my $self = shift;
3024
my $ref = shift;
3025
my($name, $attrs, $children, $value) = @$ref;
3026
# base class knows what to do with it
3027
return $self->SUPER::decode_value($ref) if exists $attrs->{href};
3028
3029
SOAP::Custom::XML::Data
3030
-> SOAP::Data::name($name)
3031
-> attr($attrs)
3032
-> set_value(ref $children && @$children
3033
? map(scalar(($self->decode_object($_))[1]), @$children)
3034
: $value);
3035
}
3036
3037
# ======================================================================
3038
3039
package SOAP::Schema::Deserializer;
3040
3041
use vars qw(@ISA);
3042
@ISA = qw(SOAP::Custom::XML::Deserializer);
3043
3044
# ======================================================================
3045
3046
package SOAP::Schema::WSDL;
3047
3048
use vars qw(%imported @ISA);
3049
@ISA = qw(SOAP::Schema);
3050
3051
sub new {
3052
my $self = shift;
3053
3054
unless (ref $self) {
3055
my $class = $self;
3056
$self = $class->SUPER::new(@_);
3057
}
3058
return $self;
3059
}
3060
3061
sub base {
3062
my $self = shift->new;
3063
@_
3064
? ($self->{_base} = shift, return $self)
3065
: return $self->{_base};
3066
}
3067
3068
sub import {
3069
my $self = shift->new;
3070
my $s = shift;
3071
my $base = shift || $self->base || die "Missing base argument for ", __PACKAGE__, "\n";
3072
3073
my @a = $s->import;
3074
local %imported = %imported;
3075
foreach (@a) {
3076
next unless $_->location;
3077
my $location = URI->new_abs($_->location->value, $base)->as_string;
3078
if ($imported{$location}++) {
3079
warn "Recursion loop detected in service description from '$location'. Ignored\n" if $^W;
3080
return $s;
3081
}
3082
my $root = $self->import(
3083
$self->deserializer->deserialize(
3084
$self->access($location)
3085
)->root, $location);
3086
3087
$root->SOAP::Data::name eq 'definitions' ? $s->set_value($s->value, $root->value) :
3088
$root->SOAP::Data::name eq 'schema' ? do { # add <types> element if there is no one
3089
$s->set_value($s->value, $self->deserializer->deserialize('<types></types>')->root) unless $s->types;
3090
$s->types->set_value($s->types->value, $root) } :
3091
die "Don't know what to do with '@{[$root->SOAP::Data::name]}' in schema imported from '$location'\n";
3092
}
3093
3094
# return the parsed WSDL file
3095
$s;
3096
}
3097
3098
# TODO - This is woefully incomplete!
3099
sub parse_schema_element {
3100
my $element = shift;
3101
# Current element is a complex type
3102
if (defined($element->complexType)) {
3103
my @elements = ();
3104
if (defined($element->complexType->sequence)) {
3105
3106
foreach my $e ($element->complexType->sequence->element) {
3107
push @elements,parse_schema_element($e);
3108
}
3109
}
3110
return @elements;
3111
}
3112
elsif ($element->simpleType) {
3113
}
3114
else {
3115
return $element;
3116
}
3117
}
3118
3119
sub parse {
3120
my $self = shift->new;
3121
my($s, $service, $port) = @_;
3122
my @result;
3123
3124
# handle imports
3125
$self->import($s);
3126
3127
# handle descriptions without <service>, aka tModel-type descriptions
3128
my @services = $s->service;
3129
my $tns = $s->{'_attr'}->{'targetNamespace'};
3130
# if there is no <service> element we'll provide it
3131
@services = $self->deserializer->deserialize(<<"FAKE")->root->service unless @services;
3132
<definitions>
3133
<service name="@{[$service || 'FakeService']}">
3134
<port name="@{[$port || 'FakePort']}" binding="@{[$s->binding->name]}"/>
3135
</service>
3136
</definitions>
3137
FAKE
3138
3139
my $has_warned = 0;
3140
foreach (@services) {
3141
my $name = $_->name;
3142
next if $service && $service ne $name;
3143
my %services;
3144
foreach ($_->port) {
3145
next if $port && $port ne $_->name;
3146
my $binding = SOAP::Utils::disqualify($_->binding);
3147
my $endpoint = ref $_->address ? $_->address->location : undef;
3148
foreach ($s->binding) {
3149
# is this a SOAP binding?
3150
next unless grep { $_->uri eq 'http://schemas.xmlsoap.org/wsdl/soap/' } $_->binding;
3151
next unless $_->name eq $binding;
3152
my $default_style = $_->binding->style;
3153
my $porttype = SOAP::Utils::disqualify($_->type);
3154
foreach ($_->operation) {
3155
my $opername = $_->name;
3156
$services{$opername} = {}; # should be initialized in 5.7 and after
3157
my $soapaction = $_->operation->soapAction;
3158
my $invocationStyle = $_->operation->style || $default_style || "rpc";
3159
my $encodingStyle = $_->input->body->use || "encoded";
3160
my $namespace = $_->input->body->namespace || $tns;
3161
my @parts;
3162
foreach ($s->portType) {
3163
next unless $_->name eq $porttype;
3164
foreach ($_->operation) {
3165
next unless $_->name eq $opername;
3166
my $inputmessage = SOAP::Utils::disqualify($_->input->message);
3167
foreach my $msg ($s->message) {
3168
next unless $msg->name eq $inputmessage;
3169
if ($invocationStyle eq "document" && $encodingStyle eq "literal") {
3170
# warn "document/literal support is EXPERIMENTAL in SOAP::Lite"
3171
# if !$has_warned && ($has_warned = 1);
3172
my ($input_ns,$input_name) = SOAP::Utils::splitqname($msg->part->element);
3173
foreach my $schema ($s->types->schema) {
3174
foreach my $element ($schema->element) {
3175
next unless $element->name eq $input_name;
3176
push @parts,parse_schema_element($element);
3177
}
3178
$services{$opername}->{parameters} = [ @parts ];
3179
}
3180
}
3181
else {
3182
# TODO - support all combinations of doc|rpc/lit|enc.
3183
#warn "$invocationStyle/$encodingStyle is not supported in this version of SOAP::Lite";
3184
@parts = $msg->part;
3185
$services{$opername}->{parameters} = [ @parts ];
3186
}
3187
}
3188
}
3189
3190
for ($services{$opername}) {
3191
$_->{endpoint} = $endpoint;
3192
$_->{soapaction} = $soapaction;
3193
$_->{namespace} = $namespace;
3194
# $_->{parameters} = [@parts];
3195
}
3196
}
3197
}
3198
}
3199
}
3200
# fix nonallowed characters in package name, and add 's' if started with digit
3201
for ($name) { s/\W+/_/g; s/^(\d)/s$1/ }
3202
push @result, $name => \%services;
3203
}
3204
return @result;
3205
}
3206
3207
# ======================================================================
3208
3209
# Naming? SOAP::Service::Schema?
3210
package SOAP::Schema;
3211
3212
use Carp ();
3213
3214
sub DESTROY { SOAP::Trace::objects('()') }
3215
3216
sub new {
3217
my $self = shift;
3218
return $self if ref $self;
3219
unless (ref $self) {
3220
my $class = $self;
3221
require LWP::UserAgent;
3222
$self = bless {
3223
'_deserializer' => SOAP::Schema::Deserializer->new,
3224
'_useragent' => LWP::UserAgent->new,
3225
}, $class;
3226
3227
SOAP::Trace::objects('()');
3228
}
3229
3230
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
3231
no strict qw(refs);
3232
while (@_) {
3233
my $method = shift;
3234
$self->$method(shift) if $self->can($method)
3235
}
3236
3237
return $self;
3238
}
3239
3240
sub schema {
3241
warn "SOAP::Schema->schema has been deprecated. "
3242
. "Please use SOAP::Schema->schema_url instead.";
3243
return shift->schema_url(@_);
3244
}
3245
3246
sub BEGIN {
3247
no strict 'refs';
3248
for my $method (qw(deserializer schema_url services useragent stub cache_dir cache_ttl)) {
3249
my $field = '_' . $method;
3250
*$method = sub {
3251
my $self = shift->new;
3252
@_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
3253
}
3254
}
3255
}
3256
3257
sub parse {
3258
my $self = shift;
3259
my $s = $self->deserializer->deserialize($self->access)->root;
3260
# here should be something that defines what schema description we want to use
3261
$self->services({SOAP::Schema::WSDL->base($self->schema_url)->parse($s, @_)});
3262
}
3263
3264
sub refresh_cache {
3265
my $self = shift;
3266
my ($filename,$contents) = @_;
3267
open CACHE,">$filename" or Carp::croak "Could not open cache file for writing: $!";
3268
print CACHE $contents;
3269
close CACHE;
3270
}
3271
3272
sub load {
3273
my $self = shift->new;
3274
local $^W; # supress warnings about redefining
3275
foreach (keys %{$self->services || Carp::croak 'Nothing to load. Schema is not specified'}) {
3276
# TODO - check age of cached file, and delete if older than configured amount
3277
if ($self->cache_dir) {
3278
my $cached_file = File::Spec->catfile($self->cache_dir,$_.".pm");
3279
my $ttl = $self->cache_ttl || $SOAP::Constants::DEFAULT_CACHE_TTL;
3280
open (CACHE, "<$cached_file");
3281
my @stat = stat($cached_file) unless eof(CACHE);
3282
close CACHE;
3283
if (@stat) {
3284
# Cache exists
3285
my $cache_lived = time() - $stat[9];
3286
if ($ttl > 0 && $cache_lived > $ttl) {
3287
$self->refresh_cache($cached_file,$self->generate_stub($_));
3288
}
3289
}
3290
else {
3291
# Cache doesn't exist
3292
$self->refresh_cache($cached_file,$self->generate_stub($_));
3293
}
3294
push @INC,$self->cache_dir;
3295
eval "require $_" or Carp::croak "Could not load cached file: $@";
3296
}
3297
else {
3298
eval $self->generate_stub($_) or Carp::croak "Bad stub: $@";
3299
}
3300
}
3301
$self;
3302
}
3303
3304
sub access {
3305
my $self = shift->new;
3306
my $url = shift || $self->schema_url || Carp::croak 'Nothing to access. URL is not specified';
3307
$self->useragent->env_proxy if $ENV{'HTTP_proxy'};
3308
3309
my $req = HTTP::Request->new(GET => $url);
3310
$req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'})
3311
if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'});
3312
3313
my $resp = $self->useragent->request($req);
3314
$resp->is_success ? $resp->content : die "Service description '$url' can't be loaded: ", $resp->status_line, "\n";
3315
}
3316
3317
sub generate_stub {
3318
my $self = shift->new;
3319
my $package = shift;
3320
my $services = $self->services->{$package};
3321
my $schema_url = $self->schema_url;
3322
3323
$self->{'_stub'} = <<"EOP";
3324
package $package;
3325
# Generated by SOAP::Lite (v$SOAP::Lite::VERSION) for Perl -- soaplite.com
3326
# Copyright (C) 2000-2006 Paul Kulchenko, Byrne Reese
3327
# -- generated at [@{[scalar localtime]}]
3328
EOP
3329
$self->{'_stub'} .= "# -- generated from $schema_url\n" if $schema_url;
3330
$self->{'_stub'} .= 'my %methods = ('."\n";
3331
foreach my $service (keys %$services) {
3332
$self->{'_stub'} .= "'$service' => {\n";
3333
foreach (qw(endpoint soapaction namespace)) {
3334
$self->{'_stub'} .= " $_ => '".$services->{$service}{$_}."',\n";
3335
}
3336
$self->{'_stub'} .= " parameters => [\n";
3337
foreach (@{$services->{$service}{parameters}}) {
3338
# This is a workaround for https://sourceforge.net/tracker/index.php?func=detail&aid=2001592&group_id=66000&atid=513017
3339
next unless ref $_;
3340
$self->{'_stub'} .= " SOAP::Data->new(name => '".$_->name."', type => '".$_->type."', attr => {";
3341
$self->{'_stub'} .= do {
3342
my %attr = %{$_->attr};
3343
join(', ', map {"'$_' => '$attr{$_}'"}
3344
grep {/^xmlns:(?!-)/}
3345
keys %attr);
3346
};
3347
$self->{'_stub'} .= "}),\n";
3348
}
3349
$self->{'_stub'} .= " ], # end parameters\n";
3350
$self->{'_stub'} .= " }, # end $service\n";
3351
}
3352
$self->{'_stub'} .= "); # end my %methods\n";
3353
$self->{'_stub'} .= <<'EOP';
3354
3355
use SOAP::Lite;
3356
use Exporter;
3357
use Carp ();
3358
3359
use vars qw(@ISA $AUTOLOAD @EXPORT_OK %EXPORT_TAGS);
3360
@ISA = qw(Exporter SOAP::Lite);
3361
@EXPORT_OK = (keys %methods);
3362
%EXPORT_TAGS = ('all' => [@EXPORT_OK]);
3363
3364
sub _call {
3365
my ($self, $method) = (shift, shift);
3366
my $name = UNIVERSAL::isa($method => 'SOAP::Data') ? $method->name : $method;
3367
my %method = %{$methods{$name}};
3368
$self->proxy($method{endpoint} || Carp::croak "No server address (proxy) specified")
3369
unless $self->proxy;
3370
my @templates = @{$method{parameters}};
3371
my @parameters = ();
3372
foreach my $param (@_) {
3373
if (@templates) {
3374
my $template = shift @templates;
3375
my ($prefix,$typename) = SOAP::Utils::splitqname($template->type);
3376
my $method = 'as_'.$typename;
3377
# TODO - if can('as_'.$typename) {...}
3378
my $result = $self->serializer->$method($param, $template->name, $template->type, $template->attr);
3379
push(@parameters, $template->value($result->[2]));
3380
}
3381
else {
3382
push(@parameters, $param);
3383
}
3384
}
3385
$self->endpoint($method{endpoint})
3386
->ns($method{namespace})
3387
->on_action(sub{qq!"$method{soapaction}"!});
3388
EOP
3389
my $namespaces = $self->deserializer->ids->[1];
3390
foreach my $key (keys %{$namespaces}) {
3391
my ($ns,$prefix) = SOAP::Utils::splitqname($key);
3392
$self->{'_stub'} .= ' $self->serializer->register_ns("'.$namespaces->{$key}.'","'.$prefix.'");'."\n"
3393
if ($ns eq "xmlns");
3394
}
3395
$self->{'_stub'} .= <<'EOP';
3396
my $som = $self->SUPER::call($method => @parameters);
3397
if ($self->want_som) {
3398
return $som;
3399
}
3400
UNIVERSAL::isa($som => 'SOAP::SOM') ? wantarray ? $som->paramsall : $som->result : $som;
3401
}
3402
3403
sub BEGIN {
3404
no strict 'refs';
3405
for my $method (qw(want_som)) {
3406
my $field = '_' . $method;
3407
*$method = sub {
3408
my $self = shift->new;
3409
@_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
3410
}
3411
}
3412
}
3413
no strict 'refs';
3414
for my $method (@EXPORT_OK) {
3415
my %method = %{$methods{$method}};
3416
*$method = sub {
3417
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
3418
? ref $_[0]
3419
? shift # OBJECT
3420
# CLASS, either get self or create new and assign to self
3421
: (shift->self || __PACKAGE__->self(__PACKAGE__->new))
3422
# function call, either get self or create new and assign to self
3423
: (__PACKAGE__->self || __PACKAGE__->self(__PACKAGE__->new));
3424
$self->_call($method, @_);
3425
}
3426
}
3427
3428
sub AUTOLOAD {
3429
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
3430
return if $method eq 'DESTROY' || $method eq 'want_som';
3431
die "Unrecognized method '$method'. List of available method(s): @EXPORT_OK\n";
3432
}
3433
3434
1;
3435
EOP
3436
return $self->stub;
3437
}
3438
3439
# ======================================================================
3440
3441
package SOAP;
3442
3443
use vars qw($AUTOLOAD);
3444
require URI;
3445
3446
my $soap; # shared between SOAP and SOAP::Lite packages
3447
3448
{
3449
no strict 'refs';
3450
*AUTOLOAD = sub {
3451
local($1,$2);
3452
my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
3453
return if $method eq 'DESTROY';
3454
3455
my $soap = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite')
3456
? $_[0]
3457
: $soap
3458
|| die "SOAP:: prefix shall only be used in combination with +autodispatch option\n";
3459
3460
my $uri = URI->new($soap->uri);
3461
my $currenturi = $uri->path;
3462
$package = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite')
3463
? $currenturi
3464
: $package eq 'SOAP'
3465
? ref $_[0] || ($_[0] eq 'SOAP'
3466
? $currenturi || Carp::croak "URI is not specified for method call"
3467
: $_[0])
3468
: $package eq 'main'
3469
? $currenturi || $package
3470
: $package;
3471
3472
# drop first parameter if it's a class name
3473
{
3474
my $pack = $package;
3475
for ($pack) { s!^/!!; s!/!::!g; }
3476
shift @_ if @_ && !ref $_[0] && ($_[0] eq $pack || $_[0] eq 'SOAP')
3477
|| ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite');
3478
}
3479
3480
for ($package) { s!::!/!g; s!^/?!/!; }
3481
$uri->path($package);
3482
3483
my $som = $soap->uri($uri->as_string)->call($method => @_);
3484
UNIVERSAL::isa($som => 'SOAP::SOM')
3485
? wantarray
3486
? $som->paramsall
3487
: $som->result
3488
: $som;
3489
};
3490
}
3491
3492
# ======================================================================
3493
3494
package SOAP::Lite;
3495
3496
use vars qw($AUTOLOAD @ISA);
3497
use Carp ();
3498
3499
use SOAP::Lite::Utils;
3500
use SOAP::Constants;
3501
use SOAP::Packager;
3502
3503
use Scalar::Util qw(weaken blessed);
3504
3505
@ISA = qw(SOAP::Cloneable);
3506
3507
# provide access to global/autodispatched object
3508
sub self {
3509
@_ > 1
3510
? $soap = $_[1]
3511
: $soap
3512
}
3513
3514
# no more warnings about "used only once"
3515
*UNIVERSAL::AUTOLOAD if 0;
3516
3517
sub autodispatched { \&{*UNIVERSAL::AUTOLOAD} eq \&{*SOAP::AUTOLOAD} };
3518
3519
sub soapversion {
3520
my $self = shift;
3521
my $version = shift or return $SOAP::Constants::SOAP_VERSION;
3522
3523
($version) = grep {
3524
$SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV} eq $version
3525
} keys %SOAP::Constants::SOAP_VERSIONS
3526
unless exists $SOAP::Constants::SOAP_VERSIONS{$version};
3527
3528
die qq!$SOAP::Constants::WRONG_VERSION Supported versions:\n@{[
3529
join "\n", map {" $_ ($SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV})"} keys %SOAP::Constants::SOAP_VERSIONS
3530
]}\n!
3531
unless defined($version) && defined(my $def = $SOAP::Constants::SOAP_VERSIONS{$version});
3532
3533
foreach (keys %$def) {
3534
eval "\$SOAP::Constants::$_ = '$SOAP::Constants::SOAP_VERSIONS{$version}->{$_}'";
3535
}
3536
3537
$SOAP::Constants::SOAP_VERSION = $version;
3538
3539
return $self;
3540
}
3541
3542
BEGIN { SOAP::Lite->soapversion(1.1) }
3543
3544
sub import {
3545
my $pkg = shift;
3546
my $caller = caller;
3547
no strict 'refs';
3548
# emulate 'use SOAP::Lite 0.99' behavior
3549
$pkg->require_version(shift) if defined $_[0] && $_[0] =~ /^\d/;
3550
3551
while (@_) {
3552
my $command = shift;
3553
3554
my @parameters = UNIVERSAL::isa($_[0] => 'ARRAY')
3555
? @{shift()}
3556
: shift
3557
if @_ && $command ne 'autodispatch';
3558
3559
if ($command eq 'autodispatch' || $command eq 'dispatch_from') {
3560
$soap = ($soap||$pkg)->new;
3561
no strict 'refs';
3562
foreach ($command eq 'autodispatch'
3563
? 'UNIVERSAL'
3564
: @parameters
3565
) {
3566
my $sub = "${_}::AUTOLOAD";
3567
defined &{*$sub}
3568
? (\&{*$sub} eq \&{*SOAP::AUTOLOAD}
3569
? ()
3570
: Carp::croak "$sub already assigned and won't work with DISPATCH. Died")
3571
: (*$sub = *SOAP::AUTOLOAD);
3572
}
3573
}
3574
elsif ($command eq 'service') {
3575
foreach (keys %{SOAP::Schema->schema_url(shift(@parameters))->parse(@parameters)->load->services}) {
3576
$_->export_to_level(1, undef, ':all');
3577
}
3578
}
3579
elsif ($command eq 'debug' || $command eq 'trace') {
3580
SOAP::Trace->import(@parameters ? @parameters : 'all');
3581
}
3582
elsif ($command eq 'import') {
3583
local $^W; # supress warnings about redefining
3584
my $package = shift(@parameters);
3585
$package->export_to_level(1, undef, @parameters ? @parameters : ':all') if $package;
3586
}
3587
else {
3588
Carp::carp "Odd (wrong?) number of parameters in import(), still continue" if $^W && !(@parameters & 1);
3589
$soap = ($soap||$pkg)->$command(@parameters);
3590
}
3591
}
3592
}
3593
3594
sub DESTROY { SOAP::Trace::objects('()') }
3595
3596
sub new {
3597
my $self = shift;
3598
return $self if ref $self;
3599
unless (ref $self) {
3600
my $class = $self;
3601
# Check whether we can clone. Only the SAME class allowed, no inheritance
3602
$self = ref($soap) eq $class ? $soap->clone : {
3603
_transport => SOAP::Transport->new,
3604
_serializer => SOAP::Serializer->new,
3605
_deserializer => SOAP::Deserializer->new,
3606
_packager => SOAP::Packager::MIME->new,
3607
_schema => undef,
3608
_autoresult => 0,
3609
_on_action => sub { sprintf '"%s#%s"', shift || '', shift },
3610
_on_fault => sub {ref $_[1] ? return $_[1] : Carp::croak $_[0]->transport->is_success ? $_[1] : $_[0]->transport->status},
3611
};
3612
bless $self => $class;
3613
$self->on_nonserialized($self->on_nonserialized || $self->serializer->on_nonserialized);
3614
SOAP::Trace::objects('()');
3615
}
3616
3617
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
3618
no strict qw(refs);
3619
while (@_) {
3620
my($method, $params) = splice(@_,0,2);
3621
$self->can($method)
3622
? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
3623
: $^W && Carp::carp "Unrecognized parameter '$method' in new()"
3624
}
3625
3626
return $self;
3627
}
3628
3629
sub init_context {
3630
my $self = shift->new;
3631
$self->{'_deserializer'}->{'_context'} = $self;
3632
# weaken circular reference to avoid a memory hole
3633
weaken $self->{'_deserializer'}->{'_context'};
3634
3635
$self->{'_serializer'}->{'_context'} = $self;
3636
# weaken circular reference to avoid a memory hole
3637
weaken $self->{'_serializer'}->{'_context'};
3638
}
3639
3640
# Naming? wsdl_parser
3641
sub schema {
3642
my $self = shift;
3643
if (@_) {
3644
$self->{'_schema'} = shift;
3645
return $self;
3646
}
3647
else {
3648
if (!defined $self->{'_schema'}) {
3649
$self->{'_schema'} = SOAP::Schema->new;
3650
}
3651
return $self->{'_schema'};
3652
}
3653
}
3654
3655
sub BEGIN {
3656
no strict 'refs';
3657
for my $method (qw(serializer deserializer)) {
3658
my $field = '_' . $method;
3659
*$method = sub {
3660
my $self = shift->new;
3661
if (@_) {
3662
my $context = $self->{$field}->{'_context'}; # save the old context
3663
$self->{$field} = shift;
3664
$self->{$field}->{'_context'} = $context; # restore the old context
3665
return $self;
3666
}
3667
else {
3668
return $self->{$field};
3669
}
3670
}
3671
}
3672
3673
__PACKAGE__->__mk_accessors(
3674
qw(endpoint transport outputxml autoresult packager)
3675
);
3676
# for my $method () {
3677
# my $field = '_' . $method;
3678
# *$method = sub {
3679
# my $self = shift->new;
3680
# @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
3681
# }
3682
# }
3683
for my $method (qw(on_action on_fault on_nonserialized)) {
3684
my $field = '_' . $method;
3685
*$method = sub {
3686
my $self = shift->new;
3687
return $self->{$field} unless @_;
3688
local $@;
3689
# commented out because that 'eval' was unsecure
3690
# > ref $_[0] eq 'CODE' ? shift : eval shift;
3691
# Am I paranoid enough?
3692
$self->{$field} = shift;
3693
Carp::croak $@ if $@;
3694
Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)"
3695
unless ref $self->{$field} eq 'CODE';
3696
return $self;
3697
}
3698
}
3699
# SOAP::Transport Shortcuts
3700
# TODO - deprecate proxy() in favor of new language endpoint_url()
3701
no strict qw(refs);
3702
for my $method (qw(proxy)) {
3703
*$method = sub {
3704
my $self = shift->new;
3705
@_ ? ($self->transport->$method(@_), return $self) : return $self->transport->$method();
3706
}
3707
}
3708
3709
# SOAP::Seriailizer Shortcuts
3710
for my $method (qw(autotype readable envprefix encodingStyle
3711
encprefix multirefinplace encoding
3712
typelookup header maptype xmlschema
3713
uri ns_prefix ns_uri use_prefix use_default_ns
3714
ns default_ns)) {
3715
*$method = sub {
3716
my $self = shift->new;
3717
@_ ? ($self->serializer->$method(@_), return $self) : return $self->serializer->$method();
3718
}
3719
}
3720
3721
# SOAP::Schema Shortcuts
3722
for my $method (qw(cache_dir cache_ttl)) {
3723
*$method = sub {
3724
my $self = shift->new;
3725
@_ ? ($self->schema->$method(@_), return $self) : return $self->schema->$method();
3726
}
3727
}
3728
}
3729
3730
sub parts {
3731
my $self = shift;
3732
$self->packager->parts(@_);
3733
return $self;
3734
}
3735
3736
# Naming? wsdl
3737
sub service {
3738
my $self = shift->new;
3739
return $self->{'_service'} unless @_;
3740
$self->schema->schema_url($self->{'_service'} = shift);
3741
my %services = %{$self->schema->parse(@_)->load->services};
3742
3743
Carp::croak "More than one service in service description. Service and port names have to be specified\n"
3744
if keys %services > 1;
3745
my $service = (keys %services)[0]->new;
3746
return $service;
3747
}
3748
3749
sub AUTOLOAD {
3750
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
3751
return if $method eq 'DESTROY';
3752
3753
ref $_[0] or Carp::croak qq!Can\'t locate class method "$method" via package \"! . __PACKAGE__ .'\"';
3754
3755
no strict 'refs';
3756
*$AUTOLOAD = sub {
3757
my $self = shift;
3758
my $som = $self->call($method => @_);
3759
return $self->autoresult && UNIVERSAL::isa($som => 'SOAP::SOM')
3760
? wantarray ? $som->paramsall : $som->result
3761
: $som;
3762
};
3763
goto &$AUTOLOAD;
3764
}
3765
3766
sub call {
3767
SOAP::Trace::trace('()');
3768
my $self = shift;
3769
3770
die "A service address has not been specified either by using SOAP::Lite->proxy() or a service description)\n"
3771
unless defined $self->proxy && UNIVERSAL::isa($self->proxy => 'SOAP::Client');
3772
3773
$self->init_context();
3774
3775
my $serializer = $self->serializer;
3776
$serializer->on_nonserialized($self->on_nonserialized);
3777
3778
my $response = $self->transport->send_receive(
3779
context => $self, # this is provided for context
3780
endpoint => $self->endpoint,
3781
action => scalar($self->on_action->($serializer->uriformethod($_[0]))),
3782
# leave only parameters so we can later update them if required
3783
envelope => $serializer->envelope(method => shift, @_),
3784
encoding => $serializer->encoding,
3785
parts => @{$self->packager->parts} ? $self->packager->parts : undef,
3786
);
3787
3788
return $response if $self->outputxml;
3789
3790
my $result = eval { $self->deserializer->deserialize($response) }
3791
if $response;
3792
3793
if (!$self->transport->is_success || # transport fault
3794
$@ || # not deserializible
3795
# fault message even if transport OK
3796
# or no transport error (for example, fo TCP, POP3, IO implementations)
3797
UNIVERSAL::isa($result => 'SOAP::SOM') && $result->fault) {
3798
return ($self->on_fault->($self, $@
3799
? $@ . ($response || '')
3800
: $result)
3801
|| $result
3802
);
3803
# ? # trick editors
3804
}
3805
# this might be trouble for connection close...
3806
return unless $response; # nothing to do for one-ways
3807
3808
# little bit tricky part that binds in/out parameters
3809
if (UNIVERSAL::isa($result => 'SOAP::SOM')
3810
&& ($result->paramsout || $result->headers)
3811
&& $serializer->signature) {
3812
my $num = 0;
3813
my %signatures = map {$_ => $num++} @{$serializer->signature};
3814
for ($result->dataof(SOAP::SOM::paramsout), $result->dataof(SOAP::SOM::headers)) {
3815
my $signature = join $;, $_->name, $_->type || '';
3816
if (exists $signatures{$signature}) {
3817
my $param = $signatures{$signature};
3818
my($value) = $_->value; # take first value
3819
3820
# fillup parameters
3821
use Scalar::Util 'reftype';
3822
if ( reftype( $_[$param] ) ) {
3823
if ( reftype( $_[$param] ) eq 'SCALAR' ) {
3824
${ $_[$param] } = $$value;
3825
}
3826
elsif ( reftype( $_[$param] ) eq 'ARRAY' ) {
3827
@{ $_[$param] } = @$value;
3828
}
3829
elsif ( reftype( $_[$param] ) eq 'HASH' ) {
3830
if ( eval { $_[$param]->isa('SOAP::Data') } ) {
3831
$_[$param]->SOAP::Data::value($value);
3832
}
3833
elsif ( reftype($value) eq 'REF' ) {
3834
%{ $_[$param] } = %$$value;
3835
}
3836
else { %{ $_[$param] } = %$value; }
3837
}
3838
else { $_[$param] = $value; }
3839
}
3840
else {
3841
$_[$param] = $value;
3842
}
3843
}
3844
}
3845
}
3846
return $result;
3847
} # end of call()
3848
3849
# ======================================================================
3850
3851
package SOAP::Lite::COM;
3852
3853
require SOAP::Lite;
3854
3855
sub required {
3856
foreach (qw(
3857
URI::_foreign URI::http URI::https
3858
LWP::Protocol::http LWP::Protocol::https LWP::Authen::Basic LWP::Authen::Digest
3859
HTTP::Daemon Compress::Zlib SOAP::Transport::HTTP
3860
XMLRPC::Lite XMLRPC::Transport::HTTP
3861
)) {
3862
eval join ';', 'local $SIG{__DIE__}', "require $_";
3863
}
3864
}
3865
3866
sub new { required; SOAP::Lite->new(@_) }
3867
3868
sub create; *create = \&new; # make alias. Somewhere 'new' is registered keyword
3869
3870
sub soap; *soap = \&new; # also alias. Just to be consistent with .xmlrpc call
3871
3872
sub xmlrpc { required; XMLRPC::Lite->new(@_) }
3873
3874
sub server { required; shift->new(@_) }
3875
3876
sub data { SOAP::Data->new(@_) }
3877
3878
sub header { SOAP::Header->new(@_) }
3879
3880
sub hash { +{@_} }
3881
3882
sub instanceof {
3883
my $class = shift;
3884
die "Incorrect class name" unless $class =~ /^(\w[\w:]*)$/;
3885
eval "require $class";
3886
$class->new(@_);
3887
}
3888
3889
# ======================================================================
3890
3891
1;
3892
3893
__END__
3894
3895
=pod
3896
3897
=head1 NAME
3898
3899
SOAP::Lite - Perl's Web Services Toolkit
3900
3901
=head1 DESCRIPTION
3902
3903
SOAP::Lite is a collection of Perl modules which provides a simple and
3904
lightweight interface to the Simple Object Access Protocol (SOAP) both on
3905
client and server side.
3906
3907
=head1 PERL VERSION WARNING
3908
3909
SOAP::Lite 0.71 will be the last version of SOAP::Lite running on perl 5.005
3910
3911
Future versions of SOAP::Lite will require at least perl 5.6.0
3912
3913
If you have not had the time to upgrad your perl, you should consider this
3914
now.
3915
3916
=head1 OVERVIEW OF CLASSES AND PACKAGES
3917
3918
=over
3919
3920
=item F<lib/SOAP/Lite.pm>
3921
3922
L<SOAP::Lite> - Main class provides all logic
3923
3924
L<SOAP::Transport> - Transport backend
3925
3926
L<SOAP::Data> - Data objects
3927
3928
L<SOAP::Header> - Header Data Objects
3929
3930
L<SOAP::Serializer> - Serializes data structures to SOAP messages
3931
3932
L<SOAP::Deserializer> - Deserializes SOAP messages into SOAP::SOM objects
3933
3934
L<SOAP::SOM> - SOAP Message objects
3935
3936
L<SOAP::Constants> - Provides access to common constants and defaults
3937
3938
L<SOAP::Trace> - Tracing facilities
3939
3940
L<SOAP::Schema> - Provides access and stub(s) for schema(s)
3941
3942
L<SOAP::Schema::WSDL|SOAP::Schema/SOAP::Schema::WSDL> - WSDL implementation for SOAP::Schema
3943
3944
L<SOAP::Server> - Handles requests on server side
3945
3946
SOAP::Server::Object - Handles objects-by-reference
3947
3948
L<SOAP::Fault> - Provides support for Faults on server side
3949
3950
L<SOAP::Utils> - A set of private and public utility subroutines
3951
3952
=item F<lib/SOAP/Packager.pm>
3953
3954
L<SOAP::Packager> - Provides an abstract class for implementing custom packagers.
3955
3956
L<SOAP::Packager::MIME|SOAP::Packager/SOAP::Packager::MIME> - Provides MIME support to SOAP::Lite
3957
3958
L<SOAP::Packager::DIME|SOAP::Packager/SOAP::Packager::DIME> - Provides DIME support to SOAP::Lite
3959
3960
=item F<lib/SOAP/Transport/HTTP.pm>
3961
3962
L<SOAP::Transport::HTTP::Client|SOAP::Transport/SOAP::Transport::HTTP::Client> - Client interface to HTTP transport
3963
3964
L<SOAP::Transport::HTTP::Server|SOAP::Transport/SOAP::Transport::HTTP::Server> - Server interface to HTTP transport
3965
3966
L<SOAP::Transport::HTTP::CGI|SOAP::Transport/SOAP::Transport::HTTP::CGI> - CGI implementation of server interface
3967
3968
L<SOAP::Transport::HTTP::Daemon|SOAP::Transport/SOAP::Transport::HTTP::Daemon> - Daemon implementation of server interface
3969
3970
L<SOAP::Transport::HTTP::Apache|SOAP::Transport/SOAP::Transport::HTTP::Apache> - mod_perl implementation of server interface
3971
3972
=item F<lib/SOAP/Transport/POP3.pm>
3973
3974
L<SOAP::Transport::POP3::Server|SOAP::Transport/SOAP::Transport::POP3::Server> - Server interface to POP3 protocol
3975
3976
=item F<lib/SOAP/Transport/MAILTO.pm>
3977
3978
L<SOAP::Transport::MAILTO::Client|SOAP::Transport/SOAP::Transport::MAILTO::Client> - Client interface to SMTP/sendmail
3979
3980
=item F<lib/SOAP/Transport/LOCAL.pm>
3981
3982
L<SOAP::Transport::LOCAL::Client|SOAP::Transport/SOAP::Transport::LOCAL::Client> - Client interface to local transport
3983
3984
=item F<lib/SOAP/Transport/TCP.pm>
3985
3986
L<SOAP::Transport::TCP::Server|SOAP::Transport/SOAP::Transport::TCP::Server> - Server interface to TCP protocol
3987
3988
L<SOAP::Transport::TCP::Client|SOAP::Transport/SOAP::Transport::TCP::Client> - Client interface to TCP protocol
3989
3990
=item F<lib/SOAP/Transport/IO.pm>
3991
3992
L<SOAP::Transport::IO::Server|SOAP::Transport/SOAP::Transport::IO::Server> - Server interface to IO transport
3993
3994
=back
3995
3996
=head1 METHODS
3997
3998
All accessor methods return the current value when called with no arguments,
3999
while returning the object reference itself when called with a new value.
4000
This allows the set-attribute calls to be chained together.
4001
4002
=over
4003
4004
=item new(optional key/value pairs)
4005
4006
$client = SOAP::Lite->new(proxy => $endpoint)
4007
4008
Constructor. Many of the accessor methods defined here may be initialized at
4009
creation by providing their name as a key, followed by the desired value.
4010
The example provides the value for the proxy element of the client.
4011
4012
=item transport(optional transport object)
4013
4014
$transp = $client->transport( );
4015
4016
Gets or sets the transport object used for sending/receiving SOAP messages.
4017
4018
See L<SOAP::Transport> for details.
4019
4020
=item serializer(optional serializer object)
4021
4022
$serial = $client->serializer( )
4023
4024
Gets or sets the serializer object used for creating XML messages.
4025
4026
See L<SOAP::Serializer> for details.
4027
4028
=item packager(optional packager object)
4029
4030
$packager = $client->packager( )
4031
4032
Provides access to the C<SOAP::Packager> object that the client uses to manage
4033
the use of attachments. The default packager is a MIME packager, but unless
4034
you specify parts to send, no MIME formatting will be done.
4035
4036
See also: L<SOAP::Packager>.
4037
4038
=item proxy(endpoint, optional extra arguments)
4039
4040
$client->proxy('http://soap.xml.info/ endPoint');
4041
4042
The proxy is the server or endpoint to which the client is going to connect.
4043
This method allows the setting of the endpoint, along with any extra
4044
information that the transport object may need when communicating the request.
4045
4046
This method is actually an alias to the proxy method of L<SOAP::Transport>.
4047
It is the same as typing:
4048
4049
$client->transport( )->proxy(...arguments);
4050
4051
Extra parameters can be passed to proxy() - see below.
4052
4053
=over
4054
4055
=item compress_threshold
4056
4057
See L<COMPRESSION|SOAP::Transport/"COMPRESSION"> in L<HTTP::Transport>.
4058
4059
=item All initialization options from the underlying transport layer
4060
4061
The options for HTTP(S) are the same as for LWP::UserAgent's new() method.
4062
4063
A common option is to create a instance of HTTP::Cookies and pass it as
4064
cookie_jar option:
4065
4066
my $cookie_jar = HTTP::Cookies->new()
4067
$client->proxy('http://www.example.org/webservice',
4068
cookie_jar => $cookie_jar,
4069
);
4070
4071
=back
4072
4073
For example, if you wish to set the HTTP timeout for a SOAP::Lite client to 5
4074
seconds, use the following code:
4075
4076
my $soap = SOAP::Lite
4077
->uri($uri)
4078
->proxy($proxyUrl, timeout => 5 );
4079
4080
See L<LWP::UserAgent>.
4081
4082
=item endpoint(optional new endpoint address)
4083
4084
$client->endpoint('http://soap.xml.info/ newPoint')
4085
4086
It may be preferable to set a new endpoint without the additional work of
4087
examining the new address for protocol information and checking to ensure the
4088
support code is loaded and available. This method allows the caller to change
4089
the endpoint that the client is currently set to connect to, without
4090
reloading the relevant transport code. Note that the proxy method must have
4091
been called before this method is used.
4092
4093
=item service(service URL)
4094
4095
$client->service('http://svc.perl.org/Svc.wsdl');
4096
4097
C<SOAP::Lite> offers some support for creating method stubs from service
4098
descriptions. At present, only WSDL support is in place. This method loads
4099
the specified WSDL schema and uses it as the basis for generating stubs.
4100
4101
=item outputxml(boolean)
4102
4103
$client->outputxml('true');
4104
4105
When set to a true value, the raw XML is returned by the call to a remote
4106
method.
4107
4108
The default is to return the a L<SOAP::SOM> object (false).
4109
4110
=item autotype(boolean)
4111
4112
$client->autotype(0);
4113
4114
This method is a shortcut for:
4115
4116
$client->serializer->autotype(boolean);
4117
4118
By default, the serializer tries to automatically deduce types for the data
4119
being sent in a message. Setting a false value with this method disables the
4120
behavior.
4121
4122
=item readable(boolean)
4123
4124
$client->readable(1);
4125
4126
This method is a shortcut for:
4127
4128
$client->serializer->readable(boolean);
4129
4130
When this is used to set a true value for this property, the generated XML
4131
sent to the endpoint has extra characters (spaces and new lines) added in to
4132
make the XML itself more readable to human eyes (presumably for debugging).
4133
The default is to not send any additional characters.
4134
4135
=item default_ns($uri)
4136
4137
Sets the default namespace for the request to the specified uri. This
4138
overrides any previous namespace declaration that may have been set using a
4139
previous call to C<ns()> or C<default_ns()>. Setting the default namespace
4140
causes elements to be serialized without a namespace prefix, like this:
4141
4142
<soap:Envelope>
4143
<soap:Body>
4144
<myMethod xmlns="http://www.someuri.com">
4145
<foo />
4146
</myMethod>
4147
</soap:Body>
4148
</soap:Envelope>
4149
4150
Some .NET web services have been reported to require this XML namespace idiom.
4151
4152
=item ns($uri,$prefix=undef)
4153
4154
Sets the namespace uri and optionally the namespace prefix for the request to
4155
the specified values. This overrides any previous namespace declaration that
4156
may have been set using a previous call to C<ns()> or C<default_ns()>.
4157
4158
If a prefix is not specified, one will be generated for you automatically.
4159
Setting the namespace causes elements to be serialized with a declared
4160
namespace prefix, like this:
4161
4162
<soap:Envelope>
4163
<soap:Body>
4164
<my:myMethod xmlns:my="http://www.someuri.com">
4165
<my:foo />
4166
</my:myMethod>
4167
</soap:Body>
4168
</soap:Envelope>
4169
4170
=item use_prefix(boolean)
4171
4172
Deprecated. Use the C<ns()> and C<default_ns> methods described above.
4173
4174
Shortcut for C<< serializer->use_prefix() >>. This lets you turn on/off the
4175
use of a namespace prefix for the children of the /Envelope/Body element.
4176
Default is 'true'.
4177
4178
When use_prefix is set to 'true', serialized XML will look like this:
4179
4180
<SOAP-ENV:Envelope ...attributes skipped>
4181
<SOAP-ENV:Body>
4182
<namesp1:mymethod xmlns:namesp1="urn:MyURI" />
4183
</SOAP-ENV:Body>
4184
</SOAP-ENV:Envelope>
4185
4186
When use_prefix is set to 'false', serialized XML will look like this:
4187
4188
<SOAP-ENV:Envelope ...attributes skipped>
4189
<SOAP-ENV:Body>
4190
<mymethod xmlns="urn:MyURI" />
4191
</SOAP-ENV:Body>
4192
</SOAP-ENV:Envelope>
4193
4194
Some .NET web services have been reported to require this XML namespace idiom.
4195
4196
=item soapversion(optional value)
4197
4198
$client->soapversion('1.2');
4199
4200
If no parameter is given, returns the current version of SOAP that is being
4201
used by the client object to encode requests. If a parameter is given, the
4202
method attempts to set that as the version of SOAP being used.
4203
4204
The value should be either 1.1 or 1.2.
4205
4206
=item envprefix(QName)
4207
4208
$client->envprefix('env');
4209
4210
This method is a shortcut for:
4211
4212
$client->serializer->envprefix(QName);
4213
4214
Gets or sets the namespace prefix for the SOAP namespace. The default is
4215
SOAP.
4216
4217
The prefix itself has no meaning, but applications may wish to chose one
4218
explicitly to denote different versions of SOAP or the like.
4219
4220
=item encprefix(QName)
4221
4222
$client->encprefix('enc');
4223
4224
This method is a shortcut for:
4225
4226
$client->serializer->encprefix(QName);
4227
4228
Gets or sets the namespace prefix for the encoding rules namespace.
4229
The default value is SOAP-ENC.
4230
4231
=back
4232
4233
While it may seem to be an unnecessary operation to set a value that isn't
4234
relevant to the message, such as the namespace labels for the envelope and
4235
encoding URNs, the ability to set these labels explicitly can prove to be a
4236
great aid in distinguishing and debugging messages on the server side of
4237
operations.
4238
4239
=over
4240
4241
=item encoding(encoding URN)
4242
4243
$client->encoding($soap_12_encoding_URN);
4244
4245
This method is a shortcut for:
4246
4247
$client->serializer->encoding(args);
4248
4249
Where the earlier method dealt with the label used for the attributes related
4250
to the SOAP encoding scheme, this method actually sets the URN to be specified
4251
as the encoding scheme for the message. The default is to specify the encoding
4252
for SOAP 1.1, so this is handy for applications that need to encode according
4253
to SOAP 1.2 rules.
4254
4255
=item typelookup
4256
4257
$client->typelookup;
4258
4259
This method is a shortcut for:
4260
4261
$client->serializer->typelookup;
4262
4263
Gives the application access to the type-lookup table from the serializer
4264
object. See the section on L<SOAP::Serializer>.
4265
4266
=item uri(service specifier)
4267
4268
Deprecated - the C<uri> subroutine is deprecated in order to provide a more
4269
intuitive naming scheme for subroutines that set namespaces. In the future,
4270
you will be required to use either the C<ns()> or C<default_ns()> subroutines
4271
instead of C<uri()>.
4272
4273
$client->uri($service_uri);
4274
4275
This method is a shortcut for:
4276
4277
$client->serializer->uri(service);
4278
4279
The URI associated with this accessor on a client object is the
4280
service-specifier for the request, often encoded for HTTP-based requests as
4281
the SOAPAction header. While the names may seem confusing, this method
4282
doesn't specify the endpoint itself. In most circumstances, the C<uri> refers
4283
to the namespace used for the request.
4284
4285
Often times, the value may look like a valid URL. Despite this, it doesn't
4286
have to point to an existing resource (and often doesn't). This method sets
4287
and retrieves this value from the object. Note that no transport code is
4288
triggered by this because it has no direct effect on the transport of the
4289
object.
4290
4291
=item multirefinplace(boolean)
4292
4293
$client->multirefinplace(1);
4294
4295
This method is a shortcut for:
4296
4297
$client->serializer->multirefinplace(boolean);
4298
4299
Controls how the serializer handles values that have multiple references to
4300
them. Recall from previous SOAP chapters that a value may be tagged with an
4301
identifier, then referred to in several places. When this is the case for a
4302
value, the serializer defaults to putting the data element towards the top of
4303
the message, right after the opening tag of the method-specification. It is
4304
serialized as a standalone entity with an ID that is then referenced at the
4305
relevant places later on. If this method is used to set a true value, the
4306
behavior is different. When the multirefinplace attribute is true, the data
4307
is serialized at the first place that references it, rather than as a separate
4308
element higher up in the body. This is more compact but may be harder to read
4309
or trace in a debugging environment.
4310
4311
=item parts( ARRAY )
4312
4313
Used to specify an array of L<MIME::Entity>'s to be attached to the
4314
transmitted SOAP message. Attachments that are returned in a response can be
4315
accessed by C<SOAP::SOM::parts()>.
4316
4317
=item self
4318
4319
$ref = SOAP::Lite->self;
4320
4321
Returns an object reference to the default global object the C<SOAP::Lite>
4322
package maintains. This is the object that processes many of the arguments
4323
when provided on the use line.
4324
4325
=back
4326
4327
The following method isn't an accessor style of method but neither does it fit
4328
with the group that immediately follows it:
4329
4330
=over
4331
4332
=item call(arguments)
4333
4334
$client->call($method => @arguments);
4335
4336
As has been illustrated in previous chapters, the C<SOAP::Lite> client objects
4337
can manage remote calls with auto-dispatching using some of Perl's more
4338
elaborate features. call is used when the application wants a greater degree
4339
of control over the details of the call itself. The method may be built up
4340
from a L<SOAP::Data> object, so as to allow full control over the namespace
4341
associated with the tag, as well as other attributes like encoding. This is
4342
also important for calling methods that contain characters not allowable in
4343
Perl function names, such as A.B.C.
4344
4345
=back
4346
4347
The next four methods used in the C<SOAP::Lite> class are geared towards
4348
handling the types of events than can occur during the message lifecycle. Each
4349
of these sets up a callback for the event in question:
4350
4351
=over
4352
4353
=item on_action(callback)
4354
4355
$client->on_action(sub { qq("$_[0]") });
4356
4357
Triggered when the transport object sets up the SOAPAction header for an
4358
HTTP-based call. The default is to set the header to the string, uri#method,
4359
in which URI is the value set by the uri method described earlier, and method
4360
is the name of the method being called. When called, the routine referenced
4361
(or the closure, if specified as in the example) is given two arguments, uri
4362
and method, in that order.
4363
4364
.NET web services usually expect C</> as separator for C<uri> and C<method>.
4365
To change SOAP::Lite's behaviour to use uri/method as SOAPAction header, use
4366
the following code:
4367
4368
$client->on_action( sub { join '/', @_ } );
4369
=item on_fault(callback)
4370
4371
$client->on_fault(sub { popup_dialog($_[1]) });
4372
4373
Triggered when a method call results in a fault response from the server.
4374
When it is called, the argument list is first the client object itself,
4375
followed by the object that encapsulates the fault. In the example, the fault
4376
object is passed (without the client object) to a hypothetical GUI function
4377
that presents an error dialog with the text of fault extracted from the object
4378
(which is covered shortly under the L<SOAP::SOM> methods).
4379
4380
=item on_nonserialized(callback)
4381
4382
$client->on_nonserialized(sub { die "$_[0]?!?" });
4383
4384
Occasionally, the serializer may be given data it can't turn into SOAP-savvy
4385
XML; for example, if a program bug results in a code reference or something
4386
similar being passed in as a parameter to method call. When that happens, this
4387
callback is activated, with one argument. That argument is the data item that
4388
could not be understood. It will be the only argument. If the routine returns,
4389
the return value is pasted into the message as the serialization. Generally,
4390
an error is in order, and this callback allows for control over signaling that
4391
error.
4392
4393
=item on_debug(callback)
4394
4395
$client->on_debug(sub { print @_ });
4396
4397
Deprecated. Use the global +debug and +trace facilities described in
4398
L<SOAP::Trace>
4399
4400
Note that this method will not work as expected: Instead of affecting the
4401
debugging behaviour of the object called on, it will globally affect the
4402
debugging behaviour for all objects of that class.
4403
4404
=back
4405
4406
=head1 WRITING A SOAP CLIENT
4407
4408
This chapter guides you to writing a SOAP client by example.
4409
4410
The SOAP service to be accessed is a simple variation of the well-known
4411
hello world program. It accepts two parameters, a name and a given name,
4412
and returns "Hello $given_name $name".
4413
4414
We will use "Martin Kutter" as the name for the call, so all variants will
4415
print the following message on success:
4416
4417
Hello Martin Kutter!
4418
4419
=head2 SOAP message styles
4420
4421
There are three common (and one less common) variants of SOAP messages.
4422
4423
These address the message style (positional parameters vs. specified message
4424
documents) and encoding (as-is vs. typed).
4425
4426
The different message styles are:
4427
4428
=over
4429
4430
=item * rpc/encoded
4431
4432
Typed, positional parameters. Widely used in scripting languages.
4433
The type of the arguments is included in the message.
4434
Arrays and the like may be encoded using SOAP encoding rules (or others).
4435
4436
=item * rpc/literal
4437
4438
As-is, positional parameters. The type of arguments is defined by some
4439
pre-exchanged interface definition.
4440
4441
=item * document/encoded
4442
4443
Specified message with typed elements. Rarely used.
4444
4445
=item * document/literal
4446
4447
Specified message with as-is elements. The message specification and
4448
element types are defined by some pre-exchanged interface definition.
4449
4450
=back
4451
4452
As of 2008, document/literal has become the predominant SOAP message
4453
variant. rpc/literal and rpc/encoded are still in use, mainly with scripting
4454
languages, while document/encoded is hardly used at all.
4455
4456
You will see clients for the rpc/encoded and document/literal SOAP variants in
4457
this section.
4458
4459
=head2 Example implementations
4460
4461
=head3 RPC/ENCODED
4462
4463
Rpc/encoded is most popular with scripting languages like perl, php and python
4464
without the use of a WSDL. Usual method descriptions look like this:
4465
4466
Method: sayHello(string, string)
4467
Parameters:
4468
name: string
4469
givenName: string
4470
4471
Such a description usually means that you can call a method named "sayHello"
4472
with two positional parameters, "name" and "givenName", which both are
4473
strings.
4474
4475
The message corresponding to this description looks somewhat like this:
4476
4477
<sayHello xmlns="urn:HelloWorld">
4478
<s-gensym01 xsi:type="xsd:string">Kutter</s-gensym01>
4479
<s-gensym02 xsi:type="xsd:string">Martin</s-gensym02>
4480
</sayHello>
4481
4482
Any XML tag names may be used instead of the "s-gensym01" stuff - parameters
4483
are positional, the tag names have no meaning.
4484
4485
A client producing such a call is implemented like this:
4486
4487
use SOAP::Lite;
4488
my $soap = SOAP::Lite->new( proxy => 'http://localhost:81/soap-wsdl-test/helloworld.pl');
4489
$soap->default_ns('urn:HelloWorld');
4490
my $som = $soap->call('sayHello', 'Kutter', 'Martin');
4491
die $som->faultstring if ($som->fault);
4492
print $som->result, "\n";
4493
4494
You can of course use a one-liner, too...
4495
4496
Sometimes, rpc/encoded interfaces are described with WSDL definitions.
4497
A WSDL accepting "named" parameters with rpc/encoded looks like this:
4498
4499
<definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
4500
xmlns:s="http://www.w3.org/2001/XMLSchema"
4501
xmlns:s0="urn:HelloWorld"
4502
targetNamespace="urn:HelloWorld"
4503
xmlns="http://schemas.xmlsoap.org/wsdl/">
4504
<types>
4505
<s:schema targetNamespace="urn:HelloWorld">
4506
</s:schema>
4507
</types>
4508
<message name="sayHello">
4509
<part name="name" type="s:string" />
4510
<part name="givenName" type="s:string" />
4511
</message>
4512
<message name="sayHelloResponse">
4513
<part name="sayHelloResult" type="s:string" />
4514
</message>
4515
4516
<portType name="Service1Soap">
4517
<operation name="sayHello">
4518
<input message="s0:sayHello" />
4519
<output message="s0:sayHelloResponse" />
4520
</operation>
4521
</portType>
4522
4523
<binding name="Service1Soap" type="s0:Service1Soap">
4524
<soap:binding transport="http://schemas.xmlsoap.org/soap/http"
4525
style="rpc" />
4526
<operation name="sayHello">
4527
<soap:operation soapAction="urn:HelloWorld#sayHello"/>
4528
<input>
4529
<soap:body use="encoded"
4530
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
4531
</input>
4532
<output>
4533
<soap:body use="encoded"
4534
encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
4535
</output>
4536
</operation>
4537
</binding>
4538
<service name="HelloWorld">
4539
<port name="HelloWorldSoap" binding="s0:Service1Soap">
4540
<soap:address location="http://localhost:81/soap-wsdl-test/helloworld.pl" />
4541
</port>
4542
</service>
4543
</definitions>
4544
4545
The message corresponding to this schema looks like this:
4546
4547
<sayHello xmlns="urn:HelloWorld">
4548
<name xsi:type="xsd:string">Kutter</name>
4549
<givenName xsi:type="xsd:string">Martin</givenName>
4550
</sayHello>
4551
4552
A web service client using this schema looks like this:
4553
4554
use SOAP::Lite;
4555
my $soap = SOAP::Lite->service("file:say_hello_rpcenc.wsdl");
4556
eval { my $result = $soap->sayHello('Kutter', 'Martin'); };
4557
if ($@) {
4558
die $@;
4559
}
4560
print $som->result();
4561
4562
You may of course also use the following one-liner:
4563
4564
perl -MSOAP::Lite -e 'print SOAP::Lite->service("file:say_hello_rpcenc.wsdl")\
4565
->sayHello('Kutter', 'Martin'), "\n";'
4566
4567
A web service client (without a service description) looks like this.
4568
4569
use SOAP::Lite;
4570
my $soap = SOAP::Lite->new( proxy => 'http://localhost:81/soap-wsdl-test/helloworld.pl');
4571
$soap->default_ns('urn:HelloWorld');
4572
my $som = $soap->call('sayHello',
4573
SOAP::Data->name('name')->value('Kutter'),
4574
SOAP::Data->name('givenName')->value('Martin')
4575
);
4576
die $som->faultstring if ($som->fault);
4577
print $som->result, "\n";
4578
4579
=head3 RPC/LITERAL
4580
4581
SOAP web services using the document/literal message encoding are usually
4582
described by some Web Service Definition. Our web service has the following
4583
WSDL description:
4584
4585
<definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
4586
xmlns:s="http://www.w3.org/2001/XMLSchema"
4587
xmlns:s0="urn:HelloWorld"
4588
targetNamespace="urn:HelloWorld"
4589
xmlns="http://schemas.xmlsoap.org/wsdl/">
4590
<types>
4591
<s:schema targetNamespace="urn:HelloWorld">
4592
<s:complexType name="sayHello">
4593
<s:sequence>
4594
<s:element minOccurs="0" maxOccurs="1" name="name"
4595
type="s:string" />
4596
<s:element minOccurs="0" maxOccurs="1" name="givenName"
4597
type="s:string" nillable="1" />
4598
</s:sequence>
4599
</s:complexType>
4600
4601
<s:complexType name="sayHelloResponse">
4602
<s:sequence>
4603
<s:element minOccurs="0" maxOccurs="1" name="sayHelloResult"
4604
type="s:string" />
4605
</s:sequence>
4606
</s:complexType>
4607
</s:schema>
4608
</types>
4609
<message name="sayHello">
4610
<part name="parameters" type="s0:sayHello" />
4611
</message>
4612
<message name="sayHelloResponse">
4613
<part name="parameters" type="s0:sayHelloResponse" />
4614
</message>
4615
4616
<portType name="Service1Soap">
4617
<operation name="sayHello">
4618
<input message="s0:sayHello" />
4619
<output message="s0:sayHelloResponse" />
4620
</operation>
4621
</portType>
4622
4623
<binding name="Service1Soap" type="s0:Service1Soap">
4624
<soap:binding transport="http://schemas.xmlsoap.org/soap/http"
4625
style="rpc" />
4626
<operation name="sayHello">
4627
<soap:operation soapAction="urn:HelloWorld#sayHello"/>
4628
<input>
4629
<soap:body use="literal" namespace="urn:HelloWorld"/>
4630
</input>
4631
<output>
4632
<soap:body use="literal" namespace="urn:HelloWorld"/>
4633
</output>
4634
</operation>
4635
</binding>
4636
<service name="HelloWorld">
4637
<port name="HelloWorldSoap" binding="s0:Service1Soap">
4638
<soap:address location="http://localhost:80//helloworld.pl" />
4639
</port>
4640
</service>
4641
</definitions>
4642
4643
The XML message (inside the SOAP Envelope) look like this:
4644
4645
4646
<ns0:sayHello xmlns:ns0="urn:HelloWorld">
4647
<parameters>
4648
<name>Kutter</name>
4649
<givenName>Martin</givenName>
4650
</parameters>
4651
</ns0:sayHello>
4652
4653
<sayHelloResponse xmlns:ns0="urn:HelloWorld">
4654
<parameters>
4655
<sayHelloResult>Hello Martin Kutter!</sayHelloResult>
4656
</parameters>
4657
</sayHelloResponse>
4658
4659
This is the SOAP::Lite implementation for the web service client:
4660
4661
use SOAP::Lite +trace;
4662
my $soap = SOAP::Lite->new( proxy => 'http://localhost:80/helloworld.pl');
4663
4664
$soap->on_action( sub { "urn:HelloWorld#sayHello" });
4665
$soap->autotype(0)->readable(1);
4666
$soap->default_ns('urn:HelloWorld');
4667
4668
my $som = $soap->call('sayHello', SOAP::Data->name('parameters')->value(
4669
\SOAP::Data->value([
4670
SOAP::Data->name('name')->value( 'Kutter' ),
4671
SOAP::Data->name('givenName')->value('Martin'),
4672
]))
4673
);
4674
4675
die $som->fault->{ faultstring } if ($som->fault);
4676
print $som->result, "\n";
4677
4678
=head3 DOCUMENT/LITERAL
4679
4680
SOAP web services using the document/literal message encoding are usually
4681
described by some Web Service Definition. Our web service has the following
4682
WSDL description:
4683
4684
<definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
4685
xmlns:s="http://www.w3.org/2001/XMLSchema"
4686
xmlns:s0="urn:HelloWorld"
4687
targetNamespace="urn:HelloWorld"
4688
xmlns="http://schemas.xmlsoap.org/wsdl/">
4689
<types>
4690
<s:schema targetNamespace="urn:HelloWorld">
4691
<s:element name="sayHello">
4692
<s:complexType>
4693
<s:sequence>
4694
<s:element minOccurs="0" maxOccurs="1" name="name" type="s:string" />
4695
<s:element minOccurs="0" maxOccurs="1" name="givenName" type="s:string" nillable="1" />
4696
</s:sequence>
4697
</s:complexType>
4698
</s:element>
4699
4700
<s:element name="sayHelloResponse">
4701
<s:complexType>
4702
<s:sequence>
4703
<s:element minOccurs="0" maxOccurs="1" name="sayHelloResult" type="s:string" />
4704
</s:sequence>
4705
</s:complexType>
4706
</s:element>
4707
</types>
4708
<message name="sayHelloSoapIn">
4709
<part name="parameters" element="s0:sayHello" />
4710
</message>
4711
<message name="sayHelloSoapOut">
4712
<part name="parameters" element="s0:sayHelloResponse" />
4713
</message>
4714
4715
<portType name="Service1Soap">
4716
<operation name="sayHello">
4717
<input message="s0:sayHelloSoapIn" />
4718
<output message="s0:sayHelloSoapOut" />
4719
</operation>
4720
</portType>
4721
4722
<binding name="Service1Soap" type="s0:Service1Soap">
4723
<soap:binding transport="http://schemas.xmlsoap.org/soap/http"
4724
style="document" />
4725
<operation name="sayHello">
4726
<soap:operation soapAction="urn:HelloWorld#sayHello"/>
4727
<input>
4728
<soap:body use="literal" />
4729
</input>
4730
<output>
4731
<soap:body use="literal" />
4732
</output>
4733
</operation>
4734
</binding>
4735
<service name="HelloWorld">
4736
<port name="HelloWorldSoap" binding="s0:Service1Soap">
4737
<soap:address location="http://localhost:80//helloworld.pl" />
4738
</port>
4739
</service>
4740
</definitions>
4741
4742
The XML message (inside the SOAP Envelope) look like this:
4743
4744
<sayHello xmlns="urn:HelloWorld">
4745
<name>Kutter</name>
4746
<givenName>Martin</givenName>
4747
</sayHello>
4748
4749
<sayHelloResponse>
4750
<sayHelloResult>Hello Martin Kutter!</sayHelloResult>
4751
</sayHelloResponse>
4752
4753
You can call this web service with the following client code:
4754
4755
use SOAP::Lite;
4756
my $soap = SOAP::Lite->new( proxy => 'http://localhost:80/helloworld.pl');
4757
4758
$soap->on_action( sub { "urn:HelloWorld#sayHello" });
4759
$soap->autotype(0);
4760
$soap->default_ns('urn:HelloWorld');
4761
4762
my $som = $soap->call("sayHello",
4763
SOAP::Data->name('name')->value( 'Kutter' ),
4764
SOAP::Data->name('givenName')->value('Martin'),
4765
);
4766
4767
die $som->fault->{ faultstring } if ($som->fault);
4768
print $som->result, "\n";
4769
4770
=head2 Differences between the implementations
4771
4772
You may have noticed that there's little difference between the rpc/encoded,
4773
rpc/literal and the document/literal example's implementation. In fact, from
4774
SOAP::Lite's point of view, the only differences between rpc/literal and
4775
document/literal that parameters are always named.
4776
4777
In our example, the rpc/encoded variant already used named parameters (by
4778
using two messages), so there's no difference at all.
4779
4780
You may have noticed the somewhat strange idiom for passing a list of named
4781
paraneters in the rpc/literal example:
4782
4783
my $som = $soap->call('sayHello', SOAP::Data->name('parameters')->value(
4784
\SOAP::Data->value([
4785
SOAP::Data->name('name')->value( 'Kutter' ),
4786
SOAP::Data->name('givenName')->value('Martin'),
4787
]))
4788
);
4789
4790
While SOAP::Data provides full control over the XML generated, passing
4791
hash-like structures require additional coding.
4792
4793
=head1 WRITING A SOAP SERVER
4794
4795
See L<SOAP::Server>, or L<SOAP::Transport>.
4796
4797
=head1 FEATURES
4798
4799
=head2 ATTACHMENTS
4800
4801
C<SOAP::Lite> features support for the SOAP with Attachments specification.
4802
Currently, SOAP::Lite only supports MIME based attachments. DIME based
4803
attachments are yet to be fully functional.
4804
4805
=head3 EXAMPLES
4806
4807
=head4 Client sending an attachment
4808
4809
C<SOAP::Lite> clients can specify attachments to be sent along with a request
4810
by using the C<SOAP::Lite::parts()> method, which takes as an argument an
4811
ARRAY of C<MIME::Entity>'s.
4812
4813
use SOAP::Lite;
4814
use MIME::Entity;
4815
my $ent = build MIME::Entity
4816
Type => "image/gif",
4817
Encoding => "base64",
4818
Path => "somefile.gif",
4819
Filename => "saveme.gif",
4820
Disposition => "attachment";
4821
my $som = SOAP::Lite
4822
->uri($SOME_NAMESPACE)
4823
->parts([ $ent ])
4824
->proxy($SOME_HOST)
4825
->some_method(SOAP::Data->name("foo" => "bar"));
4826
4827
=head4 Client retrieving an attachment
4828
4829
A client accessing attachments that were returned in a response by using the
4830
C<SOAP::SOM::parts()> accessor.
4831
4832
use SOAP::Lite;
4833
use MIME::Entity;
4834
my $soap = SOAP::Lite
4835
->uri($NS)
4836
->proxy($HOST);
4837
my $som = $soap->foo();
4838
foreach my $part (${$som->parts}) {
4839
print $part->stringify;
4840
}
4841
4842
=head4 Server receiving an attachment
4843
4844
Servers, like clients, use the S<SOAP::SOM> module to access attachments
4845
transmitted to it.
4846
4847
package Attachment;
4848
use SOAP::Lite;
4849
use MIME::Entity;
4850
use strict;
4851
use vars qw(@ISA);
4852
@ISA = qw(SOAP::Server::Parameters);
4853
sub someMethod {
4854
my $self = shift;
4855
my $envelope = pop;
4856
foreach my $part (@{$envelope->parts}) {
4857
print "AttachmentService: attachment found! (".ref($part).")\n";
4858
}
4859
# do something
4860
}
4861
4862
=head4 Server responding with an attachment
4863
4864
Servers wishing to return an attachment to the calling client need only return
4865
C<MIME::Entity> objects along with SOAP::Data elements, or any other data
4866
intended for the response.
4867
4868
package Attachment;
4869
use SOAP::Lite;
4870
use MIME::Entity;
4871
use strict;
4872
use vars qw(@ISA);
4873
@ISA = qw(SOAP::Server::Parameters);
4874
sub someMethod {
4875
my $self = shift;
4876
my $envelope = pop;
4877
my $ent = build MIME::Entity
4878
'Id' => "<1234>",
4879
'Type' => "text/xml",
4880
'Path' => "some.xml",
4881
'Filename' => "some.xml",
4882
'Disposition' => "attachment";
4883
return SOAP::Data->name("foo" => "blah blah blah"),$ent;
4884
}
4885
4886
=head2 DEFAULT SETTINGS
4887
4888
Though this feature looks similar to
4889
L<autodispatch|/"IN/OUT, OUT PARAMETERS AND AUTOBINDING"> they have (almost)
4890
nothing in common. This capability allows you specify default settings so that
4891
all objects created after that will be initialized with the proper default
4892
settings.
4893
4894
If you wish to provide common C<proxy()> or C<uri()> settings for all
4895
C<SOAP::Lite> objects in your application you may do:
4896
4897
use SOAP::Lite
4898
proxy => 'http://localhost/cgi-bin/soap.cgi',
4899
uri => 'http://my.own.com/My/Examples';
4900
4901
my $soap1 = new SOAP::Lite; # will get the same proxy()/uri() as above
4902
print $soap1->getStateName(1)->result;
4903
4904
my $soap2 = SOAP::Lite->new; # same thing as above
4905
print $soap2->getStateName(2)->result;
4906
4907
# or you may override any settings you want
4908
my $soap3 = SOAP::Lite->proxy('http://localhost/');
4909
print $soap3->getStateName(1)->result;
4910
4911
B<Any> C<SOAP::Lite> properties can be propagated this way. Changes in object
4912
copies will not affect global settings and you may still change global
4913
settings with C<< SOAP::Lite->self >> call which returns reference to global
4914
object. Provided parameter will update this object and you can even set it to
4915
C<undef>:
4916
4917
SOAP::Lite->self(undef);
4918
4919
The C<use SOAP::Lite> syntax also lets you specify default event handlers for
4920
your code. If you have different SOAP objects and want to share the same
4921
C<on_action()> (or C<on_fault()> for that matter) handler. You can specify
4922
C<on_action()> during initialization for every object, but you may also do:
4923
4924
use SOAP::Lite
4925
on_action => sub {sprintf '%s#%s', @_};
4926
4927
and this handler will be the default handler for all your SOAP objects. You
4928
can override it if you specify a handler for a particular object. See F<t/*.t>
4929
for example of on_fault() handler.
4930
4931
Be warned, that since C<use ...> is executed at compile time B<all> C<use>
4932
statements will be executed B<before> script execution that can make
4933
unexpected results. Consider code:
4934
4935
use SOAP::Lite proxy => 'http://localhost/';
4936
print SOAP::Lite->getStateName(1)->result;
4937
4938
use SOAP::Lite proxy => 'http://localhost/cgi-bin/soap.cgi';
4939
print SOAP::Lite->getStateName(1)->result;
4940
4941
B<Both> SOAP calls will go to C<'http://localhost/cgi-bin/soap.cgi'>. If you
4942
want to execute C<use> at run-time, put it in C<eval>:
4943
4944
eval "use SOAP::Lite proxy => 'http://localhost/cgi-bin/soap.cgi'; 1" or die;
4945
4946
Or alternatively,
4947
4948
SOAP::Lite->self->proxy('http://localhost/cgi-bin/soap.cgi');
4949
4950
=head2 SETTING MAXIMUM MESSAGE SIZE
4951
4952
One feature of C<SOAP::Lite> is the ability to control the maximum size of a
4953
message a SOAP::Lite server will be allowed to process. To control this
4954
feature simply define C<$SOAP::Constants::MAX_CONTENT_SIZE> in your code like
4955
so:
4956
4957
use SOAP::Transport::HTTP;
4958
use MIME::Entity;
4959
$SOAP::Constants::MAX_CONTENT_SIZE = 10000;
4960
SOAP::Transport::HTTP::CGI
4961
->dispatch_to('TemperatureService')
4962
->handle;
4963
4964
=head2 IN/OUT, OUT PARAMETERS AND AUTOBINDING
4965
4966
C<SOAP::Lite> gives you access to all parameters (both in/out and out) and
4967
also does some additional work for you. Lets consider following example:
4968
4969
<mehodResponse>
4970
<res1>name1</res1>
4971
<res2>name2</res2>
4972
<res3>name3</res3>
4973
</mehodResponse>
4974
4975
In that case:
4976
4977
$result = $r->result; # gives you 'name1'
4978
$paramout1 = $r->paramsout; # gives you 'name2', because of scalar context
4979
$paramout1 = ($r->paramsout)[0]; # gives you 'name2' also
4980
$paramout2 = ($r->paramsout)[1]; # gives you 'name3'
4981
4982
or
4983
4984
@paramsout = $r->paramsout; # gives you ARRAY of out parameters
4985
$paramout1 = $paramsout[0]; # gives you 'res2', same as ($r->paramsout)[0]
4986
$paramout2 = $paramsout[1]; # gives you 'res3', same as ($r->paramsout)[1]
4987
4988
Generally, if server returns C<return (1,2,3)> you will get C<1> as the result
4989
and C<2> and C<3> as out parameters.
4990
4991
If the server returns C<return [1,2,3]> you will get an ARRAY reference from
4992
C<result()> and C<undef> from C<paramsout()>.
4993
4994
Results can be arbitrary complex: they can be an array references, they can be
4995
objects, they can be anything and still be returned by C<result()> . If only
4996
one parameter is returned, C<paramsout()> will return C<undef>.
4997
4998
Furthermore, if you have in your output parameters a parameter with the same
4999
signature (name+type) as in the input parameters this parameter will be mapped
5000
into your input automatically. For example:
5001
5002
B<Server Code>:
5003
5004
sub mymethod {
5005
shift; # object/class reference
5006
my $param1 = shift;
5007
my $param2 = SOAP::Data->name('myparam' => shift() * 2);
5008
return $param1, $param2;
5009
}
5010
5011
B<Client Code>:
5012
5013
$a = 10;
5014
$b = SOAP::Data->name('myparam' => 12);
5015
$result = $soap->mymethod($a, $b);
5016
5017
After that, C<< $result == 10 and $b->value == 24 >>! Magic? Sort of.
5018
5019
Autobinding gives it to you. That will work with objects also with one
5020
difference: you do not need to worry about the name and the type of object
5021
parameter. Consider the C<PingPong> example (F<examples/My/PingPong.pm>
5022
and F<examples/pingpong.pl>):
5023
5024
B<Server Code>:
5025
5026
package My::PingPong;
5027
5028
sub new {
5029
my $self = shift;
5030
my $class = ref($self) || $self;
5031
bless {_num=>shift} => $class;
5032
}
5033
5034
sub next {
5035
my $self = shift;
5036
$self->{_num}++;
5037
}
5038
5039
B<Client Code>:
5040
5041
use SOAP::Lite +autodispatch =>
5042
uri => 'urn:',
5043
proxy => 'http://localhost/';
5044
5045
my $p = My::PingPong->new(10); # $p->{_num} is 10 now, real object returned
5046
print $p->next, "\n"; # $p->{_num} is 11 now!, object autobinded
5047
5048
=head2 STATIC AND DYNAMIC SERVICE DEPLOYMENT
5049
5050
Let us scrutinize the deployment process. When designing your SOAP server you
5051
can consider two kind of deployment: B<static> and B<dynamic>. For both,
5052
static and dynamic, you should specify C<MODULE>, C<MODULE::method>,
5053
C<method> or C<PATH/> when creating C<use>ing the SOAP::Lite module. The
5054
difference between static and dynamic deployment is that in case of 'dynamic',
5055
any module which is not present will be loaded on demand. See the
5056
L</"SECURITY"> section for detailed description.
5057
5058
When statically deploying a SOAP Server, you need to know all modules handling
5059
SOAP requests before.
5060
5061
Dynamic deployment allows extending your SOAP Server's interface by just
5062
installing another module into the dispatch_to path (see below).
5063
5064
=head3 STATIC DEPLOYMENT EXAMPLE
5065
5066
use SOAP::Transport::HTTP;
5067
use My::Examples; # module is preloaded
5068
5069
SOAP::Transport::HTTP::CGI
5070
# deployed module should be present here or client will get
5071
# 'access denied'
5072
-> dispatch_to('My::Examples')
5073
-> handle;
5074
5075
For static deployment you should specify the MODULE name directly.
5076
5077
You should also use static binding when you have several different classes in
5078
one file and want to make them available for SOAP calls.
5079
5080
=head3 DYNAMIC DEPLOYMENT EXAMPLE
5081
5082
use SOAP::Transport::HTTP;
5083
# name is unknown, module will be loaded on demand
5084
5085
SOAP::Transport::HTTP::CGI
5086
# deployed module should be present here or client will get 'access denied'
5087
-> dispatch_to('/Your/Path/To/Deployed/Modules', 'My::Examples')
5088
-> handle;
5089
5090
For dynamic deployment you can specify the name either directly (in that case
5091
it will be C<require>d without any restriction) or indirectly, with a PATH. In
5092
that case, the ONLY path that will be available will be the PATH given to the
5093
dispatch_to() method). For information how to handle this situation see
5094
L</"SECURITY"> section.
5095
5096
=head3 SUMMARY
5097
5098
dispatch_to(
5099
# dynamic dispatch that allows access to ALL modules in specified directory
5100
PATH/TO/MODULES
5101
# 1. specifies directory
5102
# -- AND --
5103
# 2. gives access to ALL modules in this directory without limits
5104
5105
# static dispatch that allows access to ALL methods in particular MODULE
5106
MODULE
5107
# 1. gives access to particular module (all available methods)
5108
# PREREQUISITES:
5109
# module should be loaded manually (for example with 'use ...')
5110
# -- OR --
5111
# you can still specify it in PATH/TO/MODULES
5112
5113
# static dispatch that allows access to particular method ONLY
5114
MODULE::method
5115
# same as MODULE, but gives access to ONLY particular method,
5116
# so there is not much sense to use both MODULE and MODULE::method
5117
# for the same MODULE
5118
);
5119
5120
In addition to this C<SOAP::Lite> also supports an experimental syntax that
5121
allows you to bind a specific URL or SOAPAction to a CLASS/MODULE or object.
5122
5123
For example:
5124
5125
dispatch_with({
5126
URI => MODULE, # 'http://www.soaplite.com/' => 'My::Class',
5127
SOAPAction => MODULE, # 'http://www.soaplite.com/method' => 'Another::Class',
5128
URI => object, # 'http://www.soaplite.com/obj' => My::Class->new,
5129
})
5130
5131
C<URI> is checked before C<SOAPAction>. You may use both the C<dispatch_to()>
5132
and C<dispatch_with()> methods in the same server, but note that
5133
C<dispatch_with()> has a higher order of precedence. C<dispatch_to()> will be
5134
checked only after C<URI> and C<SOAPAction> has been checked.
5135
5136
See also:
5137
L<EXAMPLE APACHE::REGISTRY USAGE|SOAP::Transport/"EXAMPLE APACHE::REGISTRY USAGE">,
5138
L</"SECURITY">
5139
5140
=head2 COMPRESSION
5141
5142
C<SOAP::Lite> provides you option to enable transparent compression over the
5143
wire. Compression can be enabled by specifying a threshold value (in the form
5144
of kilobytes) for compression on both the client and server sides:
5145
5146
I<Note: Compression currently only works for HTTP based servers and clients.>
5147
5148
B<Client Code>
5149
5150
print SOAP::Lite
5151
->uri('http://localhost/My/Parameters')
5152
->proxy('http://localhost/', options => {compress_threshold => 10000})
5153
->echo(1 x 10000)
5154
->result;
5155
5156
B<Server Code>
5157
5158
my $server = SOAP::Transport::HTTP::CGI
5159
->dispatch_to('My::Parameters')
5160
->options({compress_threshold => 10000})
5161
->handle;
5162
5163
For more information see L<COMPRESSION|SOAP::Transport/"COMPRESSION"> in
5164
L<HTTP::Transport>.
5165
5166
=head1 SECURITY
5167
5168
For security reasons, the exisiting path for Perl modules (C<@INC>) will be
5169
disabled once you have chosen dynamic deployment and specified your own
5170
C<PATH/>. If you wish to access other modules in your included package you
5171
have several options:
5172
5173
=over 4
5174
5175
=item 1
5176
5177
Switch to static linking:
5178
5179
use MODULE;
5180
$server->dispatch_to('MODULE');
5181
5182
Which can also be useful when you want to import something specific from the
5183
deployed modules:
5184
5185
use MODULE qw(import_list);
5186
5187
=item 2
5188
5189
Change C<use> to C<require>. The path is only unavailable during the
5190
initialization phase. It is available once more during execution. Therefore,
5191
if you utilize C<require> somewhere in your package, it will work.
5192
5193
=item 3
5194
5195
Wrap C<use> in an C<eval> block:
5196
5197
eval 'use MODULE qw(import_list)'; die if $@;
5198
5199
=item 4
5200
5201
Set your include path in your package and then specify C<use>. Don't forget to
5202
put C<@INC> in a C<BEGIN{}> block or it won't work. For example,
5203
5204
BEGIN { @INC = qw(my_directory); use MODULE }
5205
5206
=back
5207
5208
=head1 INTEROPERABILITY
5209
5210
=head2 Microsoft .NET client with SOAP::Lite Server
5211
5212
In order to use a .NET client with a SOAP::Lite server, be sure you use fully
5213
qualified names for your return values. For example:
5214
5215
return SOAP::Data->name('myname')
5216
->type('string')
5217
->uri($MY_NAMESPACE)
5218
->value($output);
5219
5220
In addition see comment about default incoding in .NET Web Services below.
5221
5222
=head2 SOAP::Lite client with a .NET server
5223
5224
If experiencing problems when using a SOAP::Lite client to call a .NET Web
5225
service, it is recommended you check, or adhere to all of the following
5226
recommendations:
5227
5228
=over 4
5229
5230
=item Declare a proper soapAction in your call
5231
5232
For example, use
5233
C<on_action( sub { 'http://www.myuri.com/WebService.aspx#someMethod'; } )>.
5234
5235
=item Disable charset definition in Content-type header
5236
5237
Some users have said that Microsoft .NET prefers the value of
5238
the Content-type header to be a mimetype exclusively, but SOAP::Lite specifies
5239
a character set in addition to the mimetype. This results in an error similar
5240
to:
5241
5242
Server found request content type to be 'text/xml; charset=utf-8',
5243
but expected 'text/xml'
5244
5245
To turn off this behavior specify use the following code:
5246
5247
use SOAP::Lite;
5248
$SOAP::Constants::DO_NOT_USE_CHARSET = 1;
5249
# The rest of your code
5250
5251
=item Use fully qualified name for method parameters
5252
5253
For example, the following code is preferred:
5254
5255
SOAP::Data->name(Query => 'biztalk')
5256
->uri('http://tempuri.org/')
5257
5258
As opposed to:
5259
5260
SOAP::Data->name('Query' => 'biztalk')
5261
5262
=item Place method in default namespace
5263
5264
For example, the following code is preferred:
5265
5266
my $method = SOAP::Data->name('add')
5267
->attr({xmlns => 'http://tempuri.org/'});
5268
my @rc = $soap->call($method => @parms)->result;
5269
5270
As opposed to:
5271
5272
my @rc = $soap->call(add => @parms)->result;
5273
# -- OR --
5274
my @rc = $soap->add(@parms)->result;
5275
5276
=item Disable use of explicit namespace prefixes
5277
5278
Some user's have reported that .NET will simply not parse messages that use
5279
namespace prefixes on anything but SOAP elements themselves. For example, the
5280
following XML would not be parsed:
5281
5282
<SOAP-ENV:Envelope ...attributes skipped>
5283
<SOAP-ENV:Body>
5284
<namesp1:mymethod xmlns:namesp1="urn:MyURI" />
5285
</SOAP-ENV:Body>
5286
</SOAP-ENV:Envelope>
5287
5288
SOAP::Lite allows users to disable the use of explicit namespaces through the
5289
C<use_prefix()> method. For example, the following code:
5290
5291
$som = SOAP::Lite->uri('urn:MyURI')
5292
->proxy($HOST)
5293
->use_prefix(0)
5294
->myMethod();
5295
5296
Will result in the following XML, which is more pallatable by .NET:
5297
5298
<SOAP-ENV:Envelope ...attributes skipped>
5299
<SOAP-ENV:Body>
5300
<mymethod xmlns="urn:MyURI" />
5301
</SOAP-ENV:Body>
5302
</SOAP-ENV:Envelope>
5303
5304
=item Modify your .NET server, if possible
5305
5306
Stefan Pharies <stefanph@microsoft.com>:
5307
5308
SOAP::Lite uses the SOAP encoding (section 5 of the soap 1.1 spec), and
5309
the default for .NET Web Services is to use a literal encoding. So
5310
elements in the request are unqualified, but your service expects them to
5311
be qualified. .Net Web Services has a way for you to change the expected
5312
message format, which should allow you to get your interop working.
5313
At the top of your class in the asmx, add this attribute (for Beta 1):
5314
5315
[SoapService(Style=SoapServiceStyle.RPC)]
5316
5317
Another source said it might be this attribute (for Beta 2):
5318
5319
[SoapRpcService]
5320
5321
Full Web Service text may look like:
5322
5323
<%@ WebService Language="C#" Class="Test" %>
5324
using System;
5325
using System.Web.Services;
5326
using System.Xml.Serialization;
5327
5328
[SoapService(Style=SoapServiceStyle.RPC)]
5329
public class Test : WebService {
5330
[WebMethod]
5331
public int add(int a, int b) {
5332
return a + b;
5333
}
5334
}
5335
5336
Another example from Kirill Gavrylyuk <kirillg@microsoft.com>:
5337
5338
"You can insert [SoapRpcService()] attribute either on your class or on
5339
operation level".
5340
5341
<%@ WebService Language=CS class="DataType.StringTest"%>
5342
5343
namespace DataType {
5344
5345
using System;
5346
using System.Web.Services;
5347
using System.Web.Services.Protocols;
5348
using System.Web.Services.Description;
5349
5350
[SoapRpcService()]
5351
public class StringTest: WebService {
5352
[WebMethod]
5353
[SoapRpcMethod()]
5354
public string RetString(string x) {
5355
return(x);
5356
}
5357
}
5358
}
5359
5360
Example from Yann Christensen <yannc@microsoft.com>:
5361
5362
using System;
5363
using System.Web.Services;
5364
using System.Web.Services.Protocols;
5365
5366
namespace Currency {
5367
[WebService(Namespace="http://www.yourdomain.com/example")]
5368
[SoapRpcService]
5369
public class Exchange {
5370
[WebMethod]
5371
public double getRate(String country, String country2) {
5372
return 122.69;
5373
}
5374
}
5375
}
5376
5377
=back
5378
5379
Special thanks goes to the following people for providing the above
5380
description and details on .NET interoperability issues:
5381
5382
Petr Janata <petr.janata@i.cz>,
5383
5384
Stefan Pharies <stefanph@microsoft.com>,
5385
5386
Brian Jepson <bjepson@jepstone.net>, and others
5387
5388
=head1 TROUBLESHOOTING
5389
5390
=over 4
5391
5392
=item SOAP::Lite serializes "18373" as an integer, but I want it to be a string!
5393
5394
SOAP::Lite guesses datatypes from the content provided, using a set of
5395
common-sense rules. These rules are not 100% reliable, though they fit for
5396
most data.
5397
5398
You may force the type by passing a SOAP::Data object with a type specified:
5399
5400
my $proxy = SOAP::Lite->proxy('http://www.example.org/soapservice');
5401
my $som = $proxy->myMethod(
5402
SOAP::Data->name('foo')->value(12345)->type('string')
5403
);
5404
5405
You may also change the precedence of the type-guessing rules. Note that this
5406
means fiddling with SOAP::Lite's internals - this may not work as
5407
expected in future versions.
5408
5409
The example above forces everything to be encoded as string (this is because
5410
the string test is normally last and allways returns true):
5411
5412
my @list = qw(-1 45 foo bar 3838);
5413
my $proxy = SOAP::Lite->uri($uri)->proxy($proxyUrl);
5414
my $lookup = $proxy->serializer->typelookup;
5415
$lookup->{string}->[0] = 0;
5416
$proxy->serializer->typelookup($lookup);
5417
$proxy->myMethod(\@list);
5418
5419
See L<SOAP::Serializer|SOAP::Serializer/AUTOTYPING> for more details.
5420
5421
=item C<+autodispatch> doesn't work in Perl 5.8
5422
5423
There is a bug in Perl 5.8's C<UNIVERSAL::AUTOLOAD> functionality that
5424
prevents the C<+autodispatch> functionality from working properly. The
5425
workaround is to use C<dispatch_from> instead. Where you might normally do
5426
something like this:
5427
5428
use Some::Module;
5429
use SOAP::Lite +autodispatch =>
5430
uri => 'urn:Foo'
5431
proxy => 'http://...';
5432
5433
You would do something like this:
5434
5435
use SOAP::Lite dispatch_from(Some::Module) =>
5436
uri => 'urn:Foo'
5437
proxy => 'http://...';
5438
5439
=item Problems using SOAP::Lite's COM Interface
5440
5441
=over
5442
5443
=item Can't call method "server" on undefined value
5444
5445
You probably did not register F<Lite.dll> using C<regsvr32 Lite.dll>
5446
5447
=item Failed to load PerlCtrl Runtime
5448
5449
It is likely that you have install Perl in two different locations and the
5450
location of ActiveState's Perl is not the first instance of Perl specified
5451
in your PATH. To rectify, rename the directory in which the non-ActiveState
5452
Perl is installed, or be sure the path to ActiveState's Perl is specified
5453
prior to any other instance of Perl in your PATH.
5454
5455
=back
5456
5457
=item Dynamic libraries are not found
5458
5459
If you are using the Apache web server, and you are seeing something like the
5460
following in your webserver log file:
5461
5462
Can't load '/usr/local/lib/perl5/site_perl/.../XML/Parser/Expat/Expat.so'
5463
for module XML::Parser::Expat: dynamic linker: /usr/local/bin/perl:
5464
libexpat.so.0 is NEEDED, but object does not exist at
5465
/usr/local/lib/perl5/.../DynaLoader.pm line 200.
5466
5467
Then try placing the following into your F<httpd.conf> file and see if it
5468
fixes your problem.
5469
5470
<IfModule mod_env.c>
5471
PassEnv LD_LIBRARY_PATH
5472
</IfModule>
5473
5474
=item SOAP client reports "500 unexpected EOF before status line seen
5475
5476
See L</"Apache is crashing with segfaults">
5477
5478
=item Apache is crashing with segfaults
5479
5480
Using C<SOAP::Lite> (or L<XML::Parser::Expat>) in combination with mod_perl
5481
causes random segmentation faults in httpd processes. To fix, try configuring
5482
Apache with the following:
5483
5484
RULE_EXPAT=no
5485
5486
If you are using Apache 1.3.20 and later, try configuring Apache with the
5487
following option:
5488
5489
./configure --disable-rule=EXPAT
5490
5491
See http://archive.covalent.net/modperl/2000/04/0185.xml for more details and
5492
lot of thanks to Robert Barta <rho@bigpond.net.au> for explaining this weird
5493
behavior.
5494
5495
If this doesn't address the problem, you may wish to try C<-Uusemymalloc>,
5496
or a similar option in order to instruct Perl to use the system's own C<malloc>.
5497
5498
Thanks to Tim Bunce <Tim.Bunce@pobox.com>.
5499
5500
=item CGI scripts do not work under Microsoft Internet Information Server (IIS)
5501
5502
CGI scripts may not work under IIS unless scripts use the C<.pl> extension,
5503
opposed to C<.cgi>.
5504
5505
=item Java SAX parser unable to parse message composed by SOAP::Lite
5506
5507
In some cases SOAP messages created by C<SOAP::Lite> may not be parsed
5508
properly by a SAX2/Java XML parser. This is due to a known bug in
5509
C<org.xml.sax.helpers.ParserAdapter>. This bug manifests itself when an
5510
attribute in an XML element occurs prior to the XML namespace declaration on
5511
which it depends. However, according to the XML specification, the order of
5512
these attributes is not significant.
5513
5514
http://www.megginson.com/SAX/index.html
5515
5516
Thanks to Steve Alpert (Steve_Alpert@idx.com) for pointing on it.
5517
5518
=back
5519
5520
=head1 PERFORMANCE
5521
5522
=over 4
5523
5524
=item Processing of XML encoded fragments
5525
5526
C<SOAP::Lite> is based on L<XML::Parser> which is basically wrapper around
5527
James Clark's expat parser. Expat's behavior for parsing XML encoded string
5528
can affect processing messages that have lot of encoded entities, like XML
5529
fragments, encoded as strings. Providing low-level details, parser will call
5530
char() callback for every portion of processed stream, but individually for
5531
every processed entity or newline. It can lead to lot of calls and additional
5532
memory manager expenses even for small messages. By contrast, XML messages
5533
which are encoded as base64Binary, don't have this problem and difference in
5534
processing time can be significant. For XML encoded string that has about 20
5535
lines and 30 tags, number of call could be about 100 instead of one for
5536
the same string encoded as base64Binary.
5537
5538
Since it is parser's feature there is NO fix for this behavior (let me know
5539
if you find one), especially because you need to parse message you already
5540
got (and you cannot control content of this message), however, if your are
5541
in charge for both ends of processing you can switch encoding to base64 on
5542
sender's side. It will definitely work with SOAP::Lite and it B<may> work with
5543
other toolkits/implementations also, but obviously I cannot guarantee that.
5544
5545
If you want to encode specific string as base64, just do
5546
C<< SOAP::Data->type(base64 => $string) >> either on client or on server
5547
side. If you want change behavior for specific instance of SOAP::Lite, you
5548
may subclass C<SOAP::Serializer>, override C<as_string()> method that is
5549
responsible for string encoding (take a look into C<as_base64Binary()>) and
5550
specify B<new> serializer class for your SOAP::Lite object with:
5551
5552
my $soap = new SOAP::Lite
5553
serializer => My::Serializer->new,
5554
..... other parameters
5555
5556
or on server side:
5557
5558
my $server = new SOAP::Transport::HTTP::Daemon # or any other server
5559
serializer => My::Serializer->new,
5560
..... other parameters
5561
5562
If you want to change this behavior for B<all> instances of SOAP::Lite, just
5563
substitute C<as_string()> method with C<as_base64Binary()> somewhere in your
5564
code B<after> C<use SOAP::Lite> and B<before> actual processing/sending:
5565
5566
*SOAP::Serializer::as_string = \&SOAP::XMLSchema2001::Serializer::as_base64Binary;
5567
5568
Be warned that last two methods will affect B<all> strings and convert them
5569
into base64 encoded. It doesn't make any difference for SOAP::Lite, but it
5570
B<may> make a difference for other toolkits.
5571
5572
=back
5573
5574
=head1 BUGS AND LIMITATIONS
5575
5576
=over 4
5577
5578
=item *
5579
5580
No support for multidimensional, partially transmitted and sparse arrays
5581
(however arrays of arrays are supported, as well as any other data structures,
5582
and you can add your own implementation with SOAP::Data).
5583
5584
=item *
5585
5586
Limited support for WSDL schema.
5587
5588
=item *
5589
5590
XML::Parser::Lite relies on Unicode support in Perl and doesn't do entity decoding.
5591
5592
=item *
5593
5594
Limited support for mustUnderstand and Actor attributes.
5595
5596
=back
5597
5598
=head1 PLATFORM SPECIFICS
5599
5600
=over 4
5601
5602
=item MacOS
5603
5604
Information about XML::Parser for MacPerl could be found here:
5605
5606
http://bumppo.net/lists/macperl-modules/1999/07/msg00047.html
5607
5608
Compiled XML::Parser for MacOS could be found here:
5609
5610
http://www.perl.com/CPAN-local/authors/id/A/AS/ASANDSTRM/XML-Parser-2.27-bin-1-MacOS.tgz
5611
5612
=back
5613
5614
=head1 RELATED MODULES
5615
5616
=head2 Transport Modules
5617
5618
SOAP::Lite allows one to add support for additional transport protocols, or
5619
server handlers, via separate modules implementing the SOAP::Transport::*
5620
interface. The following modules are available from CPAN:
5621
5622
=over
5623
5624
=item * SOAP-Transport-HTTP-Nginx
5625
5626
L<SOAP::Transport::HTTP::Nginx|SOAP::Transport::HTTP::Nginx> provides a transport module for nginx (<http://nginx.net/>)
5627
5628
=back
5629
5630
=head1 AVAILABILITY
5631
5632
You can download the latest version SOAP::Lite for Unix or SOAP::Lite for
5633
Win32 from the following sources:
5634
5635
* CPAN: http://search.cpan.org/search?dist=SOAP-Lite
5636
* Sourceforge: http://sourceforge.net/projects/soaplite/
5637
5638
PPM packages are also available from sourceforge.
5639
5640
You are welcome to send e-mail to the maintainers of SOAP::Lite with your
5641
comments, suggestions, bug reports and complaints.
5642
5643
=head1 ACKNOWLEDGEMENTS
5644
5645
Special thanks to Randy J. Ray, author of
5646
I<Programming Web Services with Perl>, who has contributed greatly to the
5647
documentation effort of SOAP::Lite.
5648
5649
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite
5650
to republish and redistribute the SOAP::Lite reference manual found in
5651
Appendix B of I<Programming Web Services with Perl>.
5652
5653
And special gratitude to all the developers who have contributed patches,
5654
ideas, time, energy, and help in a million different forms to the development
5655
of this software.
5656
5657
=head1 HACKING
5658
5659
SOAP::Lite's development takes place on sourceforge.net.
5660
5661
There's a subversion repository set up at
5662
5663
https://soaplite.svn.sourceforge.net/svnroot/soaplite/
5664
5665
=head1 REPORTING BUGS
5666
5667
Please report all suspected SOAP::Lite bugs using Sourceforge. This ensures
5668
proper tracking of the issue and allows you the reporter to know when something
5669
gets fixed.
5670
5671
http://sourceforge.net/tracker/?group_id=66000&atid=513017
5672
5673
=head1 COPYRIGHT
5674
5675
Copyright (C) 2000-2007 Paul Kulchenko. All rights reserved.
5676
5677
Copyright (C) 2007-2008 Martin Kutter
5678
5679
=head1 LICENSE
5680
5681
This library is free software; you can redistribute it and/or modify
5682
it under the same terms as Perl itself.
5683
5684
This text and all associated documentation for this library is made available
5685
under the Creative Commons Attribution-NoDerivs 2.0 license.
5686
http://creativecommons.org/licenses/by-nd/2.0/
5687
5688
=head1 AUTHORS
5689
5690
Paul Kulchenko (paulclinger@yahoo.com)
5691
5692
Randy J. Ray (rjray@blackperl.com)
5693
5694
Byrne Reese (byrne@majordojo.com)
5695
5696
Martin Kutter (martin.kutter@fen-net.de)
5697
5698
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1