XML::Compile::SOAP::Daemon namesservice example

README

==== README to examples/namesservice/

This directory demonstrates the implementation of a SOAP server, mimicing
the behavior of an existing service.  The XML::Compile::SOAP distribution
demonstrates various ways to create clients for this same service.  Here,
we focus on the server implementation.

The original service published a nice WSDL file, and a separate schema,
which have been beautified a bit but nothing more.

 . namesservice.wsdl
   The WSDL file, describing the service.

 . namesservice.xsd
   The Schema file, describing the data types transmitted.

To run this example, first start the server
  ./server.pl -vvv

and then run the client
  ./client.pl

Please contribute.

client.pl

#!/usr/bin/perl
# Client which demonstrates the functionality of the server.  First start
# the server, and then call the client:
#     ./server.pl --verbose=2
#     ./client.pl

# This scripts shows 3 SOAP calls which are defined via a WSDL, and
# one which is created by hand.

# This file is also included as example in the XML::Compile::SOAP
# distribution.  There, rpc-literal, rpc-encoded and shorter versions
# are shown as well.

# Thanks to Thomas Bayer, for providing this example service
#    See http://www.thomas-bayer.com/names-service/

# Author: Mark Overmeer, Januari 24 2009
# Using:  XML::Compile               1.00
#         XML::Compile::SOAP         2.00
#         XML::Compile::SOAP::Daemon 2.00
# Copyright by the Author, under the terms of Perl itself.
# Feel invited to contribute your examples!

# Of course, all Perl programs start like this!
use warnings;
use strict;

# constants, change this if needed (also in the server script)
use constant SERVERHOST => 'localhost';
use constant SERVERPORT => '8877';

# we need to redirect the endpoint as specified in the WSDL to our
# own server.
my $service_address = 'http://'.SERVERHOST.':'.SERVERPORT;

# To make Perl find the modules without the package being installed.
use lib '../../lib', '.';

# All the used XML stuff
use XML::Compile::WSDL11;
use XML::Compile::Transport::SOAPHTTP;
use XML::Compile::SOAP11;

# Other useful modules
use Data::Dumper;          # Data::Dumper is your friend.
$Data::Dumper::Indent = 1;

# Errors are reported via Log::Report, normal user interaction not.
use Log::Report   'example', syntax => 'SHORT';

use Getopt::Long  qw/:config no_ignore_case bundling/;
use List::Util    qw/first/;

my $format_list;
format =
   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
   $format_list
.

# Forward declarations
sub show_trace($$);
sub get_countries();
sub get_name_info();
sub get_names_in_country();
sub get_name_count();
sub try_stub();

#### MAIN

#
# Some standard command-line processing
#

my $mode = 0;

GetOptions
 # 3 ways to set the verbosity for Log::Report dispatchers
   'v+'        => \$mode  # -v -vv -vvv
 , 'verbose=i' => \$mode  # --verbose=2  (0..3)
 , 'mode=s'    => \$mode  # --mode=DEBUG (DEBUG,ASSERT,VERBOSE,NORMAL)
 , 'server=s'  => \$service_address
   or die "stopped\n";

die "No filenames expected on the command-line"
   if @ARGV;

# XML::Compile::* uses Log::Report.
dispatcher PERL => 'default', mode => $mode;

#
# For nice user interaction; nothing to do with SOAP
#

use Term::ReadLine;
my $term = Term::ReadLine->new('namesservice');

#
# Let all calls share the transport object
# If you need an SSL connection, or other complex transport configuration,
# you can provide your own preconfigured user_agent (LWP::UserAgent object).
#

my $transporter = XML::Compile::Transport::SOAPHTTP->new
  ( address    => $service_address
# , user_agent => ...
  );

my $http = $transporter->compileClient;

# or, when you need to change something to the message sent:
#   my $http = $transporter->compileClient(hook => \&transport_hook); 
# see implementation of transport_hook() far below.

#
# Get the WSDL and Schema definitions
#

my $wsdl = XML::Compile::WSDL11->new('namesservice.wsdl');
$wsdl->importDefinitions('namesservice.xsd');

#
# Pick one of these tests
#

my $answer = '';
while(lc $answer ne 'q')
{
    print <<__SELECTOR;

    Which call do you like to see:
      1) getCountries
      2) getNameInfo
      3) getNamesInCountry
      4) getNameCount, not defined by WSDL
      5) tryStub, in WSDL but not implemented
      6) request WSDL file
      q) quit demo
__SELECTOR

    print <<__HELP unless $mode;
    (Run this script with -v to get some stats.  -vvv shows much more)
__HELP
    print "\n";

    $answer = $term->readline("Pick one of above [1-6,q] ");
    chomp $answer;

       if($answer eq '1') { get_countries() }
    elsif($answer eq '2') { get_name_info()  }
    elsif($answer eq '3') { get_names_in_country() }
    elsif($answer eq '4') { get_name_count() }
    elsif($answer eq '5') { try_stub() }
    elsif($answer eq '6') { get_wsdl() }
    elsif(lc $answer ne 'q' && length $answer)
    {   print "Illegal choice\n";
    }
}

exit 0;

sub show_trace($$)
{   my ($answer, $trace) = @_;
    $mode > 0 or return;

    $trace->printTimings;
    $trace->printRequest;
    $trace->printResponse;

    print Dumper $answer
        if $mode > 1;
}

#
# procedure getCountries
#

sub get_countries()
{   my $getCountries = $wsdl->compileClient
      ( 'getCountries'
      , transporter => $http
      );

    my ($answer, $trace) = $getCountries->();
    show_trace $answer, $trace;

    if(my $fault_raw = $answer->{Fault})
    {   my $fault_nice = $answer->{$fault_raw->{_NAME}};
        warning __x"Cannot get list of countries: {reason}"
           , reason => $fault_nice->{reason};
        return;
    }

    my $countries = $answer->{parameters}{country} || [];

    print "getCountries() lists ",scalar(@$countries)," countries:\n";
    foreach my $country (sort @$countries)
    {   print "   $country\n";
    }
}

#
# Second example
#

sub get_name_info()
{
    my $name = $term->readline("Personal name for info: ");
    chomp $name;

    length $name or return;

    my $getNameInfo = $wsdl->compileClient
      ( 'getNameInfo'
      , transport => $http
      );

    my ($answer, $trace) = $getNameInfo->(name => $name);
    show_trace $answer, $trace;

    unless(defined $answer)
    {   warning __x"No answer received";
        return;
    }

    if($answer->{Fault})
    {   warning __x"Lookup for '{name}' failed: {text}"
          , name => $name, text => $answer->{Fault}{faultstring};
        return;
    }

    my $nameinfo = $answer->{parameters}{nameinfo};
    print "The name '$nameinfo->{name}' is\n";
    print "    male: ", ($nameinfo->{male}   ? 'yes' : 'no'), "\n";
    print "  female: ", ($nameinfo->{female} ? 'yes' : 'no'), "\n";
    print "  gender: $nameinfo->{gender}\n" if $nameinfo->{gender};
    print "and used in countries:\n";

    my $countries = $nameinfo->{countries}{country} || [];
    $format_list = join ', ', @$countries;
    write;
}

#
# Third example
#

sub get_names_in_country()
{
    my $getCountries      = $wsdl->compileClient
      ( 'getCountries'
      , transport => $http
      );

    my $getNamesInCountry = $wsdl->compileClient
     ( 'getNamesInCountry'
     , transport  => $http
     );

    my ($answer1, $trace1) = $getCountries->();
    show_trace $answer1, $trace1;

    if($answer1->{Fault})
    {   warning __x"cannot get countries: {text}"
           , text => $answer1->{Fault}{faultstring};
        return;
    }

    my $countries = $answer1->{parameters}{country};

    my $country;
    while(1)
    {   $country = $term->readline("Most common names in which country? ");
        chomp $country;
        $country eq '' or last;
        print "  please specify a country name.\n";
    }

    # find the name case-insensitive in the list of available countries
    my $name = first { /^\Q$country\E$/i } @$countries;

    unless($name)
    {   $name = 'other countries';
        print "Cannot find name '$country', defaulting to '$name'\n";
        print "Available countries are:\n";
        $format_list = join ', ', @$countries;
        write;
    }

    print "Most common names in $name:\n";
    my ($answer2, $trace2) = $getNamesInCountry->(country => $name);
    show_trace $answer2, $trace2;

    # print $trace2->response->as_string;
    if(my $fault2 = $answer2->{Fault})
    {   warning __x"cannot get names in country:\n  {code}\n  {text}"
          , code => $fault2->{faultcode}, text => $fault2->{faultstring};
        return;
    }

    my $names    = $answer2->{parameters}{name};
    unless($names)
    {   print "No data available for country `$name'\n";
        return;
    }

    $format_list = join ', ', @$names;
    write;
}

#
# This next example demonstrates how to use SOAP without WSDL
#

sub get_name_count()
{
    ### if you execute the following lines in the initiation phase of
    # your program, you can reuse it.  For clarity of the demo, all
    # initiations are made on this unusual spot.
    #
    use MyExampleCalls;
    $wsdl->importDefinitions(\@my_additional_schemas);

    my $soap11 = XML::Compile::SOAP11::Client->new(schemas => $wsdl);
    my $encode = $soap11->compileMessage(SENDER   => @get_name_count_input);
    my $decode = $soap11->compileMessage(RECEIVER => @get_name_count_output);

    # you could use the $http object, defined earlier, to share the
    # connection, but this is more fun ;-)
    my $send   = $transporter->compileClient
      ( soap      => $soap11
      , action    => '#getNameCount' # optional soapAction in HTTP header
      );

    my $getNameCount = $soap11->compileClient
      ( name      => 'getNameCount'  # symbolic name only for trace and errors
      , encode    => $encode
      , decode    => $decode
      , transport => $send
      );
    #
    ### end of re-usable structures

    my $country;
    while(1)
    {   $country = $term->readline("Number of names in which country? ");
        chomp $country;
        $country eq '' or last;
        print "  please specify a country name.\n";
    }

    my ($answer, $trace) = $getNameCount->(request => {country => $country});
    show_trace $answer, $trace;

    if($answer->{Fault})
    {   warning "cannot get names in country: {text}"
           , text => $answer->{Fault}{faultstring};
        return;
    }

    print "Country $country has $answer->{answer}{count} names defined\n";
}

#
# procedure tryStub
# added to the WSDL by hand, to demonstrate what happens when the
# server does not implement a procedure which is listed in the
# interface.
#

sub try_stub()
{   my $try_stub = $wsdl->compileClient('tryStub', transporter => $http);

    my ($answer, $trace) = $try_stub->();

    my $fault = $answer->{Fault}
        or panic "should return a fault";

    # print $trace->response->as_string;

    print __x"the stub answers with the (expected) error:\n  {reason}\n"
      , reason => $fault->{faultstring};

}

#
# get_wsdl
# Many SOAP servers publish a WSDL. This is not provided by the
# SOAP interface, but an HTTP server "trick".
#

sub get_wsdl()
{   use LWP::UserAgent;
    my $ua   = LWP::UserAgent->new;
    my $resp = $ua->get("$service_address?WSDL");
    if($resp)
    {    print "received ".$resp->as_string;
    }
    else
    {   print "no WSDL file published\n";
    }
}

#
# transport_hook() demonstrates how the HTTP message can be modified
# just before transmission/reply checked before decoding.
#

sub transport_hook($$$)
{   my ($request, $trace, $transp) = @_;   # $transp = ::SOAPHTTP object

    # take the unlaying transport layer
    my $ua = $transp->userAgent;
    trace "hook ua " . Dumper($ua);

    # do something with the message before it's being send
    my $len = length($request->content);
    $request->header( My_Header => "Added Header msg length $len" );
    trace "hook request " . Dumper($request);
    trace "hook request content " . $request->content;

    # call the remote server
    my $response = $ua->request($request);

    # modify/check the received answer
    trace "hook response " . Dumper($response);

    # back to normal SOAP
    $response;
};

MyExampleCalls.pm

# Copyrights 2007-2012 by Mark Overmeer.
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.00.

# This pm file demonstrates how a client-side and server-side definition
# of a message can be created, in case there is no WSDL for the SOAP
# interface.  This same module is used in both client.pl and server.pl.

package MyExampleCalls;
use vars '$VERSION';
$VERSION = '3.01';

use base qw/Exporter/;

use XML::Compile::Util  qw/pack_type SCHEMA2001/;

our @EXPORT = qw/
    @my_additional_schemas
    @get_name_count_input @get_name_count_output
  /;

# You may have some types you need to load as well.  You can use filenames
# or strings, or... anything XML::Compile::dataToXML() accepts.

my $myns     = 'http://my-test-ns';
my $schemans = SCHEMA2001;

our @my_additional_schemas = ( <<__XML );
<schema
  xmlns="$schemans"
  targetNamespace="$myns" xmlns:me="$myns"
  elementFormDefault="qualified"
  attributeFormDefault="unqualified">

<!-- this is the first (and only) body element for the message which
     is send from client to the server
  -->

<element name="getNameCount">
  <complexType>
    <sequence>
      <element name="country" type="string"/>
    </sequence>
  </complexType>
</element>

<!-- the only body element as answer
  -->

<element name="getNameCountResponse">
  <complexType>
    <sequence>
      <element name="count" type="int"/>
    </sequence>
  </complexType>
</element>

</schema>
__XML

# WSDL term 'input' means: input for the server; the request which the
# client will sends to the server.
# In this example, the lines which define the message --to be specified
# with method XML::Compile::SOAP::compileMessage()-- are listed.

our @get_name_count_input =
 ( body => [ request =>  pack_type($myns, 'getNameCount') ]
 );

# WSDL term 'output': send by the server, as response to the client's
# request.

our @get_name_count_output =
 ( body => [ answer => pack_type($myns, 'getNameCountResponse') ]
 );

1;

MyExampleData.pm

# Copyrights 2007-2012 by Mark Overmeer.
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.00.
use warnings;
use strict;

package MyExampleData;
use vars '$VERSION';
$VERSION = '3.01';

use base 'Exporter';

our @EXPORT = qw/$namedb/;

our $namedb =
 { Netherlands =>
    {   male  => [ qw/Mark Tycho Thomas/ ]
    , female  => [ qw/Cleo Marjolein Suzanne/ ]
    }
 , Austria     =>
    {   male => [ qw/Thomas Samuel Josh/ ]
    , female => [ qw/Barbara Susi/ ]
    }
 ,German       =>
    {   male => [ qw/Leon Maximilian Lukas Felix Jonas/ ]
    , female => [ qw/Leonie Lea Laura Alina Emily/ ]
    }
 };

1;

namesservice.wsdl

<?xml version="1.0" encoding="UTF-8"?>
<!-- Published by JAX-WS RI at http://jax-ws.dev.java.net. RI's version is JAX-WS RI 2.1.2-b05-RC1. -->
<definitions
   xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
   xmlns:tns="http://namesservice.thomas_bayer.com/"
   xmlns:xsd="http://www.w3.org/2001/XMLSchema"
   xmlns="http://schemas.xmlsoap.org/wsdl/"
   targetNamespace="http://namesservice.thomas_bayer.com/"
   name="NamesServiceService">
  <types>
    <xsd:schema>
      <xsd:import
         namespace="http://namesservice.thomas_bayer.com/"
         schemaLocation="http://www.thomas-bayer.com:80/names-service/soap?xsd=1"/>
    </xsd:schema>
  </types>

  <message name="getCountries">
    <part name="parameters" element="tns:getCountries"/>
  </message>
  <message name="getCountriesResponse">
    <part name="parameters" element="tns:getCountriesResponse"/>
  </message>

  <message name="getNamesInCountry">
    <part name="parameters" element="tns:getNamesInCountry"/>
  </message>
  <message name="getNamesInCountryResponse">
    <part name="parameters" element="tns:getNamesInCountryResponse"/>
  </message>

  <message name="getNameInfo">
    <part name="parameters" element="tns:getNameInfo"/>
  </message>
  <message name="getNameInfoResponse">
    <part name="parameters" element="tns:getNameInfoResponse"/>
  </message>

  <message name="tryStub">
    <!-- part name="parameters" element="tns:getNameInfo" -->
  </message>
  <message name="tryStubResponse">
    <part name="parameters" element="tns:getNameInfoResponse"/>
  </message>

  <portType name="NamesService">
    <operation name="getCountries">
      <input message="tns:getCountries"/>
      <output message="tns:getCountriesResponse"/>
    </operation>

    <operation name="getNamesInCountry">
      <input message="tns:getNamesInCountry"/>
      <output message="tns:getNamesInCountryResponse"/>
    </operation>

    <operation name="getNameInfo">
      <input message="tns:getNameInfo"/>
      <output message="tns:getNameInfoResponse"/>
    </operation>

    <operation name="tryStub">
      <input message="tns:tryStub"/>
      <output message="tns:tryStubResponse"/>
    </operation>
  </portType>

  <binding name="NamesServicePortBinding" type="tns:NamesService">
    <soap:binding
       transport="http://schemas.xmlsoap.org/soap/http"
       style="document"/>

    <operation name="getCountries">
      <soap:operation soapAction=""/>
      <input>
        <soap:body use="literal"/>
      </input>
      <output>
        <soap:body use="literal"/>
      </output>
    </operation>

    <operation name="getNamesInCountry">
      <soap:operation soapAction=""/>
      <input>
        <soap:body use="literal"/>
      </input>
      <output>
        <soap:body use="literal"/>
      </output>
    </operation>

    <operation name="getNameInfo">
      <soap:operation soapAction=""/>
      <input>
        <soap:body use="literal"/>
      </input>
      <output>
        <soap:body use="literal"/>
      </output>
    </operation>

    <operation name="tryStub">
      <soap:operation soapAction=""/>
      <input>
        <soap:body use="literal"/>
      </input>
      <output>
        <soap:body use="literal"/>
      </output>
    </operation>
  </binding>

  <service name="NamesServiceService">
    <port name="NamesServicePort" binding="tns:NamesServicePortBinding">
      <soap:address
         location="http://www.thomas-bayer.com:80/names-service/soap"/>
    </port>
  </service>

</definitions>

namesservice.xsd

<?xml version="1.0" encoding="UTF-8"?>
<!-- Published by JAX-WS RI at http://jax-ws.dev.java.net. RI's version is JAX-WS RI 2.1.2-b05-RC1. -->
<xs:schema xmlns:tns="http://namesservice.thomas_bayer.com/"
   xmlns:xs="http://www.w3.org/2001/XMLSchema" version="1.0"
   targetNamespace="http://namesservice.thomas_bayer.com/">

<xs:element name="getCountries"
   type="tns:getCountries"/>

<xs:element name="getCountriesResponse"
   type="tns:getCountriesResponse"/>

<xs:element name="getNameInfo"
   type="tns:getNameInfo"/>

<xs:element name="getNameInfoResponse"
   type="tns:getNameInfoResponse"/>

<xs:element name="getNamesInCountry"
   type="tns:getNamesInCountry"/>

<xs:element name="getNamesInCountryResponse"
   type="tns:getNamesInCountryResponse"/>

<xs:complexType name="getNameInfo">
  <xs:sequence>
    <xs:element name="name" type="xs:string" minOccurs="0"/>
  </xs:sequence>
</xs:complexType>

<xs:complexType name="getNameInfoResponse">
  <xs:sequence>
    <xs:element name="nameinfo" type="tns:nameInfo" minOccurs="0"/>
  </xs:sequence>
</xs:complexType>

<xs:complexType name="nameInfo">
  <xs:sequence>
    <xs:element name="name" type="xs:string" minOccurs="0"/>
    <xs:element name="gender" type="xs:string" minOccurs="0"/>
    <xs:element name="male" type="xs:boolean"/>
    <xs:element name="female" type="xs:boolean"/>
    <xs:element name="countries" minOccurs="0">
      <xs:complexType>
        <xs:sequence>
          <xs:element name="country" type="xs:string"
             minOccurs="0" maxOccurs="unbounded"/>
        </xs:sequence>
      </xs:complexType>
    </xs:element>
  </xs:sequence>
</xs:complexType>

<xs:complexType name="getNamesInCountry">
  <xs:sequence>
    <xs:element name="country" type="xs:string" minOccurs="0"/>
  </xs:sequence>
</xs:complexType>

<xs:complexType name="getNamesInCountryResponse">
  <xs:sequence>
    <xs:element name="name" type="xs:string"
       minOccurs="0" maxOccurs="unbounded"/>
  </xs:sequence>
</xs:complexType>

<xs:complexType name="getCountries">
  <xs:sequence/>
</xs:complexType>

<xs:complexType name="getCountriesResponse">
  <xs:sequence>
    <xs:element name="country" type="xs:string"
       minOccurs="0" maxOccurs="unbounded"/>
  </xs:sequence>
</xs:complexType>

</xs:schema>

server.pl

#!/usr/bin/perl
# Example of a SOAP server.
# Run like this:
#     ./server.pl --verbose=2   (optional, or use -v/-vv/-vvv)
#                 # this will start a server in the background
#
#     ./client.pl --verbose=2   (optional, or use -v/-vv/-vvv)
#                 # inter-actively call procedures on the server
#
# If you process the four examples in order, you will see increasingly
# complex examples.  The last example demonstrates what to do without
# WSDL file (or in case of too many bugs in the definition, not uncommon).
#
# ./servtempl.pl is an empty base, to start your own server

# Thanks to Thomas Bayer, for providing this example service
#    See http://www.thomas-bayer.com/names-service/

# Author: Mark Overmeer, January 24, 2009
# Using:  XML::Compile               1.00
#         XML::Compile::SOAP         2.00
#         XML::Compile::SOAP::Daemon 2.00
# Copyright by the Author, under the terms of Perl itself.
# Feel invited to contribute your examples!

# Of course, all Perl programs start like this!
use warnings;
use strict;

# constants, change this if needed (also in the client script?)
my $serverhost = 'localhost';
my $serverport = '8877';

# To make Perl find the modules without the package being installed.
use lib '../../lib'   # The server implementation, not installed
      , '.';          # To access My*.pm helpers

my $wsdl_filename = 'namesservice.wsdl';
my @more_schemas  = 'namesservice.xsd';

# useful to make constants (or vars) for namespaces
use constant ERROR_NS  => 'http://namesservice.thomas_bayer.com/error';

# This could come from a database...
use MyExampleData  qw/$namedb/;

# This module defines my additional (non-WSDL) calls
use MyExampleCalls;

# Some other XML modules are automatically included.
use XML::Compile::SOAP::Daemon::NetServer;
use XML::Compile::WSDL11;
use XML::Compile::SOAP11;
use XML::Compile::Util    qw/pack_type/;

# The client and server scripts can be translated easily, using the
# 'example' translation table name-space. trace/info/error come from
# the LogReport error dispatch infra-structure.
use Log::Report   'example', syntax => 'SHORT';

# Other useful modules
use Getopt::Long  qw/:config no_ignore_case bundling/;
use List::Util    qw/first/;
use IO::File      ();
use Fcntl         qw/:flock/;

use Data::Dumper;          # Data::Dumper is your friend.
$Data::Dumper::Indent = 1;

# Forward declarations allow prototype checking
sub get_countries($$$);
sub get_name_info($$$);
sub get_names_in_country($$$);
sub get_name_count($$$);
sub create_get_name_count($);

##
#### MAIN
##

#
# I do not like Net::Server to process my command-line options, so
# process them before Net::Server can get it's hand on them.
#

my $mode    = 0;
my $pidfile = ($ENV{TMPDIR} || '/tmp') . '/server.pid';

GetOptions
 # 3 ways to set the verbosity for Log::Report dispatchers
 # select (at least one) of these ways.
   'v+'        => \$mode  # -v -vv -vvv
 , 'verbose=i' => \$mode  # --verbose=2  (0..3)
 , 'mode=s'    => \$mode  # --mode=DEBUG (DEBUG,ASSERT,VERBOSE,NORMAL)
 , 'pidfn=s'   => \$pidfile
   or die "Deamon is not started";

#
# XML::Compile::* uses Log::Report.  The 'default' dispatcher for error
# messages is here changed from PERL (die/warn) into using syslog.
#

# This is an example of Log::Report translation/exception syntax
error __x"No filenames expected on the command-line"
    if @ARGV;

my $lock = IO::File->new($pidfile, 'a')
   or fault __x"Cannot open lockfile {fn}", fn => $pidfile;

flock $lock, LOCK_EX|LOCK_NB
   or fault __x"Server already running, lock on {fn}", fn => $pidfile;

#
# Create the daemon set-up
#

my $daemon = XML::Compile::SOAP::Daemon::NetServer->new
  ( 
    # You may wish to use other daemon implementations, for instance
    # when your platform does not have a fork.  You may also provide
    # a prepared Net::Server daemon object.
# , based_on     => 'Net::Server::PreFork'  # is default
  );

#
# Get the WSDL and Schema definitions
#

# Of course, you find this information in the applicable manual pages of
# the XML-Compile-SOAP distributions.
my $wsdl = XML::Compile::WSDL11->new($wsdl_filename);

# Some WSDLs import or include external schemas. In XML::Compile, you
# have to pass them explicitly. Single SCALAR or ARRAY.
$wsdl->importDefinitions(\@more_schemas);

# The error namespace I use in this example is not defined in the
# wsdl neither the xsd, so have to add it explicitly.
$wsdl->prefixes(err => ERROR_NS);

# enforce the error name-space declaration to be available in all
# returned messages: at compile-time, it is not known that it may
# be used... but XML::Compile handles namespaces statically.
$wsdl->prefixFor(ERROR_NS);

# This will give you some understanding about what is defined.
#$wsdl->schemas->namespaces->printIndex;

# If you have a WSDL, then most of the infrastructure is auto-generated.
# The only thing you have to do, is provide call-back code references
# for each of the portNames in the WSDL.
my %callbacks =
  ( getCountries       => \&get_countries
  , getNamesInCountry  => \&get_names_in_country
  , getNameInfo        => \&get_name_info
  );

$daemon->operationsFromWSDL
  ( $wsdl
  , callbacks => \%callbacks
  );

$daemon->setWsdlResponse($wsdl_filename);

# Add a handler which is not defined in a WSDL
create_get_name_count $daemon;

#
# Start the daemon
# All (slow) preparations done, let's start the server
#

# replace the 'default' output backend to PERL with output to syslog
dispatcher SYSLOG => 'default', mode => $mode;

print "Starting daemon PID=$$ on $serverhost:$serverport\n";

$daemon->run
  ( 
    # any Net::Server option. Difference SOAP daemon extensions add extra
    # configuration options. It also depends on the Net::Server
    # implementation you base the SOAP daemon on.  See new(base_on)
    name    => 'NamesService'
  , host    => $serverhost
  , port    => $serverport

    # Net::Server::PreFork parameters
  , min_servers => 1
  , max_servers => 1
  , min_spare_servers => 0
  , max_spare_servers => 0
  );

info "Daemon stopped\n";
exit 0;

##
### Server-side implementations of the operations
##

#
# First example, no incoming data
#

sub get_countries($$$)
{   my ($server, $in, $request) = @_;

    # We do not have to look at the incoming data ($in) in this case,
    # because this message doesn't provide any.

    # The output structure needs all names of header and body message
    # parts, as defined in the WSDL.  This message only contains a
    # message part named 'parameters'.

    my %parameters; # 'getCountriesResponse' element, see *xsd
    my @countries = sort keys %$namedb;
    $parameters{country} = \@countries;
    # You can use XML::Compile::Schema::template(PERL) to figure-out what
    # the getCountryResponse element structure looks like.

    { parameters => \%parameters } 
}

#
# Second example, with decoding of incoming data
#

sub find_name($$)
{   my $name  = lc shift;
    my $names = shift || [];
    (first {lc($_) eq $name} @$names) ? 1 : undef;
}

sub get_name_info($$$)
{   my ($server, $in, $request) = @_;

    # debugging daemons is not easy, but you could do things like:
    #      (debug mode is enabled by Log::Report dispatchers with
    #       -vvv on the [server] command-line)
    trace join '', 'get_name_info', Dumper $in;

    # In the message description, the getNameInfo message has only
    # one part, named `parameters'.  Its structure is an optional
    # name string.
    my $name = $in->{parameters}{name} || '';

    # It is probably easier for your regression testing to put more
    # complex data processing in seperate files; not in the server
    # file.
    my ($males, $females, @countries) = (0, 0);
    foreach my $country (sort keys %$namedb)
    {   my $male   = find_name $name, $namedb->{$country}{  male};
        my $female = find_name $name, $namedb->{$country}{female};
        $male or $female or next;

        $males    = 1 if $male;
        $females  = 1 if $female;
        push @countries, $country;
    }

    my $gender
      = $males && $females ? 'either'
      : $males             ? 'male'
      : $females           ? 'female'
      :                      undef;

    # The output message is constructed, which has one body element, named
    # 'parameters'.  It's structure is one optional 'nameinfo' element
    my %country_list = (country => \@countries);
    my %nameinfo =
      ( name => $name, countries => \%country_list
      , gender => $gender, male => $males, female => $females
      );

    my %parameters = (nameinfo => \%nameinfo);
    { parameters => \%parameters };

    # if you are not afraid for references, you simply write
    # { parameters =>
    #    { nameinfo =>
    #      { name => $name, countries => {country => \@countries}
    #      , gender => $gender, male => $males, female => $females }}}
    # Perl looks like Lisp, sometimes ;-)
}

##
### The third example
##

sub get_names_in_country($$$)
{   my ($server, $in, $request) = @_;

    # this should look quite familiar now... a bit more compact!
    my $country = $in->{parameters}{country} || '';
    my $data    = $namedb->{$country};

    $data or return
     +{ Fault =>
         { faultcode   => pack_type(ERROR_NS, 'UnknownCountry')
         , faultstring => "No information about country '$country'"
         }

      # The next two are put in the header of HTTP responses. Can
      # also be used in valid responses. Defaults to RC_OK.
      , _RETURN_CODE => 404  # use HTTP codes
      , _RETURN_TEXT => 'Country not found'
      };
    
    my @names   = sort @{$data->{male} || []}, @{$data->{female} || []};
    { parameters => { name => \@names } };
}

#
# The last example shows how to add your own non-WSDL calls
# You have to visit each of the levels of the procedure yourself:
#  1 collect the schemas you need
#  2 specify the protocol details
#  3 defined the incoming and outgoing message explicitly.
#    (see the client.pl, which requires exactly the same info)
#  4 define how to recognize the message
#  5 add the procedure to the knowledge of the server
# Steps 1 and 2 can be shared of all procedures you add manually.

sub create_get_name_count($)
{   my $daemon = shift;

    ##### BEGIN only once per script
    # I want to base my own methods on the WSDL definitions
    $wsdl->importDefinitions(\@my_additional_schemas);
    my $soap11 = XML::Compile::SOAP11::Server->new(schemas => $wsdl);

    # You could also do
    # my $soap11 = XML::Compile::SOAP11::Server->new;
    # $soap11->importDefinitions($_) for @my_additional_schemas;
    ##### END only once per script

    ##### BEGIN usually in initiation phase of the daemon
    # For each of the messages you want to be able to handle, you need to
    # implement this block, run before the daemon starts.

    # The 'input' and 'output' roles are the reversed in the client.
    my $decode = $soap11->compileMessage(RECEIVER => @get_name_count_input);
    my $encode = $soap11->compileMessage(SENDER   => @get_name_count_output);
    ##### END in initiation phase of daemon

    # How do we know that this message is the one arriving?  The selector
    # CODE ref is called with the XML::LibXML::Document which has arrived
    # and must return true when it feels addressed.
    # The ::compileFilter() implementation is quite thorough, because it
    # needs to understand messages from the WSDL which look much alike.
    # You may implement something else.
    # So, either
    #   my $selector = $soap11->compileFilter(@get_name_count_input);
    # or
    my $selector = sub
      { my ($xml, $info) = @_;
        @{$info->{body}} && $info->{body}[0] =~ m/\}getNameCount$/;
      };

    # The handler is the client-side plug, default produces an error reply
    my $handler = $soap11->compileHandler
      ( name       => 'getNameCount'
      , selector   => $selector       # important!
      , decode     => $decode
      , encode     => $encode
      , callback   => \&get_name_count
      );

    $daemon->addHandler('getNameCount', $soap11, $handler);
}

sub get_name_count($$$)
{   my ($server, $in, $request) = @_;

    # Althought the message is not specified in a WSDL, the handler is
    # still the same.
    my $count   = 0;
    if(my $country = $in->{request}{country})
    {   my $data = $namedb->{$country} || {};
        $count = @{$data->{male} || []} + @{$data->{female} || []};
    }

    {answer => {count => $count}};
}

servtempl.pl

#!/usr/bin/perl
# See ./server.pl for a detailed example and explanation.

use warnings;
use strict;

use XML::Compile::SOAP::Daemon::NetServer;
use XML::Compile::WSDL11;
use XML::Compile::SOAP11;

use Log::Report   'example', syntax => 'SHORT';
use Getopt::Long  qw/:config no_ignore_case bundling/;
use List::Util    qw/first/;
use Data::Dumper;          # Data::Dumper is your friend.
$Data::Dumper::Indent = 1;

# Configuration
use constant SERVERNAME => 'my-first-server v0.1';
use constant SERVERHOST => 'localhost';
use constant SERVERPORT => '8877';

my $wsdl_fn = 'namesservice.wsdl'
my @schemas = ('namesservice.xsd');

# Forward declarations

##
#### MAIN
##

my $mode = 0;

GetOptions
   'v+'        => \$mode  # -v -vv -vvv
 , 'verbose=i' => \$mode  # --verbose=2  (0..3)
 , 'mode=s'    => \$mode  # --mode=DEBUG (DEBUG,ASSERT,VERBOSE,NORMAL)
   or die "Deamon is not started";

# in preparation, use standard Perl output in $mode
dispatcher PERL => 'default', mode => $mode;

error __x"No filenames expected on the command-line"
   if @ARGV;

my $daemon = XML::Compile::SOAP::Daemon::NetServer->new;

my $wsdl   = XML::Compile::WSDL11->new($wsdl_fn);
$wsdl->importDefinitions(\@schemas);

my %callbacks = ();

$daemon->operationsFromWSDL($wsdl, callbacks => \%callbacks);
$daemon->setWsdlResponse($wsdl_fn);

# as daemon, replace Perl default by syslog for output
dispatcher SYSLOG => 'default', mode => $mode;

$daemon->run
 ( name => SERVERNAME
 , host => SERVERHOST
 , port => SERVERPORT
 );

info "Daemon stopped\n";
exit 0;

### implement your callbacks here

1;