#!/bin/env perl
BEGIN {
unless(grep /blib/, @INC) {
chdir 't' if -d 't';
unshift @INC, '../lib' if -d '../lib';
}
}
use strict;
use Test;
BEGIN { plan tests => 131 }
use SOAP::Lite;
$SIG{__WARN__} = sub { ; }; # turn off deprecation warnings
my($a, $s, $r, $serialized, $deserialized);
{ # check root, mustUnderstand
print "root and mustUnderstand attributes with SOAP::Data test(s)...\n";
$serialized = SOAP::Serializer->serialize(SOAP::Data->root(1 => 1)->name('rootandunderstand')->mustUnderstand(1));
ok($serialized =~ m!1!);
}
{ # check deserialization of envelope with result
print "Deserialization of envelope with result test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
- 20
- 40
- 60
- 100
- 200
');
ok($deserialized->result->[2] == 60);
ok((my @array = $deserialized->paramsall) == 1);
ok(ref $deserialized->body eq 'HASH'); # not blessed anymore since 0.51
}
{ # check deserialization of envelope with fault
print "Deserialization of envelope with fault test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
soap:ClientApplication ErrorInvalid Password
');
ok($deserialized->faultcode eq 'soap:Client');
ok($deserialized->faultstring eq 'Application Error');
ok($deserialized->faultdetail eq 'Invalid Password');
}
{ # check deserialization of circular references
print "Deserialization of circular references test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
');
ok(ref $deserialized->valueof('/Struct') eq ref $deserialized->valueof('//b'));
ok($deserialized->dataof('/Struct')->attr->{'{aaa}id'} == 123);
ok(exists $deserialized->dataof('/Struct')->attr->{'id'});
}
{ # check SOAP::SOM
print "SOM test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
20
40
60
100
200
');
# should return STRING '/Envelope/Body/[1]/[1]'
my $result = SOAP::SOM::result;
ok($deserialized->valueof("$result/[1]") == 20);
ok($deserialized->valueof("$result/[3]") == 60);
ok($deserialized->valueof("$result/[5]") == 200);
# match should return true/false in boolean context (and object ref otherwise)
ok($deserialized->match('aaa') ? 0 : 1);
# should return same string as above
ok($deserialized->match(SOAP::SOM->result));
ok($deserialized->valueof('[1]') == 20);
ok($deserialized->valueof('[3]') == 60);
ok($deserialized->valueof('[5]') == 200);
$deserialized->match('//Body/[1]/[1]'); # match path and change current node on success
ok($deserialized->valueof('[1]') == 20);
ok($deserialized->valueof('[3]') == 60);
ok($deserialized->valueof('[5]') == 200);
}
{ # check output parameters
print "Output parameters test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
name1
name2
name3
');
my @paramsout = $deserialized->paramsout;
ok($paramsout[0] eq 'name2' && $paramsout[1] eq 'name3');
}
{ # check nonqualified namespace
print "Nonqualified namespace test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
- 20
- 40
- 60
- 100
- 200
');
ok($deserialized->namespaceuriof(SOAP::SOM::method) eq 'http://simon.fell.com/calc');
ok($deserialized->namespaceuriof('//doublerResponse') eq 'http://simon.fell.com/calc');
}
{ # check for Array of Array serialization
print "Array of Array serialization test(s)...\n";
$serialized = SOAP::Serializer
->readable(1)
->method('mymethod' => [[1, 2], [3, 4]]);
ok($serialized =~ m!soapenc:arrayType="soapenc:Array\[2\]"!);
}
{ # check for serialization with SOAPStruct
print "Serialization w/out SOAPStruct test(s)...\n";
$a = { a => 1 };
$serialized = SOAP::Serializer->namespaces({})->serialize($a);
ok($serialized =~ m!1!);
}
{ # check header/envelope serialization/deserialization
print "Header/Envelope serialization/deserialization test(s)...\n";
$serialized = SOAP::Serializer->method( # same as ->envelope(method =>
'mymethod', 1, 2, 3,
SOAP::Header->name(t1 => 5)->mustUnderstand(1)->uri('http://namespaces.soaplite.com/headers'),
SOAP::Header->name(t2 => 7)->mustUnderstand(2),
);
$deserialized = SOAP::Deserializer->deserialize($serialized);
my $t1 = $deserialized->match(SOAP::SOM::header)->headerof('t1');
my $t2 = $deserialized->dataof('t2');
my $t3 = eval { $deserialized->headerof(SOAP::SOM::header . '/{http://namespaces.soaplite.com/headers}t3'); };
ok(!$@ && !defined $t3);
my @paramsin = $deserialized->paramsin;
my @paramsall = $deserialized->paramsall;
ok($t2->type =~ /^int$/);
ok($t2->mustUnderstand == 1);
ok(@paramsin == 3);
ok(@paramsall == 3);
eval { $deserialized->result(1) };
ok($@ =~ /Method 'result' is readonly/);
$serialized = SOAP::Serializer->method( # same as ->envelope(method =>
SOAP::Data->name('mymethod')->attr({something => 'value'}), 1, 2, 3,
);
ok($serialized =~ //);
$serialized = SOAP::Serializer
-> envprefix('')
-> method('mymethod');
ok($serialized =~ m!!);
$deserialized = SOAP::Deserializer->deserialize('1');
ok(! defined $deserialized->namespaceuriof('//getStateName'));
$deserialized = SOAP::Deserializer->deserialize('1');
ok($deserialized->namespaceuriof('//getStateName') eq 'a');
}
{ # Map type serialization/deserialization
print "Map type serialization/deserialization test(s)...\n";
my $key = "\0\1";
$serialized = SOAP::Serializer->method(aa => SOAP::Data->type(map => {a => 123, $key => 456})->name('maaap'));
{ local $^W; # disable warning on implicit map encoding
my $implicit = SOAP::Serializer->method(aa => SOAP::Data->name(maaap => {a => 123, $key => 456}));
ok($implicit eq $serialized);
}
ok($serialized =~ /apachens:Map/);
ok($serialized =~ m!xmlns:apachens="http://xml.apache.org/xml-soap"!);
$deserialized = SOAP::Deserializer->deserialize($serialized);
$a = $deserialized->valueof('//maaap');
ok(UNIVERSAL::isa($a => 'HASH'));
ok(ref $a && $a->{$key} == 456);
}
{ # Stringified type serialization
print "Stringified type serialization test(s)...\n";
$serialized = SOAP::Serializer->serialize(bless { a => 1, _current => [] } => 'SOAP::SOM');
my $test = $serialized;
ok $test =~s{
<\?xml \s version="1.0" \s encoding="UTF-8"\?>
}{}xms;
ok $test =~s{
\z
}{}xms;
ok $test =~s{ 1 }{}xms;
ok $test =~s{ <_current (:?
\s soapenc:arrayType="xsd:anyType\[0\]"
| \s xsi:type="soapenc:Array" ){2}
\s/>
}{}xms;
ok length $test == 0;
# Replaced complex regex by several simpler (see above).
# ok($serialized =~ m!1<_current(?: soapenc:arrayType="xsd:anyType\[0\]"| xsi:type="soapenc:Array"){2} />!);
# ok( ($serialized =~ m!1<_current(?: soapenc:arrayType="xsd:anyType\[0\]"| xsi:type="soapenc:Array"){2}/>!)
# || ($serialized =~ m!<_current(?: soapenc:arrayType="xsd:anyType\[0\]"| xsi:type="soapenc:Array"){2}/>1!));
#print $serialized;
# exit;
$serialized =~ s/__/./g; # check for SOAP.SOM instead of SOAP__SOM
ok(ref SOAP::Deserializer->deserialize($serialized)->root eq 'SOAP::SOM');
}
{ # Serialization of non-allowed element
print "Serialization of non-allowed element test(s)...\n";
eval { $serialized = SOAP::Serializer->serialize(SOAP::Data->name('---' => 'aaa')) };
ok($@ =~ /^Element/);
}
{ # Custom serialization of blessed reference
print "Custom serialization of blessed reference test(s)...\n";
eval q!
sub SOAP::Serializer::as_My__Own__Class {
my $self = shift;
my($value, $name, $type, $attr) = @_;
return [$name, {%{$attr || {}}, 'xsi:type' => 'xsd:string'}, join ', ', map {"$_ => $value->{$_}"} sort keys %$value];
}
1;
! or die;
$serialized = SOAP::Serializer->serialize(bless {a => 1, b => 2} => 'My::Own::Class');
ok($serialized =~ m!a => 1, b => 2!);
}
{ # Multirefs serialization
print "Multirefs serialization test(s)...\n";
my $b = { b => 2 };
my $a = { a => $b };
my $c = { c1 => $a, c2 => $a };
$serialized = SOAP::Serializer->autotype(0)->method(a => $c);
ok($serialized =~ m!2! ||
$serialized =~ m!2! ||
$serialized =~ m!2! ||
$serialized =~ m!2!);
$serialized = SOAP::Serializer->autotype(0)->namespaces({})->serialize($c);
ok($serialized =~ m!2! ||
$serialized =~ m!2! ||
$serialized =~ m!2! ||
$serialized =~ m!2!);
my $root = SOAP::Deserializer->deserialize($serialized)->root;
ok($root->{c1}->{a}->{b} == 2);
ok($root->{c2}->{a}->{b} == 2);
}
{ # Serialization of multirefs shared between Header and Body
print "Serialization of multirefs shared between Header and Body test(s)...\n";
$a = { b => 2 };
$serialized = SOAP::Serializer->autotype(0)->method(a => SOAP::Header->value($a), $a);
ok($serialized =~ m!2!);
}
{ # Deserialization with typecast
print "Deserialization with typecast test(s)...\n";
my $desc = 0;
my $typecasts = 0;
eval {
package MyDeserializer;
@MyDeserializer::ISA = 'SOAP::Deserializer';
sub typecast;
*typecast = sub { shift;
my($value, $name, $attrs, $children, $type) = @_;
$desc = "$name @{[scalar @$children]}" if $name eq 'a';
$typecasts++;
return;
};
1;
} or die;
$deserialized = MyDeserializer->deserialize('12');
ok($desc eq 'a 2'); #! fix "if $name eq 'a'", because $name is QName now ('{}a')
ok($typecasts == 5);
}
{ # Deserialization with wrong encodingStyle
print "Deserialization with wrong encodingStyle test(s)...\n";
eval { $deserialized = SOAP::Deserializer->deserialize(
'1') };
ok(!$@ && $deserialized);
eval { $deserialized = SOAP::Deserializer->deserialize(
'1') };
ok(!$@ && $deserialized);
eval { $deserialized = SOAP::Deserializer->deserialize(
'1') };
ok(!$@ && $deserialized);
eval { $deserialized = SOAP::Deserializer->deserialize(
'1') };
ok(!$@ && $deserialized);
eval { $deserialized = SOAP::Deserializer->deserialize(
'1') };
ok(!$@ && $deserialized);
}
{ # Deserialization with root attribute
print "Deserialization with root attribute test(s)...\n";
# root="0", should skip
$deserialized = SOAP::Deserializer->deserialize('
1
2
');
ok($deserialized->result == 2);
# root="0", but in wrong namespace
$deserialized = SOAP::Deserializer->deserialize('
1
2
');
ok($deserialized->result == 1);
# root="1"
$deserialized = SOAP::Deserializer->deserialize('
1
2
3
4
');
ok($deserialized->result == 1);
ok($deserialized->valueof('//{http://www.soaplite.com/2}doublerResponse2/nums') == 2);
ok($deserialized->valueof('//{http://www.soaplite.com/3}doublerResponse2/nums') == 3);
ok($deserialized->valueof('//{}doublerResponse2/nums') == 4);
my @nums = $deserialized->valueof('//doublerResponse2/nums');
ok(@nums == 3);
ok($nums[0] == 2 && $nums[1] == 3);
my $body = $deserialized->body;
ok(ref $body->{doublerResponse1} && ref $body->{doublerResponse2});
}
{
print "Deserialization with null elements test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
- 1
- 2
- 5
- 7
')->result;
ok(scalar @$deserialized == 7);
ok(! defined $deserialized->[2]);
ok(! defined $deserialized->[3]);
ok($deserialized->[5] eq '');
}
{
print "Serialization of list with undef elements test(s)...\n";
$serialized = SOAP::Serializer->method(a => undef, 1, undef, 2);
my(@r) = SOAP::Deserializer->deserialize($serialized)->paramsall;
ok(2 == grep {!defined} @r);
}
{
print "Deserialization with xsi:type='string' test(s)...\n";
$a = 'SOAP::Lite';
$deserialized = SOAP::Deserializer->deserialize(qq!$a!)->root;
ok($deserialized eq $a);
}
{
print "Deserialization with typing inherited from Array element test(s)...\n";
$deserialized = SOAP::Deserializer->deserialize('
- MTIz
- MTIz
')->root;
ok(scalar @$deserialized == 3);
ok($deserialized->[0] eq 'MTIz');
ok($deserialized->[1] eq 123);
ok($deserialized->[2] eq '');
}
{
print "Serialization with explicit typing test(s)...\n";
$serialized = SOAP::Serializer
->method(a => SOAP::Data->name('return')->type(int => 1));
ok($serialized =~ /xsd:int/);
eval {
$serialized = SOAP::Serializer
->method(a => SOAP::Data->name('return')->type(noint => 1));
};
ok($@ =~ /for type 'noint' is not specified/);
}
{
print "Serialization w/out explicit typing test(s)...\n";
$a = { a => 'false' };
$serialized = SOAP::Serializer->namespaces({})->serialize($a);
### 'false' evaluated as a boolean should still be false after the evaluation.
ok($serialized =~ m!false!);
$a = { a => 'true' };
$serialized = SOAP::Serializer->namespaces({})->serialize($a);
### 'false' evaluated as a boolean should still be false after the evaluation.
ok($serialized =~ m!true!);
}
{
print "Serialization with explicit namespaces test(s)...\n";
$serialized = SOAP::Serializer->serialize(SOAP::Data->name('b' => 1));
ok($serialized =~ m!serialize(SOAP::Data->name('c:b' => 1));
ok($serialized =~ m!serialize(SOAP::Data->name('{a}b' => 1));
ok($serialized =~ m!serialize(SOAP::Data->name('{}b' => 1));
ok($serialized =~ m!1' ],
[ undef, '', '1' ],
[ undef, 'a', '<(namesp\d+):b xmlns:\1="a">1\1:b>' ],
[ '', undef, '1' ],
[ '', '', '1' ],
[ '', 'a', '1' ],
[ 'c', undef, '1' ],
[ 'c', '', '1' ],
[ 'c', 'a', '1' ],
);
my $serializer = SOAP::Serializer->autotype(0)->namespaces({});
my $deserializer = SOAP::Deserializer->new;
my $testnum = 0;
foreach (@prefix_uri_tests) {
$testnum++;
my($prefix, $uri, $test) = @$_;
my $res = $serializer->serialize(
SOAP::Data->name('b')->prefix($prefix)->uri($uri)->value(1)
);
ok($res =~ /$test/);
next unless $testnum =~ /^([4569])$/;
my $data = $deserializer->deserialize($res)->dataof(SOAP::SOM::root);
ok(defined $prefix ? defined $data->prefix && $data->prefix eq $prefix
: !defined $data->prefix);
ok(defined $uri ? defined $data->uri && $data->uri eq $uri
: !defined $data->uri);
}
}
{
print "Deserialization for different SOAP versions test(s)...\n";
my $version = SOAP::Lite->soapversion;
$a = q!
- 1
- 3
- 5
!;
SOAP::Lite->soapversion(1.1);
$deserialized = SOAP::Deserializer->deserialize($a);
ok(ref $deserialized->result eq 'ARRAY');
SOAP::Lite->soapversion(1.2);
$deserialized = SOAP::Deserializer->deserialize($a);
ok(ref $deserialized->result eq 'ARRAY');
SOAP::Lite->soapversion($version);
}
{
print "Deserialization of multidimensional array of array test(s)...\n";
$a = q!
123
456
789
101112
!;
$deserialized = SOAP::Deserializer->deserialize($a)->result;
# [
# [
# ['1', '2', '3'],
# ['4', '5', '6']
# ],
# [
# ['7', '8', '9'],
# ['10', '11', '12']
# ]
# ]
ok(ref $deserialized eq 'ARRAY');
ok(@$deserialized == 2);
ok(@{$deserialized->[0]} == 2);
ok(@{$deserialized->[0]->[0]} == 3);
ok($deserialized->[0]->[0]->[2] == 3);
}
{
print "Serialization without specified typemapping test(s)...\n";
$serialized = SOAP::Serializer->method(a => bless {a => 1} => 'A');
ok($serialized =~ m!!);
ok($serialized =~ m!^<\?xml!); # xml declaration
# higly questionably, but that's how it is
$serialized = SOAP::Serializer->encoding(undef)->method(a => bless {a => 1} => 'A');
ok($serialized =~ m!!);
ok($serialized !~ m!^<\?xml!); # no xml declaration
}
{
print "Deserialization with different XML Schemas on one element test(s)...\n";
my $deserializer = SOAP::Deserializer->new;
$deserializer->deserialize(q!
Simple Test String
!);
ok($deserializer->xmlschema eq 'http://www.w3.org/1999/XMLSchema');
$deserializer->deserialize(q!
Simple Test String
!);
ok($deserializer->xmlschema eq 'http://www.w3.org/2001/XMLSchema');
}
{
print "SOAP::Fault stringification test(s)...\n";
my $f = SOAP::Fault->faultcode('Client.Authenticate')
->faultstring('Bad error');
ok($f eq 'Client.Authenticate: Bad error');
}
{
print "Memory leaks test(s)...\n"; # also check 36-leaks.t
my %calls;
{
SOAP::Lite->import(trace => [objects => sub {
if ((caller(2))[3] =~ /^(.+)::(.+)$/) {
$calls{$2}{$1}++;
}
}]);
my $soap = SOAP::Lite
-> uri("Echo")
-> proxy("http://services.soaplite.com/echo.cgi");
}
foreach (keys %{$calls{new}}) {
ok(exists $calls{DESTROY}{$_});
}
%calls = ();
{
local $SOAP::Constants::DO_NOT_USE_XML_PARSER = 1;
my $soap = SOAP::Lite
-> uri("Echo")
-> proxy("http://services.soaplite.com/echo.cgi");
}
foreach (keys %{$calls{new}}) {
ok(exists $calls{DESTROY}{$_});
}
SOAP::Lite->import(trace => '-objects');
}