import SOAP-WSDL 2.00_05 from CPAN
git-cpan-module: SOAP-WSDL git-cpan-version: 2.00_05 git-cpan-authorid: MKUTTER git-cpan-file: authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_05.tar.gz
This commit is contained in:
Martin Kutter
committed by
Michael G. Schwern
Michael G. Schwern
parent
5c42b1d8f6
commit
a78d6d15b5
+12
-2
@@ -1,6 +1,7 @@
|
||||
package SOAP::WSDL::Client;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use Scalar::Util qw(blessed);
|
||||
use SOAP::WSDL::Envelope;
|
||||
use SOAP::Lite;
|
||||
@@ -102,11 +103,20 @@ sub call {
|
||||
# if we had no success (Transport layer error status code)
|
||||
# or if transport layer failed
|
||||
if (! $soap->transport->is_success() ) {
|
||||
|
||||
# TODO Fix deserializing message - there's something wrong with Fault11
|
||||
# Try deserializing response - there may be some
|
||||
if ($response) {
|
||||
eval { $PARSER->parse_string( $response ) };
|
||||
return $MESSAGE_HANDLER->get_data if not $@;
|
||||
|
||||
eval { $PARSER->parse_string( $response ); };
|
||||
if ($@) {
|
||||
warn "could not deserialize response: $@";
|
||||
}
|
||||
else {
|
||||
return $MESSAGE_HANDLER->get_data();
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
require SOAP::WSDL::SOAP::Typelib::Fault11;
|
||||
# generate & return fault if we cannot serialize response
|
||||
|
||||
@@ -53,10 +53,130 @@ sub explain {
|
||||
sub to_typemap {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
$opt->{ wsdl } ||= $self;
|
||||
$opt->{ prefix } ||= q{};
|
||||
$opt->{ wsdl } ||= $self;
|
||||
$opt->{ type_prefix } ||= $opt->{ prefix };
|
||||
$opt->{ element_prefix } ||= $opt->{ prefix };
|
||||
return join "\n",
|
||||
map { $_->to_typemap( $opt ) } @{ $service_of{ ident $self } };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Definitions - model a WSDL E<gt>definitionsE<lt> element
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 first_service get_service set_service push_service
|
||||
|
||||
Accessors/Mutators for accessing / setting the E<gt>serviceE<lt> child
|
||||
element(s).
|
||||
|
||||
=head2 find_service
|
||||
|
||||
Returns the service matching the namespace/localname pair passed as arguments.
|
||||
|
||||
my $service = $wsdl->find_service($namespace, $localname);
|
||||
|
||||
=head2 first_binding get_binding set_binding push_binding
|
||||
|
||||
Accessors/Mutators for accessing / setting the E<gt>bindingE<lt> child
|
||||
element(s).
|
||||
|
||||
=head2 find_service
|
||||
|
||||
Returns the binding matching the namespace/localname pair passed as arguments.
|
||||
|
||||
my $binding = $wsdl->find_binding($namespace, $localname);
|
||||
|
||||
=head2 first_portType get_portType set_portType push_portType
|
||||
|
||||
Accessors/Mutators for accessing / setting the E<gt>portTypeE<lt> child
|
||||
element(s).
|
||||
|
||||
=head2 find_portType
|
||||
|
||||
Returns the portType matching the namespace/localname pair passed as arguments.
|
||||
|
||||
my $portType = $wsdl->find_portType($namespace, $localname);
|
||||
|
||||
=head2 first_message get_message set_message push_message
|
||||
|
||||
Accessors/Mutators for accessing / setting the E<gt>messageE<lt> child
|
||||
element(s).
|
||||
|
||||
=head2 find_service
|
||||
|
||||
Returns the message matching the namespace/localname pair passed as arguments.
|
||||
|
||||
my $message = $wsdl->find_message($namespace, $localname);
|
||||
|
||||
=head2 first_types get_types set_types push_types
|
||||
|
||||
Accessors/Mutators for accessing / setting the E<gt>typesE<lt> child
|
||||
element(s).
|
||||
|
||||
=head2 explain
|
||||
|
||||
Returns a POD string describing how to call the methods of the service(s)
|
||||
described in the WSDL.
|
||||
|
||||
=head2 to_typemap
|
||||
|
||||
Creates a typemap for use with a generated type class library.
|
||||
|
||||
Options:
|
||||
|
||||
NAME DESCRIPTION
|
||||
-------------------------------------------------------------------------
|
||||
prefix Prefix to use for all classes
|
||||
type_prefix Prefix to use for all (Complex/Simple)Type classes
|
||||
element_prefix Prefix to use for all Element classes (with atomic types)
|
||||
|
||||
As some webservices tend to use globally unique type definitions, but
|
||||
locally unique elements with atomic types, type and element classes may
|
||||
be separated by specifying type_prefix and element_prefix instead of
|
||||
prefix.
|
||||
|
||||
The typemap is plain text which can be used as snipped for building a
|
||||
SOAP::WSDL class_resolver perl class.
|
||||
|
||||
Try something like this for creating typemap classes:
|
||||
|
||||
my $parser = XML::LibXML->new();
|
||||
my $handler = SOAP::WSDL::SAX::WSDLHandler->new()
|
||||
$parser->set_handler( $handler );
|
||||
|
||||
$parser->parse_url('file:///path/to/wsdl');
|
||||
|
||||
my $wsdl = $handler->get_data();
|
||||
my $typemap = $wsdl->to_typemap();
|
||||
|
||||
print <<"EOT"
|
||||
package MyTypemap;
|
||||
my \%typemap = (
|
||||
$typemap
|
||||
);
|
||||
sub get_class { return \$typemap{\$_[1] } };
|
||||
1;
|
||||
"EOT"
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright 2004-2007 Martin Kutter.
|
||||
|
||||
This file is part of SOAP-WSDL. You may distribute/modify it under
|
||||
the same terms as perl itself
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
@@ -15,13 +15,13 @@ use base qw(
|
||||
my %faultcode_of :ATTR(:get<faultcode>);
|
||||
my %faultstring_of :ATTR(:get<faultstring>);
|
||||
my %faultactor_of :ATTR(:get<faultactor>);
|
||||
my %detail_of :ATTR(:get<faultdetail>);
|
||||
my %detail_of :ATTR(:get<detail>);
|
||||
|
||||
# always return false in boolean context - a fault is never true...
|
||||
sub as_bool :BOOLIFY { return; }
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
[ qw(faultcode faultstring faultactor faultdetail) ],
|
||||
[ qw(faultcode faultstring faultactor detail) ],
|
||||
{
|
||||
faultcode => \%faultcode_of,
|
||||
faultstring => \%faultstring_of,
|
||||
@@ -44,4 +44,57 @@ __PACKAGE__->__set_minOccurs();
|
||||
__PACKAGE__->__set_maxOccurs();
|
||||
__PACKAGE__->__set_ref('');
|
||||
|
||||
1;
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::SOAP::Typelib::Fault11 - SOAP 1.1 Fault class
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Models a SOAP 1.1 Fault.
|
||||
|
||||
SOAP::WSDL::SOAP::Typelib::Fault11 objects are false in boolean context
|
||||
and serialize to XML on stringification.
|
||||
|
||||
This means you can do something like:
|
||||
|
||||
my $soap = SOAP::WSDL::Client->new();
|
||||
# ...
|
||||
my $result = $soap->call($method, $data);
|
||||
if (not $result) {
|
||||
die "Error calling SOAP method: ", $result->get_faultstring();
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 get_faultcode / set_faultcode
|
||||
|
||||
Getter/setter for object's the faultcode property.
|
||||
|
||||
=head2 get_faultstring / set_faultstring
|
||||
|
||||
Getter/setter for object's the faultstring property.
|
||||
|
||||
=head2 get_faultactor / set_faultactor
|
||||
|
||||
Getter/setter for object's the faultactor property.
|
||||
|
||||
=head2 get_detail / set_detail
|
||||
|
||||
Getter/setter for detail object's detail property.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright 2007 Martin Kutter.
|
||||
|
||||
This file is part of SOAP-WSDL. You may distribute/modify it under
|
||||
the same terms as perl itself
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
@@ -153,6 +153,7 @@ sub to_typemap {
|
||||
|
||||
my $type;
|
||||
push @{ $opt->{path} }, $self->get_name();
|
||||
# referenced types need type_prefix
|
||||
if ( my $typename = $self->get_type() ) {
|
||||
my ($prefix, $localname) = split /:/, $self->get_type();
|
||||
my $ns = $nsmap{ $prefix };
|
||||
@@ -165,12 +166,18 @@ sub to_typemap {
|
||||
else
|
||||
{
|
||||
$type = $opt->{ wsdl }->first_types()->find_type( $ns, $localname );
|
||||
$typeclass = $opt->{ prefix } . $type->get_name();
|
||||
# referenced types need type_prefix (may be globally unique)
|
||||
$typeclass = $opt->{ type_prefix } . $type->get_name();
|
||||
$txt .= $type->to_typemap($opt);
|
||||
}
|
||||
$txt .= q{'} . join( q{/}, @{ $opt->{path} } ) . "' => '$typeclass',\n";
|
||||
}
|
||||
# atomic types need element prefix
|
||||
elsif ($type = $self->first_simpleType() ) {
|
||||
# atomic types need element prefix (may be locally unique)
|
||||
# TODO fix simpletype Typemap
|
||||
my $typeclass = $opt->{ element_prefix } . $self->get_name();
|
||||
$txt .= q{'} . join( q{/}, @{ $opt->{path} } ) . "' => '$typeclass',\n";
|
||||
my $flavor = $type->get_flavor();
|
||||
if ( $flavor eq 'sequence' ) {
|
||||
$txt .= "# atomic simple type (sequence)\n";
|
||||
@@ -185,7 +192,7 @@ sub to_typemap {
|
||||
|
||||
}
|
||||
elsif ($type = $self->first_complexType() ) {
|
||||
my $typeclass = $opt->{ prefix } . $self->get_name();
|
||||
my $typeclass = $opt->{ element_prefix } . $self->get_name();
|
||||
$txt .= q{'} . join( q{/}, @{ $opt->{path} } ) . "' => '$typeclass',\n";
|
||||
my $flavor = $type->get_flavor();
|
||||
if ( $flavor eq 'sequence' ) {
|
||||
@@ -223,6 +230,7 @@ use base qw(
|
||||
[% type.base_class($class_prefix) %]
|
||||
);
|
||||
[% ELSIF (type = self.first_complexType) %]
|
||||
# atomic complexType
|
||||
# <element name="[% self.get_name %]"><complexType> definition
|
||||
use SOAP::WSDL::XSD::Typelib::ComplexType;
|
||||
use base qw(
|
||||
@@ -250,7 +258,7 @@ __PACKAGE__->_factory(
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' %]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE %]
|
||||
[% element.get_name %] => '[% class_prefix %]::[% localname %]',
|
||||
[% element.get_name %] => '[% type_prefix %]::[% localname %]',
|
||||
[% END %]
|
||||
[% END %]
|
||||
}
|
||||
@@ -266,7 +274,7 @@ __PACKAGE__->_factory(
|
||||
[% IF (nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema');
|
||||
base_class = 'SOAP::WSDL::XSD::Typelib::Builtin::' _ localname ;
|
||||
ELSE;
|
||||
base_class = class_prefix _ '::' _ localname;
|
||||
base_class = type_prefix _ '::' _ localname;
|
||||
-%]
|
||||
|
||||
use [% base_class %];
|
||||
@@ -298,6 +306,7 @@ EOT
|
||||
);
|
||||
my $code = $tt->process( \$template, {
|
||||
class_prefix => $opt->{ prefix },
|
||||
type_prefix => $opt->{ type_prefix },
|
||||
self => $self,
|
||||
nsmap => { reverse %{ $opt->{ wsdl }->get_xmlns() } },
|
||||
},
|
||||
|
||||
@@ -2,6 +2,7 @@ package SOAP::WSDL::XSD::Typelib::Builtin::string;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
# use HTML::Entities qw(encode_entities);
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
my %length_of :ATTR(:name<length> :default<()>);
|
||||
@@ -10,6 +11,31 @@ my %maxLength_of :ATTR(:name<maxLength> :default<()>);
|
||||
my %pattern_of :ATTR(:name<pattern> :default<()>);
|
||||
my %enumeration_of :ATTR(:name<enumeration> :default<()>);
|
||||
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
|
||||
|
||||
my %char2entity = (
|
||||
q{&} => q{&},
|
||||
q{<} => q{<},
|
||||
q{>} => q{>},
|
||||
q{"} => q{&qout;},
|
||||
q{'} => q{'},
|
||||
);
|
||||
|
||||
sub serialize {
|
||||
my ($self, $opt) = @_;
|
||||
my $ident = ident $self;
|
||||
$opt ||= {};
|
||||
my $value = $self->get_value();
|
||||
return $self->start_tag({ %$opt, nil => 1})
|
||||
if not defined $value;
|
||||
|
||||
# HTML::Entities does the same - and more, thus it's around 1/3 slower...
|
||||
$value =~ s{([&<>"'])}{$char2entity{$1}}xgmso;
|
||||
|
||||
return join q{}, $self->start_tag($opt, $value)
|
||||
#, encode_entities( $value, q{&<>"'} )
|
||||
, $value
|
||||
, $self->end_tag($opt);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -20,6 +46,11 @@ __END__
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::string - string objects
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
String objects. XML entities (&, E<lt> E<gt> " ') are encoded on
|
||||
serialization.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
|
||||
@@ -89,9 +89,13 @@ sub START {
|
||||
my $method = "set_$_";
|
||||
$self->$method( $args_of->{ $_ } );
|
||||
}
|
||||
: $_ eq 'xmlns'
|
||||
: $_ =~ m{ \A # beginning of string
|
||||
xmlns # xmlns
|
||||
}xms
|
||||
? do {}
|
||||
: croak "unknown field $_ in $class";
|
||||
# TODO maybe only warn for unknown fields ?
|
||||
|
||||
} keys %$args_of;
|
||||
};
|
||||
|
||||
|
||||
Reference in New Issue
Block a user