#!/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 => 32 } $SIG{__WARN__} = sub { ; }; # turn off deprecation warnings use SOAP::Lite; my($a, $s, $r, $serialized, $deserialized); my %tests = ( 'XML only' => <<'EOM', 2 5 EOM 'message with headers' => <<'EOM', Content-Type: text/xml 2 5 EOM 'singlepart MIME' => <<'EOM', Content-Type: Multipart/Related; boundary=MIME_boundary; type="text/xml"; start="" --MIME_boundary Content-Type: text/xml; charset=UTF-8 Content-Transfer-Encoding: 8bit Content-ID: 2 5 --MIME_boundary-- EOM 'multipart MIME' => <<'EOM', Content-Type: Multipart/Related; boundary=MIME_boundary; type="text/xml"; start="" --MIME_boundary Content-Type: text/xml; charset=UTF-8 Content-Transfer-Encoding: 8bit Content-ID: 2 5 --MIME_boundary Content-Type: text/plain Content-Transfer-Encoding: binary Content-ID: 2 --MIME_boundary Content-Type: text/plain Content-Transfer-Encoding: binary Content-ID: 5 --MIME_boundary-- EOM 'multipart MIME w/multiref' => <<'EOM', Content-Type: Multipart/Related; boundary=MIME_boundary; type="text/xml"; start="" --MIME_boundary Content-Type: text/xml; charset=UTF-8 Content-Transfer-Encoding: 8bit Content-ID: --MIME_boundary Content-Type: text/plain Content-Transfer-Encoding: binary Content-ID: 2 --MIME_boundary Content-Type: text/plain Content-Transfer-Encoding: binary Content-ID: 5 --MIME_boundary-- EOM ); eval "SOAP::Packager::MIME->new->initialize_parser"; my $is_mimetools_installed = $@ ? 0 : 1; (my $reason = $@) =~ s/ at .+// unless $is_mimetools_installed; print "MIME tests will be skipped: $reason" if defined $reason; my $package = ' package Calculator; sub new { bless {} => ref($_[0]) || $_[0] } sub add { $_[1] + $_[2] } sub schema { $SOAP::Constants::DEFAULT_XML_SCHEMA } 1;'; # TEST 1-4 { print "Server handler test(s)...\n"; my $server = SOAP::Server->dispatch_to('Calculator'); foreach (keys %tests) { my $result = SOAP::Deserializer->deserialize($server->handle($tests{$_})); skip(($_ =~ /XML/ || !$is_mimetools_installed), ($result->faultstring || '') =~ /Failed to access class \(Calculator\)/); } eval $package or die; foreach (keys %tests) { my $result = SOAP::Deserializer->deserialize($server->handle($tests{$_})); skip(($_ =~ /XML/ || !$is_mimetools_installed), ($result->result || 0) == 7); } } { print "Server handler with complex dispatches test(s)...\n"; foreach my $server ( # dispatch to class SOAP::Server->dispatch_to('Calculator'), # dispatch to object SOAP::Server->dispatch_to(Calculator->new), # dispatch to regexp SOAP::Server->dispatch_to('Calc\w+'), # dispatch URI to class SOAP::Server->dispatch_with({'http://www.soaplite.com/Calculator' => 'Calculator'}), # dispatch URI to object SOAP::Server->dispatch_with({'http://www.soaplite.com/Calculator' => Calculator->new}), # dispatch quoted SOAPAction to class SOAP::Server->action('"http://action/#method"') ->dispatch_with({'http://action/#method' => 'Calculator'}), # dispatch non-quoted SOAPAction to class SOAP::Server->action('http://action/#method') ->dispatch_with({'http://action/#method' => 'Calculator'}), # dispatch to class and BAD regexp. SOAP::Server->dispatch_to('\protocols', 'Calculator') ) { # end for my $result = SOAP::Deserializer->deserialize($server->handle($tests{'XML only'})); ok(($result->result || 0) == 7); } } { print "Error handling in server test(s)...\n"; $a = SOAP::Server->handle(''); ok($a =~ /Can't find root/); $a = SOAP::Server->handle(''); ok($a =~ /Can't find method/); $a = SOAP::Server->handle('11'); ok($a =~ /Denied access to method/); $a = SOAP::Server->handle(' '); ok($a =~ /Can't find method/); } { print "Envelope with no namespaces test(s)...\n"; eval 'sub add { $_[1] + $_[2] }; 1' or die; my $result = SOAP::Deserializer->deserialize(SOAP::Server->dispatch_to('add')->handle('34')); ok(($result->result || 0) == 7); } { print "Different XML Schemas test(s)...\n"; my $server = SOAP::Server->dispatch_to('Calculator'); $a = $server->handle(' '); ok($a =~ m!xsi="http://www.w3.org/2001/XMLSchema-instance"!); ok($a =~ m!xsd="http://www.w3.org/2001/XMLSchema"!); ok($a =~ m!>http://www.w3.org/2001/XMLSchemahandle(' 2 '); ok($a =~ m!xsi="http://www.w3.org/2001/XMLSchema-instance"!); ok($a =~ m!xsd="http://www.w3.org/2001/XMLSchema"!); ok($a =~ m!>http://www.w3.org/2001/XMLSchemahandle(' 2 '); ok($a =~ m!xsi="http://www.w3.org/2001/XMLSchema-instance"!); ok($a =~ m!xsd="http://www.w3.org/2001/XMLSchema"!); ok($a =~ m!>http://www.w3.org/2001/XMLSchema