The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/bin/perl
use utf8;
#
# This was actually a part of the test suite - but because it starts
# an external process it was safer not to use it as a test (the process
# could be left running if an error occurs).
#
# It is an example of a TCP-based SOAP exchange.
#

use strict;
eval { require SOAP::Lite;
};
if( $@ ){
    die("must have SOAP::Lite installed to run this script");
}

use vars qw($NUMTESTS);

my $error;


BEGIN {
    # to handle systems with no installed Test module
    # we include the t dir (where a copy of Test.pm is located)
    # as a fallback
    eval { require Test; };
    $error = 0;
    if( $@ ) {
        use lib 't';
    }
    use Test;
    plan tests => 10;
}

my $testnum;
my $verbose = 0;

use Bio::Biblio;

# --- launch a testing SOAP server
my ($pid, $port, $max_port);
$port = 4444;
$max_port = $port + 100;
if ($pid = fork) {
    # parent here

    sleep 1;
    my $biblio = new Bio::Biblio (-location => "tcp://localhost:$port",
                                  -namespace => 'soap_server');

    ok ($biblio->get_count, '43');
    ok ($biblio->get_by_id ('X'), 'X');
    ok ($biblio->find ('a,b','c,d')->get_collection_id, 'a,b,c,d');
    ok ($biblio->find (['x', 'y'], ['u', 'v'])->get_collection_id, 'x,y,u,v');

    ok ( eval { join (',', @{ $biblio->find ('AAA')->get_all_ids }) }, 'AAA'); print STDERR $@ if $@;

    ok ( eval { join (',', @{ $biblio->find ('XXX')->get_all }) }, 'XXX'); print STDERR $@ if $@;

    ok ( eval { $biblio->find (46)->has_next }, 1); print STDERR $@ if $@;

    ok ( eval { $biblio->find ('BBB')->get_next }, 'BBB'); print STDERR $@ if $@;

    ok ( eval { join (',', @{ $biblio->find ('CCC')->get_more (3) }) }, 'CCC,CCC,CCC'); print STDERR $@ if $@;

    ok ( eval { $biblio->find (46)->exists }, 0); print STDERR $@ if $@;


    # clean-up the running server
    kill 9, $pid if defined $pid;
    print "    SOAP server $pid killed\n";

} elsif (defined $pid) {
    # child here - a testing SOAP server

    package soap_server;
    use strict;
    use SOAP::Transport::TCP;
    my $daemon;
    while ($port < $max_port) {
        eval {
            $daemon = SOAP::Transport::TCP::Server
                -> new (LocalAddr => 'localhost', LocalPort => $port, Listen => 5, Reuse => 1)
                    -> dispatch_to('soap_server');
        };
        last unless $@;
        $port++;
    }
    print "    Contact to SOAP server at ", join(':', $daemon->sockhost, $daemon->sockport), " (server PID: $$)\n";
    $daemon->handle;

    sub getBibRefCount { shift;  return 43; }
    sub getById { shift; return shift; }
    sub find {
        my ($self, $keywords, $attrs) = @_;
        return join (',', (@{ $keywords }, @{ $attrs })) if $attrs;
        return join (',', @{ $keywords });
    }
    sub getAllIDs { shift; return [ shift ] }
    sub getAllBibRefs { shift; return [ shift ] }
    sub hasNext { return SOAP::Data->type (boolean => 'true'); }
    sub getNext { shift; return [ '1', shift]; }
    sub getMore {
        my ($self, $id, $how_many) = @_;
        my @result = ('1');
        push (@result, $id) for (1..$how_many);
        return \@result;
    }
    sub exists { return SOAP::Data->type (boolean => '0'); }
    sub destroy {}

    package main;

} else {
    # fork failed
    print STDERR "Testing SOAP services FAILED: $!.\n";
}