home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _195b6e9eaff5bb82df30bf55b2144ff5 < prev    next >
Encoding:
Text File  |  2004-06-01  |  11.9 KB  |  408 lines
  1. # ======================================================================
  2. #
  3. # Copyright (C) 2000-2001 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: Test.pm,v 1.9 2002/04/15 22:02:01 paulk Exp $
  8. #
  9. # ======================================================================
  10.  
  11. package SOAP::Test;
  12.  
  13. use 5.004;
  14. use vars qw($VERSION $TIMEOUT);
  15. $VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/);
  16.  
  17. $TIMEOUT = 5;
  18.  
  19. # ======================================================================
  20.  
  21. package My::PingPong; # we'll use this package in our tests
  22.  
  23. sub new { 
  24.   my $self = shift;
  25.   my $class = ref($self) || $self;
  26.   bless {_num=>shift} => $class;
  27. }
  28.  
  29. sub next {
  30.   my $self = shift;
  31.   $self->{_num}++;
  32. }
  33.  
  34. sub value {
  35.   my $self = shift;
  36.   $self->{_num};
  37. }
  38.  
  39. # ======================================================================
  40.  
  41. package SOAP::Test::Server;
  42.  
  43. use strict;
  44. use Test;
  45. use SOAP::Lite;
  46.  
  47. sub run_for {
  48.   my $proxy = shift or die "Proxy/endpoint is not specified";
  49.  
  50.   # ------------------------------------------------------
  51.   my $s = SOAP::Lite->uri('http://something/somewhere')->proxy($proxy)->on_fault(sub{});
  52.   eval { $s->transport->timeout($SOAP::Test::TIMEOUT) };
  53.   my $r = $s->test_connection;
  54.  
  55.   unless (defined $r && defined $r->envelope) {
  56.     print "1..0 # Skip: ", $s->transport->status, "\n";
  57.     exit;
  58.   }
  59.   # ------------------------------------------------------
  60.  
  61.   plan tests => 53;
  62.  
  63.   eval q!use SOAP::Lite on_fault => sub{ref $_[1] ? $_[1] : new SOAP::SOM}; 1! or die;
  64.  
  65.   print "Perl SOAP server test(s)...\n";
  66.  
  67.   $s = SOAP::Lite
  68.     -> uri('urn:/My/Examples')                
  69.     -> proxy($proxy)
  70.   ;
  71.  
  72.   ok($s->getStateName(1)->result eq 'Alabama'); 
  73.   ok($s->getStateNames(1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/); 
  74.  
  75.   $r = $s->getStateList([1,2,3,4])->result;
  76.   ok(ref $r && $r->[0] eq 'Alabama'); 
  77.  
  78.   $r = $s->getStateStruct({item1 => 1, item2 => 4})->result;
  79.   ok(ref $r && $r->{item2} eq 'Arkansas'); 
  80.  
  81.   {
  82.     my $autoresult = $s->autoresult;
  83.     $s->autoresult(1);
  84.     ok($s->getStateName(1) eq 'Alabama');
  85.     $s->autoresult($autoresult);
  86.   }
  87.  
  88.   print "Autobinding of output parameters test(s)...\n";
  89.  
  90.   $s->uri('urn:/My/Parameters');
  91.   my $param1 = 10;
  92.   my $param2 = SOAP::Data->name('myparam' => 12);
  93.   my $result = $s->autobind($param1, $param2)->result;
  94.   ok($result == $param1 && $param2->value == 24); 
  95.  
  96.   print "Header manipulation test(s)...\n";
  97.   $a = $s->addheader(2, SOAP::Header->name(my => 123)); 
  98.   ok(ref $a->header && $a->header->{my} eq '123123'); 
  99.   ok($a->headers eq '123123'); 
  100.  
  101.   print "Echo untyped data test(s)...\n";
  102.   $a = $s->echotwo(11, 12);
  103.   ok($a->result == 11); 
  104.  
  105.   print "mustUnderstand test(s)...\n";
  106.   $s->echo(SOAP::Header->name(somethingelse => 123)
  107.                        ->mustUnderstand(1));
  108.   ok($s->call->faultstring =~ /[Hh]eader has mustUnderstand attribute/);
  109.  
  110.   if ($proxy =~ /^http/) {
  111.     ok($s->transport->status =~ /^500/);
  112.   } else {
  113.     skip('No Status checks for non http protocols on server side' => undef);
  114.   }
  115.  
  116.   $s->echo(SOAP::Header->name(somethingelse => 123)
  117.                        ->mustUnderstand(1)
  118.                        ->actor('http://notme/'));
  119.   ok(!defined $s->call->fault);
  120.  
  121.   print "dispatch_from test(s)...\n";
  122.   eval "use SOAP::Lite
  123.     uri => 'http://my.own.site.com/My/Examples',
  124.     dispatch_from => ['A', 'B'],
  125.     proxy => '$proxy',
  126.   ; 1" or die;
  127.  
  128.   eval { C->c };
  129.   ok($@ =~ /Can't locate object method "c"/);
  130.  
  131.   eval { A->a };
  132.   ok(!$@ && SOAP::Lite->self->call->faultstring =~ /Failed to access class \(A\)/);
  133.  
  134.   eval "use SOAP::Lite
  135.     dispatch_from => 'A',
  136.     uri => 'http://my.own.site.com/My/Examples',
  137.     proxy => '$proxy',
  138.   ; 1" or die;
  139.  
  140.   eval { A->a };
  141.   ok(!$@ && SOAP::Lite->self->call->faultstring =~ /Failed to access class \(A\)/);
  142.  
  143.   print "Object autobinding and SOAP:: prefix test(s)...\n";
  144.  
  145.   eval "use SOAP::Lite +autodispatch =>
  146.     uri => 'urn:', proxy => '$proxy'; 1" or die;
  147.  
  148.   ok(SOAP::Lite->autodispatched);
  149.  
  150.   eval { SOAP->new(1) };
  151.   ok($@ =~ /^URI is not specified/);
  152.  
  153.   eval "use SOAP::Lite +autodispatch =>
  154.     uri => 'urn:/A/B', proxy => '$proxy'; 1" or die;
  155.  
  156.   # should call My::PingPong, not A::B
  157.   my $p = My::PingPong->SOAP::new(10);
  158.   ok(ref $p && $p->SOAP::next+1 == $p->value);
  159.  
  160.   # forget everything
  161.   SOAP::Lite->self(undef); 
  162.  
  163.   $s = SOAP::Lite
  164.     -> uri('urn:/My/PingPong')                
  165.     -> proxy($proxy)
  166.   ;
  167.  
  168.   # should return object EXACTLY as after My::PingPong->SOAP::new(10)
  169.   $p = $s->SOAP::new(10); 
  170.   ok(ref $p && $s->SOAP::next($p)+1 == $p->value);
  171.  
  172.   print "VersionMismatch test(s)...\n";
  173.  
  174.   {
  175.     local $SOAP::Constants::NS_ENV = 'http://schemas.xmlsoap.org/new/envelope/';
  176.     my $s = SOAP::Lite
  177.       -> uri('http://my.own.site.com/My/Examples')                
  178.       -> proxy($proxy)
  179.       -> on_fault(sub{})
  180.     ;
  181.     $r = $s->dosomething;
  182.     ok(ref $r && $r->faultcode =~ /:VersionMismatch/);
  183.   }
  184.  
  185.   print "Objects-by-reference test(s)...\n";
  186.  
  187.   eval "use SOAP::Lite +autodispatch =>
  188.     uri => 'urn:', proxy => '$proxy'; 1" or die;
  189.  
  190.   print "Session iterator\n";
  191.   $r = My::SessionIterator->new(10); 
  192.   if (!ref $r || exists $r->{id}) {
  193.     ok(ref $r && $r->next && $r->next == 11);
  194.   } else {
  195.     skip('No persistent objects (o-b-r) supported on server side' => undef);
  196.   }
  197.  
  198.   print "Persistent iterator\n";
  199.   $r = My::PersistentIterator->new(10); 
  200.   if (!ref $r || exists $r->{id}) {
  201.     my $first = ($r->next, $r->next) if ref $r;   
  202.  
  203.     $r = My::PersistentIterator->new(10);
  204.     ok(ref $r && $r->next && $r->next == $first+2);
  205.   } else {
  206.     skip('No persistent objects (o-b-r) supported on server side' => undef);
  207.   }
  208.  
  209.   { local $^W; # disable warnings about deprecated AUTOLOADing for nonmethods
  210.     print "Parameters-by-name test(s)...\n";
  211.     print "You can see warning about AUTOLOAD for non-method...\n" if $^W;
  212.  
  213.     eval "use SOAP::Lite +autodispatch => 
  214.       uri => 'http://my.own.site.com/My/Parameters', proxy => '$proxy'; 1" or die;
  215.  
  216.     my @parameters = (
  217.       SOAP::Data->name(b => 222), 
  218.       SOAP::Data->name(c => 333), 
  219.       SOAP::Data->name(a => 111)
  220.     );
  221.  
  222.     # switch to 'main' package, because nonqualified methods should be there
  223.     ok(main::byname(@parameters) eq "a=111, b=222, c=333");
  224.  
  225.     ok(main::bynameororder(@parameters) eq "a=111, b=222, c=333");
  226.  
  227.     ok(main::bynameororder(111, 222, 333) eq "a=111, b=222, c=333");
  228.  
  229.     print "Function call test(s)...\n";
  230.     print "You can see warning about AUTOLOAD for non-method...\n" if $^W;
  231.     ok(main::echo(11) == 11);
  232.   }
  233.  
  234.   print "SOAPAction test(s)...\n";
  235.   if ($proxy =~ /^tcp:/) {
  236.     for (1..2) {skip('No SOAPAction checks for tcp: protocol on server side' => undef)}
  237.   } else {
  238.     my $s = SOAP::Lite
  239.       -> uri('http://my.own.site.com/My/Examples')                
  240.       -> proxy($proxy)
  241.       -> on_action(sub{'""'})
  242.     ;
  243.     ok($s->getStateName(1)->result eq 'Alabama'); 
  244.  
  245.     $s->on_action(sub{'"wrong_SOAPAction_here"'});
  246.     ok($s->getStateName(1)->faultstring =~ /SOAPAction shall match/); 
  247.   }
  248.  
  249.   print "UTF8 test(s)...\n";
  250.   if (!eval "pack('U*', 0)") {
  251.     for (1) {skip('No UTF8 test. No support for pack("U*") modifier' => undef)}
  252.   } else {
  253.     $s = SOAP::Lite
  254.       -> uri('http://my.own.site.com/My/Parameters')                
  255.       -> proxy($proxy);
  256.  
  257.      my $latin1 = '»α¿óÑΓ';
  258.      my $utf8 = pack('U*', unpack('C*', $latin1));
  259.      my $result = $s->echo(SOAP::Data->type(string => $utf8))->result;
  260.  
  261.      ok(pack('U*', unpack('C*', $result)) eq $utf8);
  262.   }
  263.  
  264.   {
  265.     my $on_fault_was_called = 0;
  266.     print "Die in server method test(s)...\n";
  267.     my $s = SOAP::Lite
  268.       -> uri('http://my.own.site.com/My/Parameters')                
  269.       -> proxy($proxy)
  270.       -> on_fault(sub{$on_fault_was_called++;return})
  271.     ;
  272.     ok($s->die_simply()->faultstring =~ /Something bad/);
  273.     ok($on_fault_was_called > 0);
  274.     my $detail = $s->die_with_object()->dataof(SOAP::SOM::faultdetail . '/[1]');
  275.     ok($on_fault_was_called > 1);
  276.     ok(ref $detail && $detail->name =~ /(^|:)something$/);
  277.  
  278.     # get Fault as hash of subelements
  279.     my $fault = $s->die_with_fault()->fault;
  280.     ok($fault->{faultcode} =~ ':Server.Custom');
  281.     ok($fault->{faultstring} eq 'Died in server method');
  282.     ok(ref $fault->{detail}->{BadError} eq 'BadError');
  283.     ok($fault->{faultactor} eq 'http://www.soaplite.com/custom');
  284.   }
  285.  
  286.   print "Method with attributes test(s)...\n";
  287.  
  288.   $s = SOAP::Lite
  289.     -> uri('urn:/My/Examples')                
  290.     -> proxy($proxy)
  291.   ;
  292.  
  293.   ok($s->call(SOAP::Data->name('getStateName')->attr({xmlns => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
  294.  
  295.   print "Call with empty uri test(s)...\n";
  296.   $s = SOAP::Lite
  297.     -> uri('')                
  298.     -> proxy($proxy)
  299.   ;
  300.  
  301.   ok($s->getStateName(1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
  302.  
  303.   ok($s->call('a:getStateName' => 1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
  304.  
  305.   print "Number of parameters test(s)...\n";
  306.  
  307.   $s = SOAP::Lite
  308.     -> uri('http://my.own.site.com/My/Parameters')                
  309.     -> proxy($proxy)
  310.   ;
  311.   { my @all = $s->echo->paramsall; ok(@all == 0) }
  312.   { my @all = $s->echo(1)->paramsall; ok(@all == 1) }
  313.   { my @all = $s->echo((1) x 10)->paramsall; ok(@all == 10) }
  314.  
  315.   print "Memory refresh test(s)...\n";
  316.  
  317.   # Funny test. 
  318.   # Let's forget about ALL settings we did before with 'use SOAP::Lite...'
  319.   SOAP::Lite->self(undef); 
  320.   ok(!defined SOAP::Lite->self);
  321.  
  322.   print "Call without uri test(s)...\n";
  323.   $s = SOAP::Lite
  324.     -> proxy($proxy)
  325.   ;
  326.  
  327.   ok($s->getStateName(1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
  328.  
  329.   print "Different settings for method and namespace test(s)...\n";
  330.  
  331.   ok($s->call(SOAP::Data
  332.     ->name('getStateName')
  333.     ->attr({xmlns => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
  334.  
  335.   ok($s->call(SOAP::Data
  336.     ->name('a:getStateName')
  337.     ->uri('urn:/My/Examples'), 1)->result eq 'Alabama');
  338.  
  339.   ok($s->call(SOAP::Data
  340.     ->name('getStateName')
  341.     ->uri('urn:/My/Examples'), 1)->result eq 'Alabama');
  342.  
  343.   ok($s->call(SOAP::Data
  344.     ->name('a:getStateName')
  345.     ->attr({'xmlns:a' => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
  346.  
  347.   eval { $s->call(SOAP::Data->name('a:getStateName')) };
  348.  
  349.   ok($@ =~ /Can't find namespace for method \(a:getStateName\)/);
  350.  
  351.   $s->serializer->namespaces->{'urn:/My/Examples'} = '';
  352.  
  353.   ok($s->getStateName(1)->result eq 'Alabama');
  354.  
  355.   eval "use SOAP::Lite 
  356.     uri => 'urn:/My/Examples', proxy => '$proxy'; 1" or die;
  357.  
  358.   print "Global settings test(s)...\n";
  359.   $s = new SOAP::Lite;
  360.  
  361.   ok($s->getStateName(1)->result eq 'Alabama');
  362.  
  363.   SOAP::Trace->import(transport => 
  364.     sub {$_[0]->content_type('something/wrong') if UNIVERSAL::isa($_[0] => 'HTTP::Request')}
  365.   );
  366.  
  367.   if ($proxy =~ /^tcp:/) {
  368.     skip('No Content-Type checks for tcp: protocol on server side' => undef);
  369.   } else {
  370.     ok($s->getStateName(1)->faultstring =~ /Content-Type must be/);
  371.   }
  372. }
  373.  
  374. # ======================================================================
  375.  
  376. 1;
  377.  
  378. __END__
  379.  
  380. =head1 NAME
  381.  
  382. SOAP::Test - Test framework for SOAP::Lite
  383.  
  384. =head1 SYNOPSIS
  385.  
  386.   use SOAP::Test;
  387.  
  388.   SOAP::Test::Server::run_for('http://localhost/cgi-bin/soap.cgi');
  389.  
  390. =head1 DESCRIPTION
  391.  
  392. SOAP::Test provides simple framework for testing server implementations.
  393. Specify your address (endpoint) and run provided tests against your server.
  394. See t/1*.t for examples.
  395.  
  396. =head1 COPYRIGHT
  397.  
  398. Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
  399.  
  400. This library is free software; you can redistribute it and/or modify
  401. it under the same terms as Perl itself.
  402.  
  403. =head1 AUTHOR
  404.  
  405. Paul Kulchenko (paulclinger@yahoo.com)
  406.  
  407. =cut
  408.