SOAP::WSDL::Server::Mod_Perl2 - mod_perl based SOAP server using SOAP::WSDL

 PerlSetVar dispatch_to "WebPackage::SOAPMethods"

 wsdl2perl.pl --server file:///path/to/your/wsdl

    <wsdl:portType name="WebServiceSoap">
        [...]
    </wsdl:portType>

    [...]

    <wsdl:service name="WebService">
        <wsdl:port name="WebServiceSoap" binding="tns:WebServiceSoap">
            <soap:address location="http://www.example.com/WebService"/>
        </wsdl:port>
    </wsdl:service>

    PerlSetVar soap_service "MyServer::WebService::WebServiceSoap"

 $r - Apache::RequestRec object

    <Location /WebService>
        SetHandler perl-script
        PerlResponseHandler SOAP::WSDL::Server::Mod_Perl2
        PerlSetVar dispatch_to "WebPackage::SOAPMethods"
        PerlSetVar soap_service "MyServer::WebService::WebServiceSoap"
    </Location>

 my $foo = $bar++;

 $Rev: 583 $
 $LastChangedBy: kutterma $
 $Id: $
 $HeadURL: $

package SOAP::WSDL::Server::Mod_Perl2;
use strict;
use warnings;
use base qw(SOAP::WSDL::Server);
use Scalar::Util qw(blessed);

use HTTP::Request       ();
use Apache2::RequestIO  (); # $r->read()
use Apache2::RequestRec (); # $r->headers_in
use Apache2::RequestUtil(); # $r->dir_config()
use APR::Table          (); # $r->headers_in->get()
use Apache2::Log        (); # $r->log
use Apache2::Const -compile => qw(
                                    OK
                                    SERVER_ERROR
                                    HTTP_LENGTH_REQUIRED
                                );

use version; our $VERSION = qv('2.00.10');

my %LOADED_OF = ();

sub handler {
    my $r       = shift;
    my $rlog    = $r->log();

    #
    # Set up section; import requested modules, throwing errors if we're
    # unable to do so. For maximum performance, this should be re-worked
    # to use perl-based Apache directives rather than dir_config(), since
    # the former happens at startup time and the latter at request time.

    #
    # dispatch_to
    my $dispatch_to     = $r->dir_config('dispatch_to');
    if (! $dispatch_to) {
        $rlog->error("No 'dispatch_to' variable set in httpd.conf");
        return Apache2::Const::SERVER_ERROR;
    }

    if (! exists $LOADED_OF{$dispatch_to}) {
        eval "require $dispatch_to";
        if ($@) {
            $rlog->error("Failed to require [$dispatch_to]: $@");
            return Apache2::Const::SERVER_ERROR;
        }
        $LOADED_OF{$dispatch_to} = undef;
    }

    #
    # SOAP service
    my $soap_service_package    = $r->dir_config('soap_service');
    if (! $soap_service_package) {
        $rlog->error("No 'soap_service' variable set in httpd.conf");
        return Apache2::Const::SERVER_ERROR;
    }

    if (! exists $LOADED_OF{$soap_service_package}) {
        eval "require $soap_service_package";
        if ($@) {
            $rlog->error("Failed to require [$soap_service_package]: $@");
            return Apache2::Const::SERVER_ERROR;
        }
        $LOADED_OF{$soap_service_package} = undef;
    }

    #
    # transport_class (optional)
    my $transport_class = $r->dir_config('transport_class');
    if ($transport_class) {
        eval "require $transport_class";
        if ($@) {
            $rlog->error("Failed to require [$transport_class]: $@");
            return Apache2::Const::SERVER_ERROR;
        }
    }
    else {
        #
        # if no transport class was specified, use this package's handle()
        # method
        $transport_class = __PACKAGE__;
    }

    #
    # instantiate SOAP server object
    my $server  = $soap_service_package->new({
            dispatch_to     => $dispatch_to,        # methods
            transport_class => $transport_class,    # handle() call
    });

    my $response_msg    = $server->handle($r);
    if ($response_msg =~ /^\d{3}$/) {
        #
        # a 3-digit number is presumed to be an HTTP return status; since
        # we got this and not a SOAP response, it's presumed to be an
        # error; pass it back to the client as-is
        $rlog->error("Dispatcher returned HTTP $response_msg");
        return $response_msg;
    }

    if ($response_msg) {
        $r->content_type('text/xml; charset="utf-8"');
        $r->print($response_msg);
        return Apache2::Const::OK;
    }
    else {
        $rlog->error("No response returned from dispatcher");
        return Apache2::Const::SERVER_ERROR;
    }
}

sub handle {
    my ($self, $r)  = @_;
    my $rlog        = $r->log();

    my $length  = $r->headers_in->get('content-length');
    if (! $length) {
        $rlog->error("No content-length provided");
        # TODO maybe throw instead of returning a HTTP code?
        # ... it's an exception, anyway...
        return Apache2::Const::HTTP_LENGTH_REQUIRED;
    }

    # read may return less than requested - read until there's no more...
    # TODO: We should note that LimitRequestBody is a must in apache config
    my ($buffer, $read_length);
    my $content = q{};
    while ($read_length = $r->read($buffer, $length)) {
        $content .= $buffer;
    }

    if ($length != length $content) {
        $rlog->error("Read length mismatch; read [" . length($content) . "] bytes but received [$length] bytes");
        return Apache2::Const::SERVER_ERROR;
    }

    # Shamelessly copied (with mild tweaks) from SOAP::WSDL::Server::CGI
    # ... which was as shamelessly copied from SOAP::Transport::HTTP...
    my $request = HTTP::Request->new(
                    $r->method  => $r->uri,
                    HTTP::Headers->new(
                        SOAPAction => $r->headers_in()->get('SOAPAction'),
                    ),
                    $content,
    );

    my $response_message   = eval { $self->SUPER::handle($request) };

    # TODO return response if @$ is a SOAP::WSDL::XSD::Typelib::Builtin::anyType object
    if ($@ || blessed($@)) {
        $rlog->error("Failed to handle request: $@");
        return Apache2::Const::SERVER_ERROR;
    }
    else {
        return $response_message;
    }
}

1;

__END__