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


line stmt bran cond sub pod time code
1             package SOAP::WSDL::Client;
2 24     24   33555 use strict;
  24         51  
  24         840  
3 24     24   124 use warnings;
  24         42  
  24         645  
4 24     24   113 use Carp;
  24         43  
  24         1581  
5              
6 24     24   25157 use Class::Std::Fast::Storable;
  24         645152  
  24         218  
7 24     24   3981 use Scalar::Util qw(blessed);
  24         58  
  24         2103  
8              
9 24     24   18099 use SOAP::WSDL::Factory::Deserializer;
  24         66  
  24         692  
10 24     24   15315 use SOAP::WSDL::Factory::Serializer;
  24         72  
  24         731  
11 24     24   18183 use SOAP::WSDL::Factory::Transport;
  24         64  
  24         790  
12 24     24   16083 use SOAP::WSDL::Expat::MessageParser;
  0            
  0            
13              
14             our $VERSION = $SOAP::WSDL::VERSION;
15              
16             my %class_resolver_of :ATTR(:name :default<()>);
17             my %no_dispatch_of :ATTR(:name :default<()>);
18             my %prefix_of :ATTR(:name :default<()>);
19             my %outputxml_of :ATTR(:name :default<()>);
20             my %transport_of :ATTR(:name :default<()>);
21             my %endpoint_of :ATTR(:name :default<()>);
22              
23             my %soap_version_of :ATTR(:get :init_attr :default<1.1>);
24              
25             my %on_action_of :ATTR(:name :default<()>);
26             my %content_type_of :ATTR(:name :default); #/#trick editors
27             my %encoding_of :ATTR(:name :default);
28             my %serializer_of :ATTR(:name :default<()>);
29             my %deserializer_of :ATTR(:name :default<()>);
30             my %deserializer_args_of :ATTR(:name :default<{}>);
31              
32             sub BUILD {
33             my ($self, $ident, $attrs_of_ref) = @_;
34              
35             if (exists $attrs_of_ref->{ proxy }) {
36             $self->set_proxy( $attrs_of_ref->{ proxy } );
37             delete $attrs_of_ref->{ proxy };
38             }
39             return;
40             }
41              
42             sub get_proxy { ## no critic RequireArgUnpacking
43             return $_[0]->get_transport();
44             }
45              
46             sub set_proxy {
47             my ($self, @args_from) = @_;
48             my $ident = ${ $self };
49              
50             # remember old value to return it later - Class::Std does so, too
51             my $old_value = $transport_of{ $ident };
52              
53             # accept both list and list ref args
54             @args_from = @{ $args_from[0] } if ref $args_from[0];
55              
56             # remember endpoint
57             $endpoint_of{ $ident } = $args_from[0];
58              
59             # set transport - SOAP::Lite works similar...
60             $transport_of{ $ident } = SOAP::WSDL::Factory::Transport
61             ->get_transport( @args_from );
62              
63             return $old_value;
64             }
65              
66             sub set_soap_version {
67             my $ident = ${ $_[0] };
68              
69             # remember old value to return it later - Class::Std does so, too
70             my $soap_version = $soap_version_of{ $ident };
71              
72             # re-setting the soap version invalidates the
73             # serializer object
74             delete $serializer_of{ $ident };
75             delete $deserializer_of{ $ident };
76              
77             $soap_version_of{ $ident } = $_[1];
78              
79             return $soap_version;
80             }
81              
82             # Mimic SOAP::Lite's behaviour for getter/setter routines
83             SUBFACTORY: {
84             for (qw(class_resolver no_dispatch outputxml proxy prefix)) {
85             my $setter = "set_$_";
86             my $getter = "get_$_";
87             no strict qw(refs); ## no critic ProhibitNoStrict
88             *{ $_ } = sub { my $self = shift;
89             if (@_) {
90             $self->$setter(@_);
91             return $self;
92             }
93             return $self->$getter()
94             };
95             }
96             }
97              
98             sub call {
99             my ($self, $method, @data_from) = @_;
100             my $ident = ${ $self };
101              
102             # the only valid idiom for calling a method with both a header and a body
103             # is
104             # ->call($method, $body_ref, $header_ref);
105             #
106             # These other idioms all assume an empty header:
107             # ->call($method, %body_of); # %body_of is a hash
108             # ->call($method, $body); # $body is a scalar
109             my ($data, $header) = ref $data_from[0]
110             ? ($data_from[0], $data_from[1] )
111             : (@data_from>1)
112             ? ( { @data_from }, undef )
113             : ( $data_from[0], undef );
114              
115             # get operation name and soap_action
116             my ($operation, $soap_action) = (ref $method eq 'HASH')
117             ? ( $method->{ operation }, $method->{ soap_action } )
118             : (blessed $data
119             && $data->isa('SOAP::WSDL::XSD::Typelib::Builtin::anyType'))
120             ? ( $method , (join q{/}, $data->get_xmlns(), $method) )
121             : ( $method, q{} );
122             $serializer_of{ $ident } ||= SOAP::WSDL::Factory::Serializer->get_serializer({
123             soap_version => $self->get_soap_version(),
124             });
125              
126             my $envelope = $serializer_of{ $ident }->serialize({
127             method => $operation,
128             body => $data,
129             header => $header,
130             options => {prefix => $prefix_of{ $ident }},
131             });
132              
133             return $envelope if $self->no_dispatch();
134              
135             # always quote SOAPAction header.
136             # WS-I BP 1.0 R1109
137             if ($soap_action) {
138             $soap_action =~s{\A(:?"|')?}{"}xms;
139             $soap_action =~s{(:?"|')?\Z}{"}xms;
140             }
141             else {
142             $soap_action = q{""};
143             }
144              
145             # get response via transport layer.
146             # Normally, SOAP::Lite's transport layer is used, though users
147             # may provide their own.
148             my $transport = $self->get_transport();
149             my $response = $transport->send_receive(
150             endpoint => $self->get_endpoint(),
151             content_type => $content_type_of{ $ident },
152             encoding => $encoding_of{ $ident },
153             envelope => $envelope,
154             action => $soap_action,
155             # on_receive_chunk => sub {} # optional, may be used for parsing large responses as they arrive.
156             );
157              
158             return $response if ($outputxml_of{ $ident } );
159              
160             # get deserializer
161             use Data::Dumper;
162             $deserializer_of{ $ident } ||= SOAP::WSDL::Factory::Deserializer->get_deserializer({
163             soap_version => $soap_version_of{ $ident },
164             %{ $deserializer_args_of{ $ident } },
165             });
166              
167             # set class resolver if serializer supports it
168             $deserializer_of{ $ident }->set_class_resolver( $class_resolver_of{ $ident } )
169             if ( $deserializer_of{ $ident }->can('set_class_resolver') );
170              
171             # Try deserializing response - there may be some,
172             # even if transport did not succeed (got a 500 response)
173             if ( $response ) {
174             # as our faults are false, returning a success marker is the only
175             # reliable way of determining whether the deserializer succeeded.
176             # Custom deserializers may return an empty list, or undef,
177             # and $@ is not guaranteed to be undefined.
178             my ($success, $result_body, $result_header) = eval {
179             (1, $deserializer_of{ $ident }->deserialize( $response ));
180             };
181             if (defined $success) {
182             return wantarray
183             ? ($result_body, $result_header)
184             : $result_body;
185             }
186             elsif (blessed $@) { #}&& $@->isa('SOAP::WSDL::SOAP::Typelib::Fault11')) {
187             return $@;
188             }
189             else {
190             return $deserializer_of{ $ident }->generate_fault({
191             code => 'soap:Server',
192             role => 'urn:localhost',
193             message => "Error deserializing message: $@. \n"
194             . "Message was: \n$response"
195             });
196             }
197             };
198              
199             # if we had no success (Transport layer error status code)
200             # or if transport layer failed
201             if ( ! $transport->is_success() ) {
202              
203             # generate & return fault if we cannot serialize response
204             # or have none...
205             return $deserializer_of{ $ident }->generate_fault({
206             code => 'soap:Server',
207             role => 'urn:localhost',
208             message => 'Error sending / receiving message: '
209             . $transport->message()
210             });
211             }
212             } ## end sub call
213              
214             1;
215              
216             __END__