dinislage/SOAP-WSDL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

import SOAP-WSDL 2.00_13 from CPAN

Browse Source 
git-cpan-module:   SOAP-WSDL
git-cpan-version:  2.00_13
git-cpan-authorid: MKUTTER
git-cpan-file:     authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_13.tar.gz
This commit is contained in:
Martin Kutter
2009-12-12 19:47:52 -08:00
committed by Michael G. Schwern
parent fd0854e34a
commit f63138fc87
181 changed files with 8714 additions and 8161 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lib/SOAP/WSDL/Client.pm
+166 -172
View File
@@ -2,37 +2,37 @@ package SOAP::WSDL::Client;
use strict;
use warnings;
use Carp;
use Class::Std::Storable;
use LWP::UserAgent;
use HTTP::Request;
use LWP::UserAgent;
use HTTP::Request;
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 SOAP::WSDL::SOAP::Typelib::Fault11;
our $VERSION='2.00_12';
our $VERSION='2.00_13';
# Package global for speed and memory savings.
# Package global for speed and memory savings.
# But should be factored out into serializer/deserializer...
my $PARSER;
my %class_resolver_of :ATTR(:name<class_resolver> :default<()>);
my %no_dispatch_of :ATTR(:name<no_dispatch> :default<()>);
my %outputxml_of :ATTR(:name<outputxml> :default<()>);
my %transport_of :ATTR(:name<transport> :default<()>);
my %endpoint_of :ATTR(:name<endpoint> :default<()>);
my %soap_version_of :ATTR(:get<soap_version> :init_attr<soap_version> :default<'1.1'>);
my %fault_class_of :ATTR(:name<fault_class> :default<SOAP::WSDL::SOAP::Typelib::Fault11>);
my %trace_of :ATTR(:set<trace> :init_arg<trace> :default<()> );
my %on_action_of :ATTR(:name<on_action> :default<()>);
my %soap_version_of :ATTR(:get<soap_version> :init_attr<soap_version> :default<'1.1'>);
my %trace_of :ATTR(:set<trace> :init_arg<trace> :default<()> );
my %on_action_of :ATTR(:name<on_action> :default<()>);
my %content_type_of :ATTR(:name<content_type> :default<text/xml; charset=utf8>); #/#trick editors
my %serializer_of :ATTR(:name<serializer> :default<()>);
my %serializer_of :ATTR(:name<serializer> :default<()>);
my %deserializer_of :ATTR(:name<deserializer> :default<()>);
# TODO remove when preparing 2.01
sub outputtree { warn 'outputtree is deprecated and'
. 'will be removed before reaching v2.01 !' }
@@ -43,18 +43,18 @@ sub BUILD {
if (exists $attrs_of_ref->{ proxy }) {
$self->set_proxy( $attrs_of_ref->{ proxy } );
delete $attrs_of_ref->{ proxy };
}
}
}
sub get_trace {
my $ident = ident $_[0];
return $trace_of{ $ident }
? ref $trace_of{ $ident } eq 'CODE'
? $trace_of{ $ident }
: sub { warn @_ }
: ()
}
sub get_trace {
my $ident = ident $_[0];
return $trace_of{ $ident }
? ref $trace_of{ $ident } eq 'CODE'
? $trace_of{ $ident }
: sub { warn @_ }
: ()
}
sub get_proxy {
return $_[0]->get_transport();
@@ -63,37 +63,40 @@ sub get_proxy {
sub set_proxy {
my ($self, @args_from) = @_;
my $ident = ident $self;
# remember old value to return it later - Class::Std does so, too
my $old_value = $transport_of{ $ident };
# 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 );
$transport_of{ $ident } = SOAP::WSDL::Factory::Transport
->get_transport( @args_from );
return $old_value;
}
sub set_soap_version {
my $ident = ident shift;
# 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 };
$soap_version_of{ $ident } = shift;
return $soap_version;
}
sub set_soap_version {
my $ident = ident shift;
# 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 };
delete $transport_of{ $ident };
$soap_version_of{ $ident } = shift;
return $soap_version;
}
# Mimic SOAP::Lite's behaviour for getter/setter routines
SUBFACTORY: {
no strict qw(refs);
@@ -110,62 +113,55 @@ SUBFACTORY: {
}
}
BEGIN {
$PARSER = SOAP::WSDL::Expat::MessageParser->new();
}
sub call {
my $self = shift;
my $method = shift;
my ($self, $method, @data_from) = @_;
my $ident = ident $self;
my $data = ref $_[0]
? $_[0]
: (@_>1)
? { @_ }
: $_[0];
my $header = {};
my ($soap_action, $operation);
my $trace_sub = $self->get_trace();
# 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 '/', $data->get_xmlns(), $method) )
: ( $method, q{} );
if (ref $method eq 'HASH') {
$soap_action = $method->{ soap_action };
$operation = $method->{ operation }
}
else {
$operation = $method;
}
$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,
});
$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,
});
return $envelope if $self->no_dispatch();
# try to guess soap_action if not given
if (not defined $soap_action) {
$soap_action = (blessed $data
&& $data->isa('SOAP::WSDL::XSD::Typelib::Builtin::anyType'))
? $soap_action = join '/', $data->get_xmlns(), $operation
: ($on_action_of{$ident})
? $soap_action = $on_action_of{$ident}->( $self, $operation )
: "";
}
# always quote SOAPAction header.
# WS-I BP 1.0 R1109
$soap_action =~s{\A(:?"|')?}{"}xms;
$soap_action =~s{(:?"|')?\Z}{"}xms;
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
# 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(
@@ -179,60 +175,58 @@ sub call {
# namely ExpatNB and XML::LibXML's Push parser interface...
);
return $response if ($self->outputxml() );
return $response if ($outputxml_of{ $ident } );
$PARSER->class_resolver( $self->get_class_resolver() );
# get deserializer
$deserializer_of{ $ident } ||= SOAP::WSDL::Factory::Deserializer->get_deserializer({
soap_version => $soap_version_of{ $ident },
});
# if we had no success (Transport layer error status code)
# or if transport layer failed
if ( ! $transport->is_success() ) {
# Try deserializing response - there may be some
if ( $response ) {
eval { $PARSER->parse( $response ); };
return $PARSER->get_data() if (not $@);
return $fault_class_of{$ident}->new({
faultcode => 'soap:Server',
faultactor => 'urn:localhost',
faultstring => "Error deserializing message: $@. \n"
. "Message was: \n$response"
});
};
# generate & return fault if we cannot serialize response
# or have none...
return $fault_class_of{$ident}->new({
faultcode => 'soap:Server',
faultactor => 'urn:localhost',
faultstring => 'Error sending / receiving message: '
. $transport->message()
});
}
eval { $PARSER->parse( $response ) };
# set class resolver if serializer supports it
$deserializer_of{ $ident }->class_resolver( $class_resolver_of{ $ident } )
if ( $deserializer_of{ $ident }->can('class_resolver') );
# return fault if we cannot deserialize response
if ($@) {
return $fault_class_of{$ident}->new({
faultcode => 'soap:Server',
faultactor => 'urn:localhost',
faultstring => "Error deserializing message: $@. \n"
my $result;
# Try deserializing response - there may be some,
# even if transport did not succeed (got a 500 response)
if ( $response ) {
eval { $result = $deserializer_of{ $ident }->deserialize( $response ); };
return $result if (not $@);
return $deserializer_of{ $ident }->generate_fault({
code => 'soap:Server',
role => 'urn:localhost',
message => "Error deserializing message: $@. \n"
. "Message was: \n$response"
});
}
};
return $PARSER->get_data();
# 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;
=pod
=head1 NAME
SOAP::WSDL::Client - SOAP::WSDL's SOAP Client
=head1 METHODS
=head2 call
=head1 NAME
SOAP::WSDL::Client - SOAP::WSDL's SOAP Client
=head1 METHODS
=head2 call
$soap->call( \%method, \@parts );
@@ -258,14 +252,14 @@ is guessed from the first part's namespace and the operation name (which is
mostly correct, but may fail). Operation style and body encoding are assumed to
be document/literal
=head2 Configuration methods
=head3 outputxml
$soap->outputxml(1);
When set, call() returns the raw XML of the SOAP Envelope.
=head2 Configuration methods
=head3 outputxml
$soap->outputxml(1);
When set, call() returns the raw XML of the SOAP Envelope.
=head3 set_content_type
@@ -285,17 +279,17 @@ like in
Default:
text/xml; charset: utf8
=head3 set_trace
$soap->set_trace(1);
$soap->set_trace( sub { Log::Log4perl::get_logger()->debug( @_ ) } );
When set to a true value, tracing (via warn) is enabled.
When set to a code reference, this function will be called on every
trace call, making it really easy for you to set up log4perl logging
or whatever you need.
=head3 set_trace
$soap->set_trace(1);
$soap->set_trace( sub { Log::Log4perl::get_logger()->debug( @_ ) } );
When set to a true value, tracing (via warn) is enabled.
When set to a code reference, this function will be called on every
trace call, making it really easy for you to set up log4perl logging
or whatever you need.
=head2 Features different from SOAP::Lite
@@ -360,15 +354,15 @@ SOAP::WSDL::Client and implementing something like
$soap_wsdl_client->call( mySoapMethod, @_);
}
You may even do this in a class factory - see L<wsdl2perl.pl> for creating
You may even do this in a class factory - see L<wsdl2perl.pl> for creating
such interfaces.
=head3 Debugging / Tracing
While SOAP::Lite features a global tracing facility, SOAP::WSDL::Client
allows to switch tracing on/of on a per-object base.
See L<set_trace|set_trace> on how to enable tracing.
=head3 Debugging / Tracing
While SOAP::Lite features a global tracing facility, SOAP::WSDL::Client
allows to switch tracing on/of on a per-object base.
See L<set_trace|set_trace> on how to enable tracing.
=head1 LICENSE
@@ -381,12 +375,12 @@ the same terms as perl itself
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
=head1 REPOSITORY INFORMATION
$Rev: 188 $
$LastChangedBy: kutterma $
$Id: Client.pm 188 2007-09-03 15:15:19Z kutterma $
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Client.pm $
=head1 REPOSITORY INFORMATION
$Rev: 218 $
$LastChangedBy: kutterma $
$Id: Client.pm 218 2007-09-10 16:19:23Z kutterma $
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Client.pm $
=cut