File Coverage

blib/lib/SOAP/WSDL.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package SOAP::WSDL;
use strict;
use warnings;

use 5.008;  # require at least perl 5.8

use vars qw($AUTOLOAD);

use Carp;
use Scalar::Util qw(blessed);
use SOAP::WSDL::Client;
use SOAP::WSDL::Expat::WSDLParser;
use Class::Std::Fast constructor => 'none';
use SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
use LWP::UserAgent;

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

my %no_dispatch_of      :ATTR(:name);
my %wsdl_of             :ATTR(:name);
my %autotype_of         :ATTR(:name);
my %outputxml_of        :ATTR(:name :default<0>);
my %outputtree_of       :ATTR(:name);
my %outputhash_of       :ATTR(:name);
my %servicename_of      :ATTR(:name);
my %portname_of         :ATTR(:name);
my %class_resolver_of   :ATTR(:name);

my %method_info_of      :ATTR(:default<()>);
my %port_of             :ATTR(:default<()>);
my %porttype_of         :ATTR(:default<()>);
my %binding_of          :ATTR(:default<()>);
my %service_of          :ATTR(:default<()>);
my %definitions_of      :ATTR(:get :default<()>);
my %serialize_options_of :ATTR(:default<()>);

my %client_of           :ATTR(:name     :default<()>);
my %keep_alive_of       :ATTR(:name :default<0> );

my %LOOKUP = (
  no_dispatch           => \%no_dispatch_of,
  class_resolver        => \%class_resolver_of,
  wsdl                  => \%wsdl_of,
  autotype              => \%autotype_of,
  outputxml             => \%outputxml_of,
  outputtree            => \%outputtree_of,
  outputhash            => \%outputhash_of,
  portname              => \%portname_of,
  servicename           => \%servicename_of,
  keep_alive            => \%keep_alive_of,
);

sub readable { carp <<'EOT';
'readable' has no effect any more. If you want formatted XML,
copy the debug output to your favorite XML editor and run the
source format command.
EOT
    return;
}

sub set_readable; *set_readable = \&readable;

for my $method (keys %LOOKUP ) {
    no strict qw(refs); ## no critic (ProhibitNoStrict)
    *{ $method } = sub {
        my $self = shift;
        my $ident = ident $self;
        if (@_) {
            $LOOKUP{ $method }->{ $ident } = shift;
            return $self;
        }
        return $LOOKUP{ $method }->{ $ident };
    };
}

{   # just a BLOCK for scoping warnings.

    # we need to roll our own for supporting
    # SOAP::WSDL->new( key => value ) syntax,
    # like SOAP::Lite does. Class::Std enforces a single hash ref as
    # parameters to new()
    no warnings qw(redefine);   ## no critic ProhibitNoWarnings;

    sub new {
        my ($class, %args_from) = @_;
        my  $self = \do { my $foo = Class::Std::Fast::ID() };
        bless $self, $class;
        for (keys %args_from) {
            my $method = $self->can("set_$_")
                or croak "unknown parameter $_ passed to new";
            $method->($self, $args_from{$_});
        }

        my $ident = ident $self;
        $client_of{ $ident } = SOAP::WSDL::Client->new();
        $self->wsdlinit() if ($wsdl_of{ $ident });
        return $self;
    }
}

sub set_proxy {
    my $self = shift;
    return $self->get_client()->set_proxy(@_);
}

sub get_proxy {
    my $self = shift;
    return $self->get_client()->get_proxy();
}

sub proxy {
    my $self = shift;
    if (@_) {
        return $self->set_proxy(@_);
    }
    return $self->get_proxy();
}

sub wsdlinit {
    my ($self, %opt) = @_;
    my $ident = ident $self;

    my $lwp = LWP::UserAgent->new(
        $keep_alive_of{ $ident }
        ? (keep_alive => 1)
        : ()
    );
    $lwp->agent(qq[SOAP::WSDL $VERSION]);
    my $response = $lwp->get( $wsdl_of{ $ident } );
    croak $response->message() if ($response->code != 200);

    my $parser = SOAP::WSDL::Expat::WSDLParser->new();
    $parser->parse_string( $response->content() );

    my $wsdl_definitions = $parser->get_data();

    # sanity checks
    my $types = $wsdl_definitions->first_types()
        or croak "unable to extract schema from WSDL";
    my $ns = $wsdl_definitions->get_xmlns();

    # setup lookup variables
    $definitions_of{ $ident }  = $wsdl_definitions;
    $serialize_options_of{ $ident } = {
        autotype  => 0,
        typelib   => $types,
        namespace => $ns,
    };

    $servicename_of{ $ident } = $opt{servicename} if $opt{servicename};
    $portname_of{ $ident } = $opt{portname} if $opt{portname};

    $self->_wsdl_init_methods();

    # pass-through keep_alive if we need it...
    $self->get_client()->set_proxy(
        $port_of{ $ident }->first_address()->get_location(),
        $keep_alive_of{ $ident } ? (keep_alive => 1) : (),
    );

    return $self;
} ## end sub wsdlinit

sub _wsdl_get_service :PRIVATE {
    my $ident = ident shift;
    my $wsdl = $definitions_of{ $ident };
    return $service_of{ $ident } = $servicename_of{ $ident }
        ? $wsdl->find_service( $wsdl->get_targetNamespace() , $servicename_of{ $ident } )
        : ( $service_of{ $ident } = $wsdl->get_service()->[ 0 ] );
} ## end sub _wsdl_get_service

sub _wsdl_get_port :PRIVATE  {
    my $ident = ident shift;
    my $wsdl = $definitions_of{ $ident };
    my $ns   = $wsdl->get_targetNamespace();
    return $port_of{ $ident } = $portname_of{ $ident }
        ? $service_of{ $ident }->get_port( $ns, $portname_of{ $ident } )->[ 0 ]
        : ( $port_of{ $ident } = $service_of{ $ident }->get_port()->[ 0 ] );
}

sub _wsdl_get_binding :PRIVATE {
    my $self = shift;
    my $ident = ident $self;
    my $wsdl = $definitions_of{ $ident };
    my $port = $self->_wsdl_get_port();
    $binding_of{ $ident } = $wsdl->find_binding( $port->expand( $port->get_binding() ) )
        or croak "no binding found for ", $port->get_binding();
    return $binding_of{ $ident };
}

sub _wsdl_get_portType :PRIVATE {
    my $self    = shift;
    my $ident   = ident $self;
    my $wsdl    = $definitions_of{ $ident };
    my $binding = $self->_wsdl_get_binding();
    $porttype_of{ $ident } = $wsdl->find_portType( $binding->expand( $binding->get_type() ) )
        or croak "cannot find portType for " . $binding->get_type();
    return $porttype_of{ $ident };
}

sub _wsdl_init_methods :PRIVATE {
    my $self = shift;
    my $ident = ident $self;
    my $wsdl = $definitions_of{ $ident };
    my $ns   = $wsdl->get_targetNamespace();

    # get bindings, portType, message, part(s) - use private methods for clear separation...
    $self->_wsdl_get_service();
    $self->_wsdl_get_portType();

    $method_info_of{ $ident } = {};

    foreach my $binding_operation (@{ $binding_of{ $ident }->get_operation() })
    {
        my $method = {};

        # get SOAP Action
        # SOAP-Action is a required HTTP Header, so we need to look it up...
        # There must be a soapAction uri - or the WSDL is invalid (and
        # it's not us to prove that...)
        my $soap_binding_operation = $binding_operation->get_operation()->[0];
        $method->{ soap_action } = $soap_binding_operation->get_soapAction();

        # get parts
        # 1. get operation from port
        my $operation = $porttype_of{ $ident }->find_operation( $ns,
            $binding_operation->get_name() );

        # 2. get input message name
        my ( $prefix, $localname ) = split /:/xm,
          $operation->first_input()->get_message();

        # 3. get input message
        my $message = $wsdl->find_message( $ns, $localname )
          or croak "Message {$ns}$localname not found in WSDL definition";

        # Is body not required? So there must be one? Do we need the "if"?
        # if (
        my $body=$binding_operation->first_input()->first_body();
        # {
            if ($body->get_parts()) {
                $method->{ parts } = [];        # make sure it's empty
                my $message_part_ref = $message->get_part();
                for my $name ( split m{\s}xm , $body->get_parts() ) {
                    $name =~s{ \A [^:]+: }{}xm;  # throw away ns prefix
                    # could probably made more efficient, but our lists are
                    # usually quite short
                    push @{ $method->{ parts } },
                        grep { $_->get_name() eq $name } @{ $message_part_ref };
                }
            }
        # }
        # A body does not need to specify the parts of a messages.
        # Use all of the message's parts if it does not.
        $method->{ parts } ||= $message->get_part();

        # rpc / encoded methods may have a namespace specified.
        # look it up and set it...
        $method->{ namespace } = $binding_operation
            ? do {
                my $input = $binding_operation->first_input();
                $input ? $input->first_body()->get_namespace() : undef;
            }
            : undef;

        $method_info_of{ $ident }->{ $binding_operation->get_name() } = $method;
    }

    return $method_info_of{ $ident };
}

# on_action is a no-op and just here for compatibility reasons.
# It returns the first parameter to allow method chaining.
sub on_action { return shift }

sub call {
    my ($self, $method, @data_from) = @_;
    my $ident = ${ $self };

    my ($data, $header) = ref $data_from[0]
      ? ($data_from[0], $data_from[1] )
      : (@data_from>1)
          ? ( { @data_from }, undef )
          : ( $data_from[0], undef );

    $self->wsdlinit() if not ($definitions_of{ $ident });
    $self->_wsdl_init_methods() if not ($method_info_of{ $ident });

    my $client = $client_of{ $ident };

    $client->set_no_dispatch( $no_dispatch_of{ $ident } );
    $client->set_outputxml( $outputxml_of{ $ident } ? 1 : 0 );

    # only load ::Deserializer::SOM if we really need to deserialize to SOM.
    # maybe we should introduce something like $output{ $ident } with a fixed
    # set of values - m{^(TREE|HASH|XML|SOM)$}xms ?
    if ( ( ! $outputtree_of{ $ident } )
      && ( ! $outputhash_of{ $ident } )
      && ( ! $outputxml_of{ $ident } )
      && ( ! $no_dispatch_of{ $ident } ) ) {
        require SOAP::WSDL::Deserializer::SOM;
        $client->set_deserializer( SOAP::WSDL::Deserializer::SOM->new() );
    }

    my $method_info = $method_info_of{ $ident }->{ $method };

    # TODO serialize both header and body, not only header
    my (@response) = (blessed $data)
        ? $client->call( {
            operation => $method,
            soap_action => $method_info->{ soap_action },
          }, $data )
        : do {
            my $content = q{};
            # TODO support RPC-encoding: Top-Level element + namespace...
            foreach my $part ( @{ $method_info->{ parts } } ) {

                $content .= $part->serialize( $method, $data,
                  {
                    %{ $serialize_options_of{ $ident } }
                  }  );
            }
            $client->call(
                {
                    operation => $method,
                    soap_action => $method_info->{ soap_action }
                },
                # absolutely stupid, but we need a reference which
                # serializes to XML on stringification...
                SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType->new({
                    value => $content
                }),
                SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType->new({
                    value => $header
                })
            );
        };

    return if not @response;    # nothing to do for one-ways
    return wantarray ? @response : $response[0];
}
1;

__END__