branch-1-6/examples/biblio/biblio_soap.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # This was actually a part of the test suite - but because it starts
   4 # an external process it was safer not to use it as a test (the process
   5 # could be left running if an error occurs).
   6 #
   7 # It is an example of a TCP-based SOAP exchange.
   8 #
   9
  10 use strict;
  11 eval { require SOAP::Lite;
  12 };
  13 if( $@ ){
  14     die("must have SOAP::Lite installed to run this script");
  15 }
  16
  17 use vars qw($NUMTESTS);
  18
  19 my $error;
  20
  21 BEGIN {
  22     # to handle systems with no installed Test module
  23     # we include the t dir (where a copy of Test.pm is located)
  24     # as a fallback
  25     eval { require Test; };
  26     $error = 0;
  27     if( $@ ) {
  28         use lib 't';
  29     }
  30     use Test;
  31     plan tests => 10;
  32 }
  33
  34 my $testnum;
  35 my $verbose = 0;
  36
  37 use Bio::Biblio;
  38
  39 # --- launch a testing SOAP server
  40 my ($pid, $port, $max_port);
  41 $port = 4444;
  42 $max_port = $port + 100;
  43 if ($pid = fork) {
  44     # parent here
  45
  46     sleep 1;
  47     my $biblio = new Bio::Biblio (-location => "tcp://localhost:$port",
  48                                   -namespace => 'soap_server');
  49
  50     ok ($biblio->get_count, '43');
  51     ok ($biblio->get_by_id ('X'), 'X');
  52     ok ($biblio->find ('a,b','c,d')->get_collection_id, 'a,b,c,d');
  53     ok ($biblio->find (['x', 'y'], ['u', 'v'])->get_collection_id, 'x,y,u,v');
  54
  55     ok ( eval { join (',', @{ $biblio->find ('AAA')->get_all_ids }) }, 'AAA'); print STDERR $@ if $@;
  56
  57     ok ( eval { join (',', @{ $biblio->find ('XXX')->get_all }) }, 'XXX'); print STDERR $@ if $@;
  58
  59     ok ( eval { $biblio->find (46)->has_next }, 1); print STDERR $@ if $@;
  60
  61     ok ( eval { $biblio->find ('BBB')->get_next }, 'BBB'); print STDERR $@ if $@;
  62
  63     ok ( eval { join (',', @{ $biblio->find ('CCC')->get_more (3) }) }, 'CCC,CCC,CCC'); print STDERR $@ if $@;
  64
  65     ok ( eval { $biblio->find (46)->exists }, 0); print STDERR $@ if $@;
  66
  67
  68     # clean-up the running server
  69     kill 9, $pid if defined $pid;
  70     print "    SOAP server $pid killed\n";
  71
  72 } elsif (defined $pid) {
  73     # child here - a testing SOAP server
  74
  75     package soap_server;
  76     use strict;
  77     use SOAP::Transport::TCP;
  78     my $daemon;
  79     while ($port < $max_port) {
  80         eval {
  81             $daemon = SOAP::Transport::TCP::Server
  82                 -> new (LocalAddr => 'localhost', LocalPort => $port, Listen => 5, Reuse => 1)
  83                     -> dispatch_to('soap_server');
  84         };
  85         last unless $@;
  86         $port++;
  87     }
  88     print "    Contact to SOAP server at ", join(':', $daemon->sockhost, $daemon->sockport), " (server PID: $$)\n";
  89     $daemon->handle;
  90
  91     sub getBibRefCount { shift;  return 43; }
  92     sub getById { shift; return shift; }
  93     sub find {
  94         my ($self, $keywords, $attrs) = @_;
  95         return join (',', (@{ $keywords }, @{ $attrs })) if $attrs;
  96         return join (',', @{ $keywords });
  97     }
  98     sub getAllIDs { shift; return [ shift ] }
  99     sub getAllBibRefs { shift; return [ shift ] }
 100     sub hasNext { return SOAP::Data->type (boolean => 'true'); }
 101     sub getNext { shift; return [ '1', shift]; }
 102     sub getMore {
 103         my ($self, $id, $how_many) = @_;
 104         my @result = ('1');
 105         push (@result, $id) for (1..$how_many);
 106         return \@result;
 107     }
 108     sub exists { return SOAP::Data->type (boolean => '0'); }
 109     sub destroy {}
 110
 111     package main;
 112
 113 } else {
 114         # fork failed
 115         print STDERR "Testing SOAP services FAILED: $!.\n";
 116     }