D.2 SOAP with Other Protocols ( Chapter 8 )

D.2 SOAP with Other Protocols (Chapter 8)

Many server examples in this chapter are functionally identical except for the declaration of a different transport protocol at an early point in the code.

D.2.1 The Generic Transport Class

This class is used by the non-HTTP daemon examples to both provide an overloading of a method to accomplish the task of reading authentication header data and to allow compile-time (or runtime, even) specification of the protocol to use.

Example D-13. WishListCustomer::Transport.pm

 package WishListCustomer::Transport;     use strict; use vars qw(@ISA); use subs qw(import find_target);     use SOAP::Lite;     # For lack of a better default, SOAP::Server is given here. # In fact, the expectation is that import( ) will change this # at compile-time or run-time. @ISA = qw(SOAP::Server);     1;     # Set the parent class that this class inherits from for # all the server functionality. The purpose here is just # to overload find_target (below). sub import {     my $class = shift;     my $new_parent = shift;         @ISA = ($new_parent); }     # This overloading of the find_target method takes the # (now) deserialized request object and looks for a header # named "authenticate". If found, the value is stuffed into # the same %WishListCustomer::SOAP::COOKIES hash table that # the code already uses. # # This remains coupled to WishListCustomer::SOAP by virtue # of the use of the %WishListCustomer::SOAP hash table. sub find_target {     my $self = shift;     my $request = shift;         %WishListCustomer::SOAP::COOKIES = ( );     my $header = $request->match(SOAP::SOM::header .                                  '/authenticate')->dataof;     if ($header) {         my $key = $header->attr->{name}  'user';         my $value = $header->value;             $value =~ s/\n\r\s//g;         $WishListCustomer::SOAP::COOKIES{$key} = $value;     }         $self->SUPER::find_target($request); } 

D.2.2 The Subclass of SOAP::Lite

The client examples use the WishListCustomer::Client class to automate the inclusion of a SOAP header that bears the authentication data into each request. Without this, the application is responsible for including a header in all outgoing requests .

Example D-14. WishListCustomer::Client.pm

 package WishListCustomer::Client;     use strict; use vars qw(@ISA); use subs qw(setAuth call);     use WishListCustomer; # For make_cookie use SOAP::Lite; @ISA = qw(SOAP::Lite);     1;     # Create a SOAP::Header instance and store it on the object. # If called with no parameters at all, the the header is # cleared out. The header will contain the cookie data in # the format that the existing WishListCustomer code is # expecting. sub setAuth {     my ($self, $user, $passwd, @rest) = @_;         if ($user and $passwd) {         my $cookie =             WishListCustomer::make_cookie($user, $passwd);         $self->{_ _auth_header} =             SOAP::Header->name(authenticate => $cookie)                         ->uri('urn:/WiahListCustomer');         if (@rest) {             # This extra block allows the user to specify             # extra parts such as forcing mustUnderstand             # or setting the namespace URI for the header.             my %attr = @rest;             $self->{_ _auth_header}->attr(%attr);         }     } else {         delete $self->{_ _auth_header};     }         $self; }     # This overloading of call( ) allows the calling object to # insert the authentication header, if one is set. The # argument set is simple, and the only concern is adding # a header to @args. sub call {     my ($self, $method, @args) = @_;         unshift(@args, $self->{_ _auth_header})         if $self->{_ _auth_header};     $self->SUPER::call($method, @args); } 

D.2.3 A TCP-Based Server

The first server example given is essentially identical to the basic daemon from Chapter 7, differing mainly in the use of the generic transport class. The daemon has to specify the base server class, and it has to load the module that contains the class.

Example D-15. server-TCP-1

 #!/usr/bin/perl -w     # # This daemon uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::TCP::Server class by way of the # WishListCustomer::Transport generic class for a transport # method. # use strict;     use SOAP::Transport::TCP; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Transport         'SOAP::Transport::TCP::Server';     my $port = pop(@ARGV)  9000; my $host = shift(@ARGV)  'localhost';     # The constructor has to give a Listen argument with a # value, something that HTTP::Daemon did automatically. # Other than that, the only real difference is the use # of WishListCustomer::Transport as the class to create # the object from. WishListCustomer::Transport     ->new(LocalAddr => $host, LocalPort => $port,           Listen => 5, Reuse => 1)     ->dispatch_with({ 'urn:/WishListCustomer' =>                       'WishListCustomer::SOAP' })     ->objects_by_reference('WishListCustomer::SOAP')     ->handle;     exit; 

D.2.4 A Generic Client (TCP by Default)

The client that connect to the earlier server is even more generic in nature than the server, because clients don't have to directly load their own transport code. This example is also strongly based on one of the clients from Chapter 7. It defaults to an endpoint value that indicates a TCP server, but it can just as easily be one of the other protocols.

Example D-16. client-general-1

 #!/usr/bin/perl -w     # # This is a sample client that calls the SOAP interface on # the specified endpoint (defaulting to a local address) and # gets the wishlist for the specified user. The data is # given a simple formatting by means of a format-picture. # use strict;     use WishListCustomer::Client;     my ($user, $passwd) = (shift, shift); die "USAGE: 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint (defaulting to a local address) and # gets the wishlist for the specified user. The data is # given a simple formatting by means of a format-picture. # use strict; use WishListCustomer::Client; my ($user, $passwd) = (shift, shift); die "USAGE: $0 username passwd [ endpoint ]\n" unless ($user and $passwd); my $endpoint = shift  'tcp://localhost:9000'; # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the Wishlist method, checking for errors my $result = $soap->Wishlist; if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } my $books = $result->result; format = @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>> $result->{title}, $result->{us_price} @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>>>> $result->{authors}, $result->{isbn} . for ( sort { $a->{title} cmp $b->{title} } @$books) { $result = $soap->GetBook($_->{isbn}); # Quietly skip books that cause faults next if ($result->fault); $result = $result->result; write; } exit; 
 username passwd [ endpoint ]\n"     unless ($user and $passwd);     my $endpoint = shift  'tcp://localhost:9000';     # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client                ->uri('urn:/WishListCustomer')                ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the Wishlist method, checking for errors my $result = $soap->Wishlist; if ($result->fault) {     die " 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint (defaulting to a local address) and # gets the wishlist for the specified user. The data is # given a simple formatting by means of a format-picture. # use strict; use WishListCustomer::Client; my ($user, $passwd) = (shift, shift); die "USAGE: $0 username passwd [ endpoint ]\n" unless ($user and $passwd); my $endpoint = shift  'tcp://localhost:9000'; # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the Wishlist method, checking for errors my $result = $soap->Wishlist; if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } my $books = $result->result; format = @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>> $result->{title}, $result->{us_price} @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>>>> $result->{authors}, $result->{isbn} . for ( sort { $a->{title} cmp $b->{title} } @$books) { $result = $soap->GetBook($_->{isbn}); # Quietly skip books that cause faults next if ($result->fault); $result = $result->result; write; } exit; 
 : Operation failed: " . $result->faultstring; } my $books = $result->result;     format = @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<            @>>>>>> $result->{title},                        $result->{us_price} @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>>>> $result->{authors},                       $result->{isbn}     .     for (sort { $a->{title} cmp $b->{title} } @$books) {     $result = $soap->GetBook($_->{isbn});     # Quietly skip books that cause faults     next if ($result->fault);     $result = $result->result;     write; }     exit; 

D.2.5 A Jabber-Based Server

For the Jabber example, only a server was written, because, by specifying an endpoint on the command line that starts with the sequence jabber:// , the generic client (shown previously) can connect to the Jabber server without modification.

Example D-17. server-JABBER-1

 #!/usr/bin/perl -w     # This daemon uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::JABBER::Server class by way of the # WishListCustomer::Transport generic class for a transport # method. use strict;     use SOAP::Transport::JABBER; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Transport         'SOAP::Transport::JABBER::Server';     my ($user, $passwd, $host, $port) = @ARGV; $host = 'jabber.org' unless $host; $port = 5222         unless $port; my $jabber_url = "jabber://$user:$passwd\@$host:$port";     # The constructor expects a string that looks like a URL, # but with a leading sequence of "jabber://". The string # will provide the connection and authentication data for # reaching the Jabber server. my $server = WishListCustomer::Transport     ->new($jabber_url)     ->dispatch_with({ 'urn:/WishListCustomer' =>                       'WishListCustomer::SOAP' })     ->objects_by_reference('WishListCustomer::SOAP');     while (1) {     $server->handle;     sleep 10; }     exit; 

D.2.6 The MQ-Based Server

This server closely resembles the Jabber server because a URI-style string is built up from command-line parameters and because the handle method isn't designed to run as an endless loop; the daemon itself provides the loop construct.

Example D-18. server-MQ-1

 #!/usr/bin/perl -w     # This daemon uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::MQ::Server class by way of the # WishListCustomer::Transport generic class for a transport # method. use strict;     use SOAP::Transport::MQ; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Transport         'SOAP::Transport::MQ::Server';     my ($chan, $mgr, $reqest, $reply, $host, $port) = @ARGV; # Putting these last on the command-line allowed for default # values to be used. $host = 'localhost' unless $host; $port = 9000        unless $port; die "USAGE: 
 #!/usr/bin/perl -w # This daemon uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::MQ::Server class by way of the # WishListCustomer::Transport generic class for a transport # method. use strict; use SOAP::Transport::MQ; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Transport 'SOAP::Transport::MQ::Server'; my ($chan, $mgr, $reqest, $reply, $host, $port) = @ARGV; # Putting these last on the command-line allowed for default # values to be used. $host = 'localhost' unless $host; $port = 9000 unless $port; die "USAGE: $0 channel manager request_queue reply_queue " . '[ host port ]' unless ($chan and $mgr and $request and $reply); my $mq_url = "mq://$host:$port?Channel=$chan;" . "QueueManager=$mgr;RequestQueue=$request;" . "ReplyQueue=$reply"; # The constructor expects a string that looks like a URL, # but with a leading sequence of "jabber://". The string # will provide the connection and authentication data for # reaching the Jabber server. my $server = WishListCustomer::Transport ->new($mq_url) ->dispatch_with({ 'urn:/WishListCustomer' => 'WishListCustomer::SOAP' }) ->objects_by_reference('WishListCustomer::SOAP'); do { $server->handle } while sleep 1; exit; 
 channel manager request_queue reply_queue " .     '[ host port ]'     unless ($chan and $mgr and $request and $reply);     my $mq_url = "mq://$host:$port?Channel=$chan;" .     "QueueManager=$mgr;RequestQueue=$request;" .     "ReplyQueue=$reply";     # The constructor expects a string that looks like a URL, # but with a leading sequence of "jabber://". The string # will provide the connection and authentication data for # reaching the Jabber server. my $server = WishListCustomer::Transport     ->new($mq_url)     ->dispatch_with({ 'urn:/WishListCustomer' =>                       'WishListCustomer::SOAP' })     ->objects_by_reference('WishListCustomer::SOAP');     do { $server->handle } while sleep 1;     exit; 

D.2.7 The POP3-Based Server

The POP3 server example was the first of the applications to be one-way in the communication model. The server class it uses doesn't directly reply to the requests it receives. Thus, any clients that sent those requests must also have been designed to not expect replies. Aside from this behavior, the server resembles those written for Jabber and MQ.

Example D-19. server-POP3-1

 #!/usr/bin/perl -w     # # This daemon uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::POP3::Server class by way of the # WishListCustomer::Transport generic class for a transport # method. # use strict;     use SOAP::Transport::TCP; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Transport         'SOAP::Transport::POP3::Server';     my ($user, $passwd, $host) = @ARGV; $host = 'localhost'; my $pop3_url = "pop://$user:$passwd\@$host";     # The constructor takes a URL string that contains all the # the needed information for connecting and authenticating # with the POP3 server. WishListCustomer::Transport     ->new($pop3_url)     ->dispatch_with({ 'urn:/WishListCustomer' =>                       'WishListCustomer::SOAP' })     ->objects_by_reference('WishListCustomer::SOAP');     do { $server->handle ) while sleep 10;     exit; 

D.2.8 The MAILTO Client

Presented as a compliment to the previous POP3 server, this client doesn't expect an actual reply from the transmission of the request. The success or failure of transmitting is as close to a result as can be presented to the user.

Example D-20. client-mailto-1

 #!/usr/bin/perl -w     # # This is a sample client that calls the SOAP interface on # the specified endpoint using the MAILTO protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict;     use WishListCustomer::Client; use Sys::Hostname 'hostname';     my ($user, $passwd, $mailto) = (shift, shift, shift); die "USAGE: 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint using the MAILTO protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict; use WishListCustomer::Client; use Sys::Hostname 'hostname'; my ($user, $passwd, $mailto) = (shift, shift, shift); die "USAGE: $0 username passwd endpoint ISBN [ ISBN... ]\n" unless ($user and $passwd and $mailto and @ARGV); my $hostname = eval { hostname }; $hostname = 'localhost' if $@; my $endpoint = sprintf("maito:%s?From=%s&Subject=SOAP", $mailto, "$user\@$hostname"); # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } else { print "Request sent\n"; } exit; 
 username passwd endpoint ISBN [ ISBN... ]\n"     unless ($user and $passwd and $mailto and @ARGV);     my $hostname = eval { hostname }; $hostname = 'localhost' if $@; my $endpoint = sprintf("maito:%s?From=%s&Subject=SOAP",                        $mailto,                        "$user\@$hostname");     # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client                ->uri('urn:/WishListCustomer')                ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) {     die " 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint using the MAILTO protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict; use WishListCustomer::Client; use Sys::Hostname 'hostname'; my ($user, $passwd, $mailto) = (shift, shift, shift); die "USAGE: $0 username passwd endpoint ISBN [ ISBN... ]\n" unless ($user and $passwd and $mailto and @ARGV); my $hostname = eval { hostname }; $hostname = 'localhost' if $@; my $endpoint = sprintf("maito:%s?From=%s&Subject=SOAP", $mailto, "$user\@$hostname"); # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } else { print "Request sent\n"; } exit; 
 : Operation failed: " . $result->faultstring; } else {     print "Request sent\n"; }     exit; 

D.2.9 The IO-Based Filter

The example presented for the SOAP::Transport::IO::Server class is designed as a filter, reading a request from Perl's STDIN file handle and writing the response to the STDOUT file handle.

Example D-21. server-IO-1

 #!/usr/bin/perl -w     # This example uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::IO::Server class by way of the # WishListCustomer::Transport generic class for a transport # method. use strict;     use SOAP::Transport::IO; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Transport         'SOAP::Transport::IO::Server';     # The constructor could take parameters for the input and # output filehandles, but this application is going to act # as an ordinary filter, so the defaults of STDIN and STDOUT # are fine. my $server = WishListCustomer::Transport     ->new( )     ->dispatch_with({ 'urn:/WishListCustomer' =>                       'WishListCustomer::SOAP' })     ->objects_by_reference('WishListCustomer::SOAP')     ->handle;     exit; 

D.2.10 The FTP Client

The example FTP client is actually a reengineered version of the MAILTO client ( client-mailto-1 ). This version is designed to accept endpoint strings for either MAILTO or FTP. Because FTP is also a one-way client implementation, the functionality of the application is independent of the specific protocol used.

Example D-22. client-general-2

 #!/usr/bin/perl -w     # # This is a sample client that calls the SOAP interface on # the specified endpoint using a one-way protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict;     use WishListCustomer::Client; use Sys::Hostname 'hostname';     my ($user, $passwd, $endpoint) = (shift, shift, shift); die "USAGE: 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint using a one-way protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict; use WishListCustomer::Client; use Sys::Hostname 'hostname'; my ($user, $passwd, $endpoint) = (shift, shift, shift); die "USAGE: $0 username passwd endpoint ISBN [ ISBN... ]\n" unless ($user and $passwd and $endpoint and @ARGV); if (substr($endpoint, 0, 3) eq 'ftp') { my @time = localtime; my $file = sprintf("%s-%02d%02d%02d:%02d%02d.xml", $user, $time[5] % 100, # year $time[4] + 1, # month $time[3], # day $time[2], # hour $time[1]); # minute $endpoint .= '/' unless (substr($endpoint, -1, 1) eq '/'); $endpoint .= $file; } elsif (substr($endpoint, 0, 6) eq 'mailto') { my $hostname = eval { hostname }; $hostname = 'localhost' if $@; $endpoint = "$endpoint?From=$user\@$hostname&Subject=" . 'SOAP'; } else { die "$0: endpoint only supports ftp: and mailto: "; } # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } else { print "Request sent\n"; } exit; 
 username passwd endpoint ISBN [ ISBN... ]\n"     unless ($user and $passwd and $endpoint and @ARGV);     if (substr($endpoint, 0, 3) eq 'ftp') {     my @time = localtime;     my $file = sprintf("%s-%02d%02d%02d:%02d%02d.xml",                        $user,                        $time[5] % 100, # year                        $time[4] + 1,   # month                        $time[3],       # day                        $time[2],       # hour                        $time[1]);      # minute     $endpoint .= '/'         unless (substr($endpoint, -1, 1) eq '/');     $endpoint .= $file; } elsif (substr($endpoint, 0, 6) eq 'mailto') {     my $hostname = eval { hostname };     $hostname = 'localhost' if $@;     $endpoint = "$endpoint?From=$user\@$hostname&Subject=" .         'SOAP'; } else {     die " 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint using a one-way protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict; use WishListCustomer::Client; use Sys::Hostname 'hostname'; my ($user, $passwd, $endpoint) = (shift, shift, shift); die "USAGE: $0 username passwd endpoint ISBN [ ISBN... ]\n" unless ($user and $passwd and $endpoint and @ARGV); if (substr($endpoint, 0, 3) eq 'ftp') { my @time = localtime; my $file = sprintf("%s-%02d%02d%02d:%02d%02d.xml", $user, $time[5] % 100, # year $time[4] + 1, # month $time[3], # day $time[2], # hour $time[1]); # minute $endpoint .= '/' unless (substr($endpoint, -1, 1) eq '/'); $endpoint .= $file; } elsif (substr($endpoint, 0, 6) eq 'mailto') { my $hostname = eval { hostname }; $hostname = 'localhost' if $@; $endpoint = "$endpoint?From=$user\@$hostname&Subject=" . 'SOAP'; } else { die "$0: endpoint only supports ftp: and mailto: "; } # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } else { print "Request sent\n"; } exit; 
 : endpoint only supports ftp: and mailto: "; }     # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client                ->uri('urn:/WishListCustomer')                ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) {     die " 
 #!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint using a one-way protocol. It sends # a request to purchase one or more books from the wish- # list. # use strict; use WishListCustomer::Client; use Sys::Hostname 'hostname'; my ($user, $passwd, $endpoint) = (shift, shift, shift); die "USAGE: $0 username passwd endpoint ISBN [ ISBN... ]\n" unless ($user and $passwd and $endpoint and @ARGV); if (substr($endpoint, 0, 3) eq 'ftp') { my @time = localtime; my $file = sprintf("%s-%02d%02d%02d:%02d%02d.xml", $user, $time[5] % 100, # year $time[4] + 1, # month $time[3], # day $time[2], # hour $time[1]); # minute $endpoint .= '/' unless (substr($endpoint, -1, 1) eq '/'); $endpoint .= $file; } elsif (substr($endpoint, 0, 6) eq 'mailto') { my $hostname = eval { hostname }; $hostname = 'localhost' if $@; $endpoint = "$endpoint?From=$user\@$hostname&Subject=" . 'SOAP'; } else { die "$0: endpoint only supports ftp: and mailto: "; } # Create the SOAP handle, using the class that manages the # authentication data my $soap = WishListCustomer::Client ->uri('urn:/WishListCustomer') ->proxy($endpoint); # Set the authentication credentials $soap->setAuth($user, $passwd); # ...and call the PurchaseBooks method, checking for errors my $result = $soap->PurchaseBooks(\@ARGV); if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } else { print "Request sent\n"; } exit; 
 : Operation failed: " . $result->faultstring; } else {     print "Request sent\n"; }     exit; 

D.2.11 The LOCAL Example

The example used to illustrate the SOAP::Transport::LOCAL module is in fact a client that acts as its own server. The example is simple but noteworthy for the way one object acts in both roles. An example of this is the need to call the dispatch_with method for the server aspect of the object. Calling this directly on the object created from the SOAP::Lite class results in an attempt to treat dispatch_with as a remote call itself. To avoid confusion, the code uses the transport method of SOAP::Lite to gain access to the underlying SOAP::Transport object. That object reference then calls the method and sets up the dispatch table.

Example D-23. server+client-LOCAL-1

 #!/usr/bin/perl -w     # This example uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::LOCAL::Client class by way of the # WishListCustomer::Transport generic class for a transport # method. use strict;     use SOAP::Lite +trace => 'method'; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP;     my $pattern = shift  'perl'; my $soap = SOAP::Lite->uri('urn:/WishListCustomer')                      ->proxy('local:'); $soap->transport            ->dispatch_with({ 'urn:/WishListCustomer',                              'WishListCustomer::SOAP' });     my $result = $soap->BooksByTitle($pattern); if ($result->fault) {     die " 
 #!/usr/bin/perl -w # This example uses the SOAP-layer for WishListCustomer and # the SOAP::Transport::LOCAL::Client class by way of the # WishListCustomer::Transport generic class for a transport # method. use strict; use SOAP::Lite +trace => 'method'; # Loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; my $pattern = shift  'perl'; my $soap = SOAP::Lite->uri('urn:/WishListCustomer') ->proxy('local:'); $soap->transport ->dispatch_with({ 'urn:/WishListCustomer', 'WishListCustomer::SOAP' }); my $result = $soap->BooksByTitle($pattern); if ($result->fault) { die "$0: Operation failed: " . $result->faultstring; } my $books = $result->result; format = @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>>>> $result->{title}, $result->{isbn} . print "Books whose title matches '$pattern':\n\n"; for (@$books) { $result = $soap->GetBook($_); # Quietly skip books that cause faults next if ($result->fault); $result = $result->result; write; } exit; 
 : Operation failed: " . $result->faultstring; } my $books = $result->result;     format = @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>>>> $result->{title},                         $result->{isbn} .     print "Books whose title matches '$pattern':\n\n"; for (@$books) {     $result = $soap->GetBook($_);     # Quietly skip books that cause faults     next if ($result->fault);     $result = $result->result;     write; }     exit; 

D.2.12 The Sample Transport Module

The code in this module is an example of writing and subclassing modules for client-transport or general SOAP::Transport replacement. Note that the code hasn't actually been tested in a sample application and that some ciphers it supports aren't considered strong encryption. It's meant as an exercise; don't use it if you need to keep data secure!

Example D-24. Crypt::SOAP.pm

 package Crypt::SOAP;     use strict; use vars qw(%known_cbc);     use SOAP::Lite; use Crypt::CBC;     # A mapping table of the cyphers that can be used with the # Crypt::CBC module. The key is the lc'd name for matching # and the value is what must get passed to Crypt::CBC::new %known_cbc = ( des      => 'DES',                idea     => 'IDEA',                blowfish => 'Blowfish',                rc6      => 'RC6',                rijndael => 'Rijndael' );     package Crypt::SOAP::Transport;     use strict; use vars qw(@ISA); use subs qw(new proxy cipher key iv padding prepend_iv             as_hex encrypt decrypt crypt);     @ISA = qw(SOAP::Transport);     sub new {     my ($class, @args) = @_;     return $class if ref $class;         # While SOAP::Transport::new takes no arguments, there     # are a number of attributes in this class, any of     # which can be set in the constructor.     my $self = $class->SUPER::new( );     my ($method, $value);     while (@args) {         ($method, $value) = splice(@args, 0, 2);         $self->can($method) ?             $self->$method($value) :             die "$class: Unknown parameter $method in new";     }         $self; }     sub proxy {     my $self = shift->new;     my $class = ref $self;         return $self->{_proxy} unless @_;         my ($cipher, $proto);     my $endpoint = shift;     if ($endpoint =~ /^(\w+):/) {         ($cipher, $proto) = split(/-/, );         $endpoint =~ s/^$cipher-//;     } else {         die "$class: No transport protocol in proxy";     }     if ($cipher = $Crypt::SOAP::known_cbc{lc $cipher}) {         $self->cipher($cipher);     } else {         die "$class: Cipher $cipher unknown or unsupported "             . 'in proxy';     }         $self->SUPER::proxy($endpoint, @_);     # This is cheating, using knowledge of SOAP::Transport     # internal keys. But it is necessary as long as the     # super-class proxy method only takes string arguments.     $self->{_proxy} =         Crypt::SOAP::Client->new($self, $self->{_proxy}); }     sub encrypt { shift->crypt('E', shift) } sub decrypt { shift->crypt('D', shift) }     sub crypt {     my ($self, $direction, $text) = @_;         die ref($self) . ": both 'direction' and 'text' must " .         'be passed to crypt'             unless ($direction and $text);         # This relies on the application having set most of     # these attributes already     my $cipher = Crypt::CBC->new({                                   key => $self->key,                                   cipher => $self->cipher,                                   $self->iv ?                                   (iv => $self->iv) : ( ),                                   $self->padding ?                                   (padding =>                                    $self->padding) : ( ),                                   prepend_iv =>                                   $self->prepend_iv  0                                  });         my $method =         ($direction =~ /^e/i) ? 'encrypt' : 'decrypt';     $method .= '_hex' if $self->as_hex;         $cipher->$method($text); }     BEGIN {     no strict 'refs';     for my $method (qw(cipher key iv padding prepend_iv                        as_hex)) {         my $field = "_$method";         *$method = sub {             my $self = shift->new;             @_ ? ($self->{$field} = shift, return $self) :                  return $self->{$field};         }     } }     package Crypt::SOAP::Server;     use strict; use vars qw(@ISA); use subs qw(import subclass new handle);     sub import {     my ($class, $new_parent, $load_class) = @_;         @ISA = ($new_parent);         # Attempt to load the module that provides the parent     # class, unless expressly told not to     return $class if (defined($load_class) and                       ("$load_class" eq '0'));     if ($load_class) {         eval { require $load_class };         die "$class: Error loading $load_class: $@" if $@;     } else {         # First we try the parent name directly         eval { require $new_parent };         # If that failed and the last 8 character of the         # classname are "::Server", trim that and try again         if ($@ and substr($new_parent, -8) eq '::Server') {             substr($new_parent, -8) = '';             eval { require $new_parent };             die "$class: Error loading $new_parent " .                 "(derived from ${new_parent}::Server: $@"                     if $@;         } else {             die "$class: Error loading $new_parent: $@";         }     }         $class; }     # Just a little alias to avoid confusing people not used to # thinking of import( ) as just another function. Allows an # application to say "->subclass($new_parent)" instead. sub subclass {     shift->import(@_); }     sub new {     my ($class, %args) = @_;     return $class if ref $class;         die "$class: Cannot create objects without a parent " .         'class specified first'             unless (@ISA);         # Save any arguments intended for the transport object     # so they can be passed to new( ) later.     my $transport_args;     if ($args{transport}) {         $transport_args = $args{transport};         delete $args{transport};     }     my $self = $class->SUPER::new(%args);     # The CSS in the key is to hopefully avoid collision     $self->{_CSS_transport} =         Crypt::SOAP::Transport->new($transport_args ?                                     @$transport_args : ( ));         $self; }     sub handle {     my ($self, $message) = @_;         $message = $self->{_CSS_transport}->decrypt($message);     $self->SUPER::handle($message); }     package Crypt::SOAP::Client;     use strict; use vars qw(@ISA); use subs qw(new send_receive);     sub new {     my ($class, $transport, $client) = @_;     return $class if ref $class;         # The only purpose of this new( ) method is to hang a     # reference to $transport on the object and re-bless it     # into this class, after setting the @ISA path to     # include the original class.     die "$class: new( ) must be called with a transport " .         'object and an existing client object'             unless (UNIVERSAL::can($transport, 'new') &&                     UNIVERSAL::can($client, 'new'));     # The key here hopes to avoid collisions     $client->{_CSC_transport} = $transport;     @ISA = (ref $client);     bless $client, $class; }     sub send_receive {     my $self = shift;     my %args = @_;         $args{envelope} = $self->{_CSC_transport}                            ->encrypt($args{envelope});     $self->SUPER::send_receive(%args); }     1;