#!/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 => 125 } 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'); } # TODO - These tests are failing at line 243 because of the odd $key value { # 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'); ok($serialized =~ m!1<_current(?: soapenc:arrayType="xsd:anyType\[0\]"| xsi:type="soapenc:Array"){2} />!); $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 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' ], [ '', 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'); }