SOAP-Lite
view release on metacpan or search on metacpan
lib/SOAP/Lite.pm view on Meta::CPAN
sub o_qname { $_[0]->[0] }
sub o_attr { $_[0]->[1] }
sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef }
sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] }
# $_[0]->[3] is not used. Serializer stores object ID there
sub o_value { $_[0]->[4] }
sub o_lname { $_[0]->[5] }
sub o_lattr { $_[0]->[6] }
sub format_datetime {
my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5];
my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s);
return $time;
}
# make bytelength that calculates length in bytes regardless of utf/byte settings
# either we can do 'use bytes' or length will count bytes already
BEGIN {
sub bytelength;
*bytelength = eval('use bytes; 1') # 5.6.0 and later?
? sub { use bytes; length(@_ ? $_[0] : $_) }
: sub { length(@_ ? $_[0] : $_) };
}
# ======================================================================
package SOAP::Cloneable;
sub clone {
my $self = shift;
return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__);
my $clone = bless {} => ref($self) || $self;
for (keys %$self) {
my $value = $self->{$_};
$clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value;
}
return $clone;
}
# ======================================================================
package SOAP::Transport;
use vars qw($AUTOLOAD @ISA);
@ISA = qw(SOAP::Cloneable);
use Class::Inspector;
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
return $self if ref $self;
my $class = ref($self) || $self;
SOAP::Trace::objects('()');
return bless {} => $class;
}
sub proxy {
my $self = shift;
$self = $self->new() if not ref $self;
my $class = ref $self;
return $self->{_proxy} unless @_;
$_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
my $protocol = uc "$1"; # untainted now
# HTTPS is handled by HTTP class
$protocol =~s/^HTTPS$/HTTP/;
(my $protocol_class = "${class}::$protocol") =~ s/-/_/g;
no strict 'refs';
unless (Class::Inspector->loaded("$protocol_class\::Client")
&& UNIVERSAL::can("$protocol_class\::Client" => 'new')
) {
eval "require $protocol_class";
die "Unsupported protocol '$protocol'\n"
if $@ =~ m!^Can\'t locate SOAP/Transport/!;
die if $@;
}
$protocol_class .= "::Client";
return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_);
}
sub AUTOLOAD {
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
return if $method eq 'DESTROY';
no strict 'refs';
*$AUTOLOAD = sub { shift->proxy->$method(@_) };
goto &$AUTOLOAD;
}
# ======================================================================
package SOAP::Fault;
use Carp ();
use overload fallback => 1, '""' => "stringify";
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
unless (ref $self) {
my $class = $self;
$self = bless {} => $class;
SOAP::Trace::objects('()');
}
Carp::carp "Odd (wrong?) number of parameters in new()"
if $^W && (@_ & 1);
no strict qw(refs);
while (@_) {
my $method = shift;
$self->$method(shift)
if $self->can($method)
}
return $self;
}
sub stringify {
my $self = shift;
return join ': ', $self->faultcode, $self->faultstring;
}
sub BEGIN {
no strict 'refs';
for my $method (qw(faultcode faultstring faultactor faultdetail)) {
my $field = '_' . $method;
*$method = sub {
my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
? shift->new
: __PACKAGE__->new;
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
*detail = \&faultdetail;
}
# ======================================================================
package SOAP::Data;
use vars qw(@ISA @EXPORT_OK);
use Exporter;
use Carp ();
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
@ISA = qw(Exporter);
@EXPORT_OK = qw(name type attr value uri);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
unless (ref $self) {
my $class = $self;
$self = bless {_attr => {}, _value => [], _signature => []} => $class;
SOAP::Trace::objects('()');
}
no strict qw(refs);
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
while (@_) {
my $method = shift;
$self->$method(shift) if $self->can($method)
}
return $self;
}
sub name {
my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
if (@_) {
my $name = shift;
my ($uri, $prefix); # predeclare, because can't declare in assign
if ($name) {
($uri, $name) = SOAP::Utils::splitlongname($name);
unless (defined $uri) {
($prefix, $name) = SOAP::Utils::splitqname($name);
$self->prefix($prefix) if defined $prefix;
} else {
$self->uri($uri);
}
}
$self->{_name} = $name;
$self->value(@_) if @_;
return $self;
}
return $self->{_name};
}
sub attr {
my $self = ref $_[0]
? shift
: UNIVERSAL::isa($_[0] => __PACKAGE__)
? shift->new()
: __PACKAGE__->new();
if (@_) {
$self->{_attr} = shift;
return $self->value(@_) if @_;
return $self
}
return $self->{_attr};
}
sub type {
my $self = ref $_[0]
? shift
: UNIVERSAL::isa($_[0] => __PACKAGE__)
? shift->new()
: __PACKAGE__->new();
if (@_) {
$self->{_type} = shift;
$self->value(@_) if @_;
return $self;
}
if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) {
lib/SOAP/Lite.pm view on Meta::CPAN
use SOAP::Lite::Utils;
sub BEGIN {
no strict 'refs';
my %path = (
root => '/',
envelope => '/Envelope',
body => '/Envelope/Body',
header => '/Envelope/Header',
headers => '/Envelope/Header/[>0]',
fault => '/Envelope/Body/Fault',
faultcode => '/Envelope/Body/Fault/faultcode',
faultstring => '/Envelope/Body/Fault/faultstring',
faultactor => '/Envelope/Body/Fault/faultactor',
faultdetail => '/Envelope/Body/Fault/detail',
);
for my $method (keys %path) {
*$method = sub {
my $self = shift;
ref $self or return $path{$method};
Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
return $self->valueof($path{$method});
};
}
my %results = (
method => '/Envelope/Body/[1]',
result => '/Envelope/Body/[1]/[1]',
freeform => '/Envelope/Body/[>0]',
paramsin => '/Envelope/Body/[1]/[>0]',
paramsall => '/Envelope/Body/[1]/[>0]',
paramsout => '/Envelope/Body/[1]/[>1]'
);
for my $method (keys %results) {
*$method = sub {
my $self = shift;
ref $self or return $results{$method};
Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
defined $self->fault ? return : return $self->valueof($results{$method});
};
}
for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils
*$method = \&{'SOAP::Utils::'.$method};
}
__PACKAGE__->__mk_accessors('context');
}
# use object in boolean context return true/false on last match
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success';
use overload fallback => 1, 'bool' => sub { @{shift->{_current}} > 0 };
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $content = shift;
SOAP::Trace::objects('()');
return bless { _content => $content, _current => [$content] } => $class;
}
sub parts {
my $self = shift;
if (@_) {
$self->context->packager->parts(@_);
return $self;
}
else {
return $self->context->packager->parts;
}
}
sub is_multipart {
my $self = shift;
return defined($self->parts);
}
sub current {
my $self = shift;
$self->{_current} = [@_], return $self if @_;
return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
}
sub valueof {
my $self = shift;
local $self->{_current} = $self->{_current};
$self->match(shift) if @_;
return wantarray
? map {o_value($_)} @{$self->{_current}}
: @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef;
}
sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
wantarray
? map { bless $_ => 'SOAP::Header' } shift->dataof(@_)
: do { # header returned by ->dataof can be undef in scalar context
my $header = shift->dataof(@_);
ref $header ? bless($header => 'SOAP::Header') : undef;
};
}
sub dataof {
my $self = shift;
local $self->{_current} = $self->{_current};
$self->match(shift) if @_;
return wantarray
? map {$self->_as_data($_)} @{$self->{_current}}
: @{$self->{_current}}
? $self->_as_data($self->{_current}->[0])
: undef;
}
sub namespaceuriof {
my $self = shift;
local $self->{_current} = $self->{_current};
$self->match(shift) if @_;
return wantarray
? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}}
: @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef;
lib/SOAP/Lite.pm view on Meta::CPAN
} keys %$attrs;
# try to handle with typecasting
my $res = $self->typecast($value, $name, $attrs, $children, $type);
return $res if defined $res;
# ok, continue with others
if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) {
my $res = [];
$self->hrefs->{$id} = $res if defined $id;
# check for arrayType which could be [1], [,2][5] or []
# [,][1] will NOT be allowed right now (multidimensional sparse array)
my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}
=~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/
or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!;
my @dimensions = map { $_ || undef } split /,/, $multisize;
my $size = 1;
foreach (@dimensions) { $size *= $_ || 0 }
# TODO ähm, shouldn't this local be my?
local $arraytype = $type;
# multidimensional
if ($multisize =~ /,/) {
@$res = splitarray(
[@dimensions],
[map { scalar(($self->decode_object($_))[1]) } @{$children || []}]
);
}
# normal
else {
@$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []};
}
# sparse (position)
if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) {
my @new;
for (my $pos = 0; $pos < @$children; $pos++) {
# TBD implement position in multidimensional array
my($position) = SOAP::Utils::o_lattr($children->[$pos])->{"{$SOAP::Constants::NS_ENC}position"} =~ /^\[(\d+)\]$/
or die "Position must be specified for all elements of sparse array\n";
$new[$position] = $res->[$pos];
}
@$res = @new;
}
# partially transmitted (offset)
# TBD implement offset in multidimensional array
my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/
if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"};
unshift(@$res, (undef) x $offset) if $offset;
die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n"
if $multisize && $size < @$res;
# extend the array if number of elements is specified
$#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0];
return defined $class && $class ne 'Array' ? bless($res => $class) : $res;
}
elsif ($name =~ /^\{$SOAP::Constants::NS_ENC\}Struct$/
|| !$schemaclass->can($method)
&& (ref $children || defined $class && $value =~ /^\s*$/)) {
my $res = {};
$self->hrefs->{$id} = $res if defined $id;
# Patch code introduced in 0.65 - deserializes array properly
# Decode each element of the struct.
my %child_count_of = ();
foreach my $child (@{$children || []}) {
my ($child_name, $child_value) = $self->decode_object($child);
# Store the decoded element in the struct. If the element name is
# repeated, replace the previous scalar value with a new array
# containing both values.
if (not $child_count_of{$child_name}) {
# first time to see this value: use scalar
$res->{$child_name} = $child_value;
}
elsif ($child_count_of{$child_name} == 1) {
# second time to see this value: convert scalar to array
$res->{$child_name} = [ $res->{$child_name}, $child_value ];
}
else {
# already have an array: append to it
push @{$res->{$child_name}}, $child_value;
}
$child_count_of{$child_name}++;
}
# End patch code
return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res;
}
else {
my $res;
if (my $method_ref = $schemaclass->can($method)) {
$res = $method_ref->($self, $value, $name, $attrs, $children, $type);
}
else {
$res = $self->typecast($value, $name, $attrs, $children, $type);
$res = $class ? die "Unrecognized type '$type'\n" : $value
unless defined $res;
}
$self->hrefs->{$id} = $res if defined $id;
return $res;
}
}
sub splitarray {
my @sizes = @{+shift};
my $size = shift @sizes;
my $array = shift;
return splice(@$array, 0, $size) unless @sizes;
my @array = ();
push @array, [
splitarray([@sizes], $array)
] while @$array && (!defined $size || $size--);
return @array;
}
sub typecast { } # typecast is called for both objects AND scalar types
# check ref of the second parameter (first is the object)
# return undef if you don't want to handle it
# ======================================================================
package SOAP::Client;
use SOAP::Lite::Utils;
our $VERSION = '1.27'; # VERSION
sub BEGIN {
__PACKAGE__->__mk_accessors(qw(endpoint code message
is_success status options));
}
# ======================================================================
package SOAP::Server::Object;
sub gen_id; *gen_id = \&SOAP::Serializer::gen_id;
my %alive;
my %objects;
sub objects_by_reference {
shift;
while (@_) {
@alive{shift()} = ref $_[0]
? shift
lib/SOAP/Lite.pm view on Meta::CPAN
my $command = shift;
my @parameters = UNIVERSAL::isa($_[0] => 'ARRAY')
? @{shift()}
: shift
if @_ && $command ne 'autodispatch';
if ($command eq 'autodispatch' || $command eq 'dispatch_from') {
$soap = ($soap||$pkg)->new;
no strict 'refs';
foreach ($command eq 'autodispatch'
? 'UNIVERSAL'
: @parameters
) {
my $sub = "${_}::AUTOLOAD";
defined &{*$sub}
? (\&{*$sub} eq \&{*SOAP::AUTOLOAD}
? ()
: Carp::croak "$sub already assigned and won't work with DISPATCH. Died")
: (*$sub = *SOAP::AUTOLOAD);
}
}
elsif ($command eq 'service') {
foreach (keys %{SOAP::Schema->schema_url(shift(@parameters))->parse(@parameters)->load->services}) {
$_->export_to_level(1, undef, ':all');
}
}
elsif ($command eq 'debug' || $command eq 'trace') {
SOAP::Trace->import(@parameters ? @parameters : 'all');
}
elsif ($command eq 'import') {
local $^W; # suppress warnings about redefining
my $package = shift(@parameters);
$package->export_to_level(1, undef, @parameters ? @parameters : ':all') if $package;
}
else {
Carp::carp "Odd (wrong?) number of parameters in import(), still continue" if $^W && !(@parameters & 1);
$soap = ($soap||$pkg)->$command(@parameters);
}
}
}
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
return $self if ref $self;
unless (ref $self) {
my $class = $self;
# Check whether we can clone. Only the SAME class allowed, no inheritance
$self = ref($soap) eq $class ? $soap->clone : {
_transport => SOAP::Transport->new,
_serializer => SOAP::Serializer->new,
_deserializer => SOAP::Deserializer->new,
_packager => SOAP::Packager::MIME->new,
_schema => undef,
_autoresult => 0,
_on_action => sub { sprintf '"%s#%s"', shift || '', shift },
_on_fault => sub {ref $_[1] ? return $_[1] : Carp::croak $_[0]->transport->is_success ? $_[1] : $_[0]->transport->status},
};
bless $self => $class;
$self->on_nonserialized($self->on_nonserialized || $self->serializer->on_nonserialized);
SOAP::Trace::objects('()');
}
Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
no strict qw(refs);
while (@_) {
my($method, $params) = splice(@_,0,2);
$self->can($method)
? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
: $^W && Carp::carp "Unrecognized parameter '$method' in new()"
}
return $self;
}
sub init_context {
my $self = shift->new;
$self->{'_deserializer'}->{'_context'} = $self;
# weaken circular reference to avoid a memory hole
weaken $self->{'_deserializer'}->{'_context'};
$self->{'_serializer'}->{'_context'} = $self;
# weaken circular reference to avoid a memory hole
weaken $self->{'_serializer'}->{'_context'};
}
# Naming? wsdl_parser
sub schema {
my $self = shift;
if (@_) {
$self->{'_schema'} = shift;
return $self;
}
else {
if (!defined $self->{'_schema'}) {
$self->{'_schema'} = SOAP::Schema->new;
}
return $self->{'_schema'};
}
}
sub BEGIN {
no strict 'refs';
for my $method (qw(serializer deserializer)) {
my $field = '_' . $method;
*$method = sub {
my $self = shift->new;
if (@_) {
my $context = $self->{$field}->{'_context'}; # save the old context
$self->{$field} = shift;
$self->{$field}->{'_context'} = $context; # restore the old context
return $self;
}
else {
return $self->{$field};
}
}
}
lib/SOAP/Lite.pm view on Meta::CPAN
<res2>name2</res2>
<res3>name3</res3>
</mehodResponse>
In that case:
$result = $r->result; # gives you 'name1'
$paramout1 = $r->paramsout; # gives you 'name2', because of scalar context
$paramout1 = ($r->paramsout)[0]; # gives you 'name2' also
$paramout2 = ($r->paramsout)[1]; # gives you 'name3'
or
@paramsout = $r->paramsout; # gives you ARRAY of out parameters
$paramout1 = $paramsout[0]; # gives you 'res2', same as ($r->paramsout)[0]
$paramout2 = $paramsout[1]; # gives you 'res3', same as ($r->paramsout)[1]
Generally, if server returns C<return (1,2,3)> you will get C<1> as the result
and C<2> and C<3> as out parameters.
If the server returns C<return [1,2,3]> you will get an ARRAY reference from
C<result()> and C<undef> from C<paramsout()>.
Results can be arbitrary complex: they can be an array references, they can be
objects, they can be anything and still be returned by C<result()> . If only
one parameter is returned, C<paramsout()> will return C<undef>.
Furthermore, if you have in your output parameters a parameter with the same
signature (name+type) as in the input parameters this parameter will be mapped
into your input automatically. For example:
B<Server Code>:
sub mymethod {
shift; # object/class reference
my $param1 = shift;
my $param2 = SOAP::Data->name('myparam' => shift() * 2);
return $param1, $param2;
}
B<Client Code>:
$a = 10;
$b = SOAP::Data->name('myparam' => 12);
$result = $soap->mymethod($a, $b);
After that, C<< $result == 10 and $b->value == 24 >>! Magic? Sort of.
Autobinding gives it to you. That will work with objects also with one
difference: you do not need to worry about the name and the type of object
parameter. Consider the C<PingPong> example (F<examples/My/PingPong.pm>
and F<examples/pingpong.pl>):
B<Server Code>:
package My::PingPong;
sub new {
my $self = shift;
my $class = ref($self) || $self;
bless {_num=>shift} => $class;
}
sub next {
my $self = shift;
$self->{_num}++;
}
B<Client Code>:
use SOAP::Lite +autodispatch =>
uri => 'urn:',
proxy => 'http://localhost/';
my $p = My::PingPong->new(10); # $p->{_num} is 10 now, real object returned
print $p->next, "\n"; # $p->{_num} is 11 now!, object autobinded
=head2 STATIC AND DYNAMIC SERVICE DEPLOYMENT
Let us scrutinize the deployment process. When designing your SOAP server you
can consider two kind of deployment: B<static> and B<dynamic>. For both,
static and dynamic, you should specify C<MODULE>, C<MODULE::method>,
C<method> or C<PATH/> when creating C<use>ing the SOAP::Lite module. The
difference between static and dynamic deployment is that in case of 'dynamic',
any module which is not present will be loaded on demand. See the
L</"SECURITY"> section for detailed description.
When statically deploying a SOAP Server, you need to know all modules handling
SOAP requests before.
Dynamic deployment allows extending your SOAP Server's interface by just
installing another module into the dispatch_to path (see below).
=head3 STATIC DEPLOYMENT EXAMPLE
use SOAP::Transport::HTTP;
use My::Examples; # module is preloaded
SOAP::Transport::HTTP::CGI
# deployed module should be present here or client will get
# 'access denied'
-> dispatch_to('My::Examples')
-> handle;
For static deployment you should specify the MODULE name directly.
You should also use static binding when you have several different classes in
one file and want to make them available for SOAP calls.
=head3 DYNAMIC DEPLOYMENT EXAMPLE
use SOAP::Transport::HTTP;
# name is unknown, module will be loaded on demand
SOAP::Transport::HTTP::CGI
# deployed module should be present here or client will get 'access denied'
-> dispatch_to('/Your/Path/To/Deployed/Modules', 'My::Examples')
-> handle;
For dynamic deployment you can specify the name either directly (in that case
it will be C<require>d without any restriction) or indirectly, with a PATH. In
( run in 0.366 second using v1.01-cache-2.11-cpan-00829025b61 )