File Coverage

blib/lib/SOAP/WSDL/Client.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

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

use Class::Std::Fast::Storable;
use Scalar::Util qw(blessed);

use SOAP::WSDL::Factory::Deserializer;
use SOAP::WSDL::Factory::Serializer;
use SOAP::WSDL::Factory::Transport;
use SOAP::WSDL::Expat::MessageParser;

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

my %class_resolver_of   :ATTR(:name :default<()>);
my %no_dispatch_of      :ATTR(:name    :default<()>);
my %prefix_of           :ATTR(:name         :default<()>);
my %outputxml_of        :ATTR(:name      :default<()>);
my %transport_of        :ATTR(:name      :default<()>);
my %endpoint_of         :ATTR(:name       :default<()>);

my %soap_version_of     :ATTR(:get    :init_attr :default<1.1>);

my %on_action_of        :ATTR(:name      :default<()>);
my %content_type_of     :ATTR(:name   :default);  #/#trick editors
my %encoding_of         :ATTR(:name       :default);
my %serializer_of       :ATTR(:name     :default<()>);
my %deserializer_of     :ATTR(:name   :default<()>);
my %deserializer_args_of   :ATTR(:name   :default<{}>);

sub BUILD {
    my ($self, $ident, $attrs_of_ref) = @_;

    if (exists $attrs_of_ref->{ proxy }) {
        $self->set_proxy( $attrs_of_ref->{ proxy } );
        delete $attrs_of_ref->{ proxy };
    }
    return;
}

sub get_proxy {                         ## no critic RequireArgUnpacking
    return $_[0]->get_transport();
}

sub set_proxy {
    my ($self, @args_from) = @_;
    my $ident = ${ $self };

    # remember old value to return it later - Class::Std does so, too
    my $old_value = $transport_of{ $ident };

    # accept both list and list ref args
    @args_from =  @{ $args_from[0] } if ref $args_from[0];

    # remember endpoint
    $endpoint_of{ $ident } = $args_from[0];

    # set transport - SOAP::Lite works similar...
    $transport_of{ $ident } =  SOAP::WSDL::Factory::Transport
      ->get_transport( @args_from );

    return $old_value;
}

sub set_soap_version {
    my $ident = ${ $_[0] };

    # remember old value to return it later - Class::Std does so, too
    my $soap_version = $soap_version_of{ $ident };

    # re-setting the soap version invalidates the
    # serializer object
    delete $serializer_of{ $ident };
    delete $deserializer_of{ $ident };

    $soap_version_of{ $ident } = $_[1];

    return $soap_version;
}

# Mimic SOAP::Lite's behaviour for getter/setter routines
SUBFACTORY: {
    for (qw(class_resolver no_dispatch outputxml proxy prefix)) {
        my $setter = "set_$_";
        my $getter = "get_$_";
        no strict qw(refs);     ## no critic ProhibitNoStrict
        *{ $_ } = sub { my $self = shift;
            if (@_) {
                $self->$setter(@_);
                return $self;
            }
            return $self->$getter()
        };
    }
}

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

    # the only valid idiom for calling a method with both a header and a body
    # is
    # ->call($method, $body_ref, $header_ref);
    #
    # These other idioms all assume an empty header:
    # ->call($method, %body_of);    # %body_of is a hash
    # ->call($method, $body);       # $body is a scalar
    my ($data, $header) = ref $data_from[0]
      ? ($data_from[0], $data_from[1] )
      : (@data_from>1)
          ? ( { @data_from }, undef )
          : ( $data_from[0], undef );

    # get operation name and soap_action
    my ($operation, $soap_action) = (ref $method eq 'HASH')
        ? ( $method->{ operation }, $method->{ soap_action } )
        : (blessed $data
            && $data->isa('SOAP::WSDL::XSD::Typelib::Builtin::anyType'))
            ? ( $method , (join q{/}, $data->get_xmlns(), $method) )
            : ( $method, q{} );
    $serializer_of{ $ident } ||= SOAP::WSDL::Factory::Serializer->get_serializer({
        soap_version => $self->get_soap_version(),
    });

    my $envelope = $serializer_of{ $ident }->serialize({
        method => $operation,
        body => $data,
        header => $header,
        options => {prefix => $prefix_of{ $ident }},
    });

    return $envelope if $self->no_dispatch();

    # always quote SOAPAction header.
    # WS-I BP 1.0 R1109
    if ($soap_action) {
        $soap_action =~s{\A(:?"|')?}{"}xms;
        $soap_action =~s{(:?"|')?\Z}{"}xms;
    }
    else {
        $soap_action = q{""};
    }

    # get response via transport layer.
    # Normally, SOAP::Lite's transport layer is used, though users
    # may provide their own.
    my $transport = $self->get_transport();
    my $response = $transport->send_receive(
       endpoint => $self->get_endpoint(),
       content_type => $content_type_of{ $ident },
       encoding => $encoding_of{ $ident },
       envelope => $envelope,
       action => $soap_action,
       # on_receive_chunk => sub {}     # optional, may be used for parsing large responses as they arrive.
    );

    return $response if ($outputxml_of{ $ident } );

    # get deserializer
    use Data::Dumper;
    $deserializer_of{ $ident } ||= SOAP::WSDL::Factory::Deserializer->get_deserializer({
        soap_version => $soap_version_of{ $ident },
        %{ $deserializer_args_of{ $ident } },
    });

    # set class resolver if serializer supports it
    $deserializer_of{ $ident }->set_class_resolver( $class_resolver_of{ $ident } )
        if ( $deserializer_of{ $ident }->can('set_class_resolver') );

    # Try deserializing response - there may be some,
    # even if transport did not succeed (got a 500 response)
    if ( $response ) {
        # as our faults are false, returning a success marker is the only
        # reliable way of determining whether the deserializer succeeded.
        # Custom deserializers may return an empty list, or undef,
        # and $@ is not guaranteed to be undefined.
        my ($success, $result_body, $result_header) = eval {
            (1, $deserializer_of{ $ident }->deserialize( $response ));
        };
        if (defined $success) {
            return wantarray
                ? ($result_body, $result_header)
                : $result_body;
        }
        elsif (blessed $@) { #}&& $@->isa('SOAP::WSDL::SOAP::Typelib::Fault11')) {
            return $@;
        }
        else {
            return $deserializer_of{ $ident }->generate_fault({
                code => 'soap:Server',
                role => 'urn:localhost',
                message => "Error deserializing message: $@. \n"
                    . "Message was: \n$response"
            });
        }
    };

    # if we had no success (Transport layer error status code)
    # or if transport layer failed
    if ( ! $transport->is_success() ) {

        # generate & return fault if we cannot serialize response
        # or have none...
        return $deserializer_of{ $ident }->generate_fault({
            code => 'soap:Server',
            role => 'urn:localhost',
            message => 'Error sending / receiving message: '
                . $transport->message()
        });
    }
} ## end sub call

1;

__END__