import SOAP-WSDL 2.00_16 from CPAN
git-cpan-module: SOAP-WSDL git-cpan-version: 2.00_16 git-cpan-authorid: MKUTTER git-cpan-file: authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_16.tar.gz
This commit is contained in:
Martin Kutter
committed by
Michael G. Schwern
Michael G. Schwern
parent
2347a88353
commit
30be0da3dc
2039
lib/SOAP/WSDL.pm
2039
lib/SOAP/WSDL.pm
File diff suppressed because it is too large
Load Diff
191
lib/SOAP/WSDL/Base.pm
Normal file
191
lib/SOAP/WSDL/Base.pm
Normal file
@@ -0,0 +1,191 @@
|
||||
package SOAP::WSDL::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use List::Util qw(first);
|
||||
use Carp;
|
||||
|
||||
my %id_of :ATTR(:name<id> :default<()>);
|
||||
my %name_of :ATTR(:name<name> :default<()>);
|
||||
my %documentation_of :ATTR(:name<documentation> :default<()>);
|
||||
my %targetNamespace_of :ATTR(:name<targetNamespace> :default<()>);
|
||||
my %xmlns_of :ATTR(:name<xmlns> :default<{}>);
|
||||
my %parent_of :ATTR(:name<parent> :default<()>);
|
||||
|
||||
sub DEMOLISH {
|
||||
my $self = shift;
|
||||
# delete upward references
|
||||
delete $parent_of{ ident $self };
|
||||
}
|
||||
|
||||
sub STORABLE_freeze_pre :CUMULATIVE {};
|
||||
sub STORABLE_freeze_post :CUMULATIVE {};
|
||||
sub STORABLE_thaw_pre :CUMULATIVE {};
|
||||
sub STORABLE_thaw_post :CUMULATIVE { return $_[0] };
|
||||
|
||||
sub _accept {
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
$class =~ s{ \A SOAP::WSDL:: }{}xms;
|
||||
$class =~ s{ (:? :: ) }{_}gxms;
|
||||
my $method = "visit_$class";
|
||||
no strict qw(refs);
|
||||
shift->$method( $self );
|
||||
}
|
||||
|
||||
# unfortunately, AUTOMETHOD is SLOW.
|
||||
# Re-implement in derived package wherever speed is an issue...
|
||||
#
|
||||
sub AUTOMETHOD {
|
||||
my ($self, $ident, @values) = @_;
|
||||
my $subname = $_; # Requested subroutine name is passed via $_
|
||||
|
||||
# we're called as $self->push_something(@values);
|
||||
if ($subname =~s{^push_}{}xms) {
|
||||
my $getter = "get_$subname";
|
||||
my $setter = "set_$subname";
|
||||
## Checking here is paranoid - will fail fatally if
|
||||
## there is no setter...
|
||||
## And we would have to check getters, too.
|
||||
## Maybe do it the Conway way via the Symbol table...
|
||||
## ... can is way slow...
|
||||
return sub {
|
||||
no strict qw(refs);
|
||||
my $old_value = $self->$getter();
|
||||
# Listify if not a list ref
|
||||
$old_value = $old_value ? [ $old_value ] : [] if not ref $old_value;
|
||||
|
||||
push @$old_value , @values;
|
||||
$self->$setter( $old_value );
|
||||
};
|
||||
}
|
||||
|
||||
# we're called as $obj->find_something($ns, $key)
|
||||
elsif ($subname =~s {^find_}{get_}xms) {
|
||||
@values = @{ $values[0] } if ref $values[0] eq 'ARRAY';
|
||||
return sub {
|
||||
return first {
|
||||
$_->get_targetNamespace() eq $values[0] &&
|
||||
$_->get_name() eq $values[1]
|
||||
}
|
||||
@{ $self->$subname() };
|
||||
}
|
||||
}
|
||||
elsif ($subname =~s {^first_}{get_}xms) {
|
||||
return sub {
|
||||
my $result_ref = $self->$subname();
|
||||
return if not $result_ref;
|
||||
return $result_ref if (not ref $result_ref eq 'ARRAY');
|
||||
return $result_ref->[0];
|
||||
};
|
||||
}
|
||||
confess "$subname not found in class " . (ref $self || $self) ;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
foreach my $value (@args)
|
||||
{
|
||||
die @args if (not defined ($value->{ Name }));
|
||||
if ($value->{ Name } =~m{^xmlns\:}xms) {
|
||||
die $xmlns_of{ ident $self }
|
||||
if ref $xmlns_of{ ident $self } ne 'HASH';
|
||||
|
||||
# add namespaces
|
||||
$xmlns_of{ ident $self }->{ $value->{ Value } } =
|
||||
$value->{ LocalName };
|
||||
|
||||
next;
|
||||
}
|
||||
elsif ($value->{ Name } =~m{^xmlns$}xms) {
|
||||
# just ignore xmlns = for now
|
||||
# TODO handle xmlns correctly - maybe via setting a prefix ?
|
||||
next;
|
||||
}
|
||||
|
||||
my $name = $value->{ LocalName };
|
||||
my $method = "set_$name";
|
||||
$self->$method( $value->{ Value } );
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub add_namespace {
|
||||
my ($self, $uri, $prefix ) = @_;
|
||||
return unless $uri;
|
||||
$self->{ namespace } ||= {};
|
||||
$self->{ namespace }->{ $uri } = $prefix;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
warn "to_typemap";
|
||||
return q{};
|
||||
}
|
||||
|
||||
sub expand {
|
||||
my ($self, , $qname) = @_;
|
||||
my ($prefix, $localname) = split /:/, $qname;
|
||||
my %ns_map = reverse %{ $self->get_xmlns() };
|
||||
return ($ns_map{ $prefix }, $localname) if ($ns_map{ $prefix });
|
||||
|
||||
if (my $parent = $self->get_parent()) {
|
||||
return $parent->expand($qname);
|
||||
}
|
||||
die "unbound prefix $prefix found for $prefix:$localname";
|
||||
}
|
||||
sub _expand;
|
||||
*_expand = \&expand;
|
||||
|
||||
|
||||
sub to_class {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $template = shift;
|
||||
|
||||
$opt->{ base_path } ||= '.';
|
||||
|
||||
my $element_prefix = $opt->{ element_prefix } || $opt->{ prefix };
|
||||
my $type_prefix = $opt->{ type_prefix } || $opt->{ prefix };
|
||||
|
||||
if (($type_prefix) && ($type_prefix !~m{ :: $ }xms ) ) {
|
||||
warn 'type_prefix should end with "::"';
|
||||
$type_prefix .= '::';
|
||||
}
|
||||
|
||||
if (($element_prefix) && ($element_prefix !~m{ :: $ }xms) ) {
|
||||
warn 'element_prefix should end with "::"';
|
||||
$element_prefix .= '::';
|
||||
}
|
||||
|
||||
# Be careful: a Element may be ComplexType, too
|
||||
# (but not vice versa)
|
||||
my $prefix = $self->isa('SOAP::WSDL::XSD::Element')
|
||||
? $element_prefix
|
||||
: $type_prefix;
|
||||
|
||||
die 'No prefix specified' if not $prefix;
|
||||
|
||||
my $filename = $prefix . $self->get_name() . '.pm';
|
||||
$filename =~s{::}{/}xmsg;
|
||||
|
||||
my $output = $opt->{ output } || $filename;
|
||||
|
||||
require Template;
|
||||
my $tt = Template->new(
|
||||
RELATIVE => 1,
|
||||
OUTPUT_PATH => $opt->{ base_path },
|
||||
);
|
||||
|
||||
my $code = $tt->process( \$template, {
|
||||
element_prefix => $element_prefix,
|
||||
type_prefix => $type_prefix,
|
||||
self => $self,
|
||||
nsmap => { reverse %{ $opt->{ wsdl }->get_xmlns() } },
|
||||
structure => $self->explain( { wsdl => $opt->{ wsdl } } ),
|
||||
},
|
||||
$output
|
||||
)
|
||||
or die $tt->error();
|
||||
}
|
||||
1;
|
||||
13
lib/SOAP/WSDL/Binding.pm
Normal file
13
lib/SOAP/WSDL/Binding.pm
Normal file
@@ -0,0 +1,13 @@
|
||||
package SOAP::WSDL::Binding;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use List::Util qw(first);
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %operation_of :ATTR(:name<operation> :default<()>);
|
||||
my %type_of :ATTR(:name<type> :default<()>);
|
||||
my %transport_of :ATTR(:name<transport> :default<()>);
|
||||
my %style_of :ATTR(:name<style> :default<()>);
|
||||
|
||||
1;
|
||||
382
lib/SOAP/WSDL/Client.pm
Normal file
382
lib/SOAP/WSDL/Client.pm
Normal file
@@ -0,0 +1,382 @@
|
||||
package SOAP::WSDL::Client;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
use Class::Std::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;
|
||||
|
||||
our $VERSION = '2.00_16';
|
||||
|
||||
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 %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 %deserializer_of :ATTR(:name<deserializer> :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 };
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
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();
|
||||
}
|
||||
|
||||
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 };
|
||||
|
||||
# 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 = 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);
|
||||
for (qw(class_resolver no_dispatch outputxml proxy)) {
|
||||
my $setter = "set_$_";
|
||||
my $getter = "get_$_";
|
||||
*{ $_ } = sub { my $self = shift;
|
||||
if (@_) {
|
||||
$self->$setter(@_);
|
||||
return $self;
|
||||
}
|
||||
return $self->$getter()
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub call {
|
||||
my ($self, $method, @data_from) = @_;
|
||||
my $ident = 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 '/', $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,
|
||||
});
|
||||
|
||||
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 },
|
||||
envelope => $envelope,
|
||||
action => $soap_action,
|
||||
on_receive_chunk => sub {} # optional, may be used for parsing large responses as they arrive.
|
||||
# might not be supported by all transport layers...
|
||||
# and, of course, only is of interest for chunk parsers -
|
||||
# namely ExpatNB and XML::LibXML's Push parser interface...
|
||||
);
|
||||
|
||||
return $response if ($outputxml_of{ $ident } );
|
||||
|
||||
# get deserializer
|
||||
$deserializer_of{ $ident } ||= SOAP::WSDL::Factory::Deserializer->get_deserializer({
|
||||
soap_version => $soap_version_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 ) {
|
||||
my $result = eval { $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"
|
||||
});
|
||||
};
|
||||
|
||||
# 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__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Client - SOAP::WSDL's SOAP Client
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 call
|
||||
|
||||
$soap->call( \%method, \@parts );
|
||||
|
||||
%method is a hash with the following keys:
|
||||
|
||||
Name Description
|
||||
----------------------------------------------------
|
||||
operation operation name
|
||||
soap_action SOAPAction HTTP header to use
|
||||
style Operation style. One of (document|rpc)
|
||||
use SOAP body encoding. One of (literal|encoded)
|
||||
|
||||
The style and use keys have no influence yet.
|
||||
|
||||
@parts is a list containing the elements of the message parts.
|
||||
|
||||
For backward compatibility, call may also be called as below:
|
||||
|
||||
$soap->call( $method, \@parts );
|
||||
|
||||
In this case, $method is the SOAP operation name, and the SOAPAction header
|
||||
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.
|
||||
|
||||
=head3 set_content_type
|
||||
|
||||
$soap->set_content_type('application/xml; charset: utf8');
|
||||
|
||||
Sets the content type and character encoding.
|
||||
|
||||
You probably should not use a character encoding different from utf8:
|
||||
SOAP::WSDL::Client will not convert the request into a different encoding
|
||||
(yet).
|
||||
|
||||
To leave out the encoding, just set the content type without appendet charset
|
||||
like in
|
||||
|
||||
text/xml
|
||||
|
||||
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.
|
||||
|
||||
=head2 Features different from SOAP::Lite
|
||||
|
||||
SOAP::WSDL does not aim to be a complete replacement for SOAP::Lite - the
|
||||
SOAP::Lite module has it's strengths and weaknesses and SOAP::WSDL is
|
||||
designed as a cure for the weakness of little WSDL support - nothing more,
|
||||
nothing less.
|
||||
|
||||
Nonetheless SOAP::WSDL mimics part of SOAP::Lite's API and behaviour,
|
||||
so SOAP::Lite users can switch without looking up every method call in the
|
||||
documentation.
|
||||
|
||||
A few things are quite different from SOAP::Lite, though:
|
||||
|
||||
=head3 SOAP request data
|
||||
|
||||
SOAP request data may either be given as message object, or as hash ref (in
|
||||
which case it will automatically be encoded into a message object).
|
||||
|
||||
=head3 Return values
|
||||
|
||||
The result from call() is not a SOAP::SOM object, but a message object.
|
||||
|
||||
Message objects' classes may be generated from WSDL definitions automatically
|
||||
- see SOAP::WSDL::Generator::Typelib on how to generate your own WSDL based
|
||||
message class library.
|
||||
|
||||
=head3 Fault handling
|
||||
|
||||
SOAP::WSDL::Client returns a fault object on errors, even on transport layer
|
||||
errors.
|
||||
|
||||
The fault object is a SOAP1.1 fault object of the following
|
||||
C<SOAP::WSDL::SOAP::Typelib::Fault11>.
|
||||
|
||||
SOAP::WSDL::SOAP::Typelib::Fault11 objects are false in boolean context, so
|
||||
you can just do something like
|
||||
|
||||
my $result = $soap->call($method, $data);
|
||||
|
||||
if ($result) {
|
||||
# handle result
|
||||
}
|
||||
else {
|
||||
die $result->faultstring();
|
||||
}
|
||||
|
||||
=head3 outputxml
|
||||
|
||||
SOAP::Lite returns only the content of the SOAP body when outputxml is set
|
||||
to true. SOAP::WSDL::Client returns the complete XML response.
|
||||
|
||||
=head3 Auto-Dispatching
|
||||
|
||||
SOAP::WSDL::Client does B<does not> support auto-dispatching.
|
||||
|
||||
This is on purpose: You may easily create interface classes by using
|
||||
SOAP::WSDL::Client and implementing something like
|
||||
|
||||
sub mySoapMethod {
|
||||
my $self = shift;
|
||||
$soap_wsdl_client->call( mySoapMethod, @_);
|
||||
}
|
||||
|
||||
You may even do this in a class factory - see L<wsdl2perl.pl> for creating
|
||||
such interfaces.
|
||||
|
||||
=head1 Troubleshooting
|
||||
|
||||
=head2 Accessing protected web services
|
||||
|
||||
Accessing protected web services is very specific for the transport
|
||||
backend used.
|
||||
|
||||
In general, you may pass additional arguments to the set_proxy method (or
|
||||
a list ref of the web service address and any additional arguments to the
|
||||
new method's I<proxy> argument).
|
||||
|
||||
Refer to the appropriate transport module for documentation.
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 288 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Client.pm 288 2007-09-29 19:34:20Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Client.pm $
|
||||
|
||||
=cut
|
||||
|
||||
121
lib/SOAP/WSDL/Client/Base.pm
Normal file
121
lib/SOAP/WSDL/Client/Base.pm
Normal file
@@ -0,0 +1,121 @@
|
||||
package SOAP::WSDL::Client::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'SOAP::WSDL::Client';
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
sub call {
|
||||
my ($self, $method, $body, $header) = @_;
|
||||
if (not blessed $body) {
|
||||
my $class = $method->{ body }->{ parts }->[0];
|
||||
eval "require $class" || die $@;
|
||||
$body = $class->new($body);
|
||||
}
|
||||
|
||||
# if we have a header
|
||||
if (%{ $method->{ header } }) {
|
||||
if (not blessed $header) {
|
||||
my $class = $method->{ header }->{ parts }->[0];
|
||||
eval "require $class" || die $@;
|
||||
$header = $class->new($header);
|
||||
}
|
||||
}
|
||||
return $self->SUPER::call($method, $body, $header);
|
||||
}
|
||||
|
||||
sub __create_new {
|
||||
my ($package, %args_of) = @_;
|
||||
|
||||
no strict qw(refs);
|
||||
|
||||
# TODO factor out and replace by generated START method
|
||||
*{ "$package\::new" } = sub {
|
||||
my $class = shift;
|
||||
my $self = $class->SUPER::new({
|
||||
proxy => $args_of{ proxy },
|
||||
class_resolver => $args_of{ class_resolver }
|
||||
});
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
}
|
||||
|
||||
sub __create_methods {
|
||||
my ($package, %info_of) = @_;
|
||||
|
||||
no strict qw(refs);
|
||||
|
||||
for my $method (keys %info_of){
|
||||
my ($soap_action, @parts);
|
||||
|
||||
# up to 2.00_10 we had list refs...
|
||||
if (ref $info_of{ $method }eq 'HASH') {
|
||||
@parts = @{ $info_of{ $method }->{ parts } };
|
||||
$soap_action = $info_of{ $method }->{ soap_action };
|
||||
}
|
||||
else {
|
||||
@parts = @{ $info_of{ $method } };
|
||||
$soap_action = ();
|
||||
}
|
||||
|
||||
*{ "$package\::$method" } = sub {
|
||||
my $self = shift;
|
||||
my @param = map {
|
||||
my $data = shift || {};
|
||||
eval "require $_";
|
||||
$_->new( $data );
|
||||
} @parts;
|
||||
|
||||
return $self->SUPER::call( {
|
||||
operation => $method,
|
||||
soap_action => $soap_action,
|
||||
}, @param );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Client::Base - Factory class for WSDL-based SOAP access
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MySoapInterface;
|
||||
use SOAP::WSDL::Client::Base;
|
||||
__PACKAGE__->__create_new(
|
||||
proxy => 'http://somewhere.over.the.rainbow',
|
||||
class_resolver => 'Typemap::MySoapInterface'
|
||||
);
|
||||
__PACKAGE__->__create_methods( qw(one two three) );
|
||||
1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Factory class for creating interface classes. Should probably be renamed to
|
||||
SOAP::WSDL::Factory::Interface...
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 283 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Base.pm 283 2007-09-27 19:06:29Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Client/Base.pm $
|
||||
|
||||
=cut
|
||||
127
lib/SOAP/WSDL/Definitions.pm
Normal file
127
lib/SOAP/WSDL/Definitions.pm
Normal file
@@ -0,0 +1,127 @@
|
||||
package SOAP::WSDL::Definitions;
|
||||
use utf8;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use File::Basename;
|
||||
use File::Path;
|
||||
use List::Util qw(first);
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %types_of :ATTR(:name<types> :default<[]>);
|
||||
my %message_of :ATTR(:name<message> :default<()>);
|
||||
my %portType_of :ATTR(:name<portType> :default<()>);
|
||||
my %binding_of :ATTR(:name<binding> :default<()>);
|
||||
my %service_of :ATTR(:name<service> :default<()>);
|
||||
my %namespace_of :ATTR(:name<namespace> :default<()>);
|
||||
|
||||
# must be attr for Class::Std::Storable
|
||||
my %attributes_of :ATTR();
|
||||
%attributes_of = (
|
||||
binding => \%binding_of,
|
||||
message => \%message_of,
|
||||
portType => \%portType_of,
|
||||
service => \%service_of,
|
||||
);
|
||||
|
||||
# Function factory - we could be writing this method for all %attribute
|
||||
# keys, too, but that's just C&P (eehm, Copy & Paste...)
|
||||
BLOCK: {
|
||||
no strict qw/refs/;
|
||||
foreach my $method(keys %attributes_of ) {
|
||||
|
||||
*{ "find_$method" } = sub {
|
||||
my ($self, @args_from) = @_;
|
||||
@args_from = @{ $args_from[0] } if ref $args_from[0] eq 'ARRAY';
|
||||
return first {
|
||||
$_->get_targetNamespace() eq $args_from[0]
|
||||
&& $_->get_name() eq $args_from[1]
|
||||
}
|
||||
@{ $attributes_of{ $method }->{ ident $self } };
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub listify {
|
||||
my $data = shift;
|
||||
return if not defined $data;
|
||||
return [ $data ] if not ref $data;
|
||||
return [ $data ] if not ref $data eq 'ARRAY';
|
||||
return $data;
|
||||
}
|
||||
|
||||
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).
|
||||
|
||||
=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
|
||||
|
||||
162
lib/SOAP/WSDL/Deserializer/Hash.pm
Normal file
162
lib/SOAP/WSDL/Deserializer/Hash.pm
Normal file
@@ -0,0 +1,162 @@
|
||||
package SOAP::WSDL::Deserializer::Hash;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::SOAP::Typelib::Fault11;
|
||||
use SOAP::WSDL::Expat::Message2Hash;
|
||||
|
||||
use SOAP::WSDL::Factory::Deserializer;
|
||||
SOAP::WSDL::Factory::Deserializer->register( '1.1', __PACKAGE__ );
|
||||
|
||||
our $VERSION='2.00_16';
|
||||
|
||||
sub BUILD {
|
||||
my ($self, $ident, $args_of_ref) = @_;
|
||||
|
||||
# ignore all options except 'class_resolver'
|
||||
for (keys %{ $args_of_ref }) {
|
||||
delete $args_of_ref->{ $_ }
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub deserialize {
|
||||
my ($self, $content) = @_;
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::Message2Hash->new();
|
||||
eval { $parser->parse_string( $content ) };
|
||||
if ($@) {
|
||||
die $self->generate_fault({
|
||||
code => 'soap:Server',
|
||||
role => 'urn:localhost',
|
||||
message => "Error deserializing message: $@. \n"
|
||||
. "Message was: \n$content"
|
||||
});
|
||||
}
|
||||
return $parser->get_data();
|
||||
}
|
||||
|
||||
sub generate_fault {
|
||||
my ($self, $args_from_ref) = @_;
|
||||
return SOAP::WSDL::SOAP::Typelib::Fault11->new({
|
||||
faultcode => $args_from_ref->{ code } || 'soap:Client',
|
||||
faultactor => $args_from_ref->{ role } || 'urn:localhost',
|
||||
faultstring => $args_from_ref->{ message } || "Unknown error"
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Deserializer::Hash - Deserializer SOAP messages into perl hash refs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SOAP::WSDL;
|
||||
use SOAP::WSDL::Deserializer::Hash;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Deserializer for creating perl hash refs as result of a SOAP call.
|
||||
|
||||
=head2 Output structure
|
||||
|
||||
The XML structure is converted into a perl data structure consisting of
|
||||
hash and or list references. List references are used for holding array data.
|
||||
|
||||
SOAP::WSDL::Deserializer::Hash creates list references always at the maximum
|
||||
depth possible.
|
||||
|
||||
Examples:
|
||||
|
||||
XML:
|
||||
<MyDataArray>
|
||||
<MyData>1</MyData>
|
||||
<MyData>1</MyData>
|
||||
</MyDataArray>
|
||||
|
||||
Perl:
|
||||
{
|
||||
MyDataArray => {
|
||||
MyData => [ 1, 1 ]
|
||||
}
|
||||
}
|
||||
|
||||
XML:
|
||||
<DeepArray>
|
||||
<MyData><int>1<int>/MyData>
|
||||
<MyData><int>1<int>/MyData>
|
||||
</DeepArray>
|
||||
|
||||
Perl:
|
||||
{
|
||||
MyDataArray => {
|
||||
MyData => [
|
||||
{ int => 1 },
|
||||
{ int => 1 }
|
||||
]
|
||||
}
|
||||
}
|
||||
|
||||
List reference creation is triggered by the second occurance of an element.
|
||||
XML Array types with one element only will not be represented as list
|
||||
references.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
All you need to do is to use SOAP::WSDL::Deserializer::Hash.
|
||||
|
||||
SOAP::WSDL::Deserializer::Hash autoregisters itself for SOAP1.1 messages
|
||||
|
||||
You may register SOAP::WSDLDeserializer::Hash for other SOAP Versions by
|
||||
calling
|
||||
|
||||
SOAP::Factory::Deserializer->register('1.2',
|
||||
SOAP::WSDL::Deserializer::Hash)
|
||||
|
||||
=head1 Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Namespaces
|
||||
|
||||
All namespaces are ignored.
|
||||
|
||||
=item * XML attributes
|
||||
|
||||
All XML attributes are ignored.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Differences from other SOAP::WSDL::Deserializer classes
|
||||
|
||||
=over
|
||||
|
||||
=item * generate_fault
|
||||
|
||||
SOAP::WSDL::Deserializer::Hash will die with a SOAP::WSDL::Fault11 object when
|
||||
a parse error appears
|
||||
|
||||
=back
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 176 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Serializer.pm 176 2007-08-31 15:28:29Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Serializer.pm $
|
||||
|
||||
=cut
|
||||
50
lib/SOAP/WSDL/Deserializer/SOAP11.pm
Normal file
50
lib/SOAP/WSDL/Deserializer/SOAP11.pm
Normal file
@@ -0,0 +1,50 @@
|
||||
package SOAP::WSDL::Deserializer::SOAP11;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::SOAP::Typelib::Fault11;
|
||||
use SOAP::WSDL::Expat::MessageParser;
|
||||
|
||||
our $VERSION='2.00_13';
|
||||
|
||||
my %class_resolver_of :ATTR(:name<class_resolver> :default<()>);
|
||||
|
||||
sub BUILD {
|
||||
my ($self, $ident, $args_of_ref) = @_;
|
||||
|
||||
# ignore all options except 'class_resolver'
|
||||
for (keys %{ $args_of_ref }) {
|
||||
delete $args_of_ref->{ $_ } if $_ ne 'class_resolver';
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub deserialize {
|
||||
my ($self, $content) = @_;
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => $class_resolver_of{ ident $self },
|
||||
});
|
||||
eval { $parser->parse_string( $content ) };
|
||||
if ($@) {
|
||||
return $self->generate_fault({
|
||||
code => 'soap:Server',
|
||||
role => 'urn:localhost',
|
||||
message => "Error deserializing message: $@. \n"
|
||||
. "Message was: \n$content"
|
||||
});
|
||||
}
|
||||
return $parser->get_data();
|
||||
}
|
||||
|
||||
sub generate_fault {
|
||||
my ($self, $args_from_ref) = @_;
|
||||
return SOAP::WSDL::SOAP::Typelib::Fault11->new({
|
||||
faultcode => $args_from_ref->{ code } || 'soap:Client',
|
||||
faultactor => $args_from_ref->{ role } || 'urn:localhost',
|
||||
faultstring => $args_from_ref->{ message } || "Unknown error"
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
124
lib/SOAP/WSDL/Deserializer/SOM.pm
Normal file
124
lib/SOAP/WSDL/Deserializer/SOM.pm
Normal file
@@ -0,0 +1,124 @@
|
||||
package SOAP::WSDL::Deserializer::SOM;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.00_15';
|
||||
our @ISA;
|
||||
|
||||
eval {
|
||||
require SOAP::Lite;
|
||||
push @ISA, 'SOAP::Deserializer';
|
||||
}
|
||||
or die "Cannot load SOAP::Lite.
|
||||
Cannot deserialize to SOM object without SOAP::Lite.
|
||||
Please install SOAP::Lite.";
|
||||
|
||||
sub generate_fault {
|
||||
my ($self, $args_from_ref) = @_;
|
||||
# code, message, detail, actor
|
||||
die SOAP::Fault->new(
|
||||
faultcode => $args_from_ref->{ code },
|
||||
faultstring => $args_from_ref->{ message },
|
||||
faultactor => $args_from_ref->{ role },
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Deserializer::SOM - Deserializer SOAP messages into SOM objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SOAP::WSDL;
|
||||
use SOAP::WSDL::Deserializer::SOM;
|
||||
use SOAP::WSDL::Factory::Deserializer;
|
||||
SOAP::WSDL::Factory::Deserializer->register( '1.1', __PACKAGE__ );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Deserializer for creating SOAP::Lite's SOM object as result of a SOAP call.
|
||||
|
||||
This package is here for two reasons:
|
||||
|
||||
=over
|
||||
|
||||
=item * Compatibility
|
||||
|
||||
You don't have to change the rest of your SOAP::Lite based app when switching
|
||||
to SOAP::WSDL, but can just use SOAP::WSDL::Deserializer::SOM to get back the
|
||||
same objects as you were used to.
|
||||
|
||||
=item * Completeness
|
||||
|
||||
SOAP::Lite covers much more of the SOAP specification than SOAP::WSDL.
|
||||
|
||||
SOAP::WSDL::Deserializer::SOM can be used for content which cannot be
|
||||
deserialized by L<SOAP::WSDL::Deserializer::SOAP11|SOAP::WSDL::Deserializer::SOAP11>.
|
||||
This may be XML including mixed content, attachements and other XML data not
|
||||
(yet) handled by L<SOAP::WSDL::Deserializer::SOAP11|SOAP::WSDL::Deserializer::SOAP11>.
|
||||
|
||||
=back
|
||||
|
||||
SOAP::WSDL::Deserializer::SOM is a subclass of L<SOAP::Deserializer|SOAP::Deserializer>
|
||||
from the L<SOAP::Lite|SOAP::Lite> package.
|
||||
|
||||
You may
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
SOAP::WSDL::Deserializer will not auroregister itself - to use it for a particular
|
||||
SOAP version just use the following lines:
|
||||
|
||||
my $soap_version = '1.1'; # or '1.2', further versions may appear.
|
||||
|
||||
use SOAP::WSDL::Deserializer::SOM;
|
||||
use SOAP::WSDL::Factory::Deserializer;
|
||||
SOAP::WSDL::Factory::Deserializer->register( $soap_version, __PACKAGE__ );
|
||||
|
||||
=head1 DIFFERENCES FROM OTHER CLASSES
|
||||
|
||||
=head2 Differences from SOAP::Lite
|
||||
|
||||
=over
|
||||
|
||||
=item * No on_fault handler
|
||||
|
||||
You cannot specify what to do when an error occurs - SOAP::WSDL will die
|
||||
with a SOAP::Fault object on transport errors.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Differences from other SOAP::WSDL::Deserializer classes
|
||||
|
||||
=over
|
||||
|
||||
=item * generate_fault
|
||||
|
||||
SOAP::WSDL::Deserializer::SOM will die with a SOAP::Fault object on calls
|
||||
to generate_fault.
|
||||
|
||||
=back
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 176 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Serializer.pm 176 2007-08-31 15:28:29Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Serializer.pm $
|
||||
|
||||
=cut
|
||||
170
lib/SOAP/WSDL/Expat/Message2Hash.pm
Normal file
170
lib/SOAP/WSDL/Expat/Message2Hash.pm
Normal file
@@ -0,0 +1,170 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::Message2Hash;
|
||||
use strict;
|
||||
use warnings;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
$self->{ parser } = $parser;
|
||||
delete $self->{ data }; # remove potential old results
|
||||
|
||||
my $characters;
|
||||
my $current = {};
|
||||
my $list = []; # node list
|
||||
my $current_part = q{}; # are we in header or body ?
|
||||
$self->{ data } = $current;
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_localname, $_element, $_method,
|
||||
$_class, $_parser, %_attrs) = ();
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
push @$list, $current;
|
||||
#If our element exists and is a list ref, add to it
|
||||
if ( exists $current->{ $_[1] }
|
||||
&& ( ref ($current->{ $_[1] }) eq 'ARRAY')
|
||||
) {
|
||||
push @{ $current->{ $_[1] } }, {};
|
||||
$current = $current->{ $_[1] }->[-1];
|
||||
}
|
||||
elsif ( exists $current->{ $_[1] } )
|
||||
{
|
||||
$current->{ $_[1] } = [ $current->{ $_[1] }, {} ];
|
||||
$current = $current->{ $_[1] }->[-1];
|
||||
}
|
||||
else {
|
||||
$current->{ $_[1] } = {};
|
||||
$current = $current->{ $_[1] };
|
||||
}
|
||||
return;
|
||||
},
|
||||
|
||||
Char => sub {
|
||||
$characters .= $_[1] if $_[1] !~m{ \A \s* \z}xms;
|
||||
return;
|
||||
},
|
||||
|
||||
End => sub {
|
||||
$_element = $_[1];
|
||||
($_prefix, $_localname) = split m{:}xms , $_element;
|
||||
$_localname ||= $_element; # for non-prefixed elements
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
# return if not ref $$list[-1];
|
||||
|
||||
if (length $characters) {
|
||||
if (ref $list->[-1]->{ $_element } eq 'ARRAY') {
|
||||
$list->[-1]->{ $_element }->[-1] = $characters ;
|
||||
}
|
||||
else {
|
||||
$list->[-1]->{ $_element } = $characters;
|
||||
}
|
||||
}
|
||||
$characters = q{};
|
||||
$current = pop @$list; # step up in object hierarchy...
|
||||
return;
|
||||
}
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new( Namespaces => 1 ) )->parse( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
die $@ if $@;
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new( Namespaces => 1 ) )->parsefile( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
die $@, $_[1] if $@;
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
# SAX-like aliases
|
||||
sub parse_string;
|
||||
*parse_string = \&parse;
|
||||
|
||||
sub parse_file;
|
||||
*parse_file = \&parsefile;
|
||||
|
||||
sub get_data {
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Real fast expat based SOAP message parser.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=head2 Skipping unwanted items
|
||||
|
||||
Sometimes there's unneccessary information transported in SOAP messages.
|
||||
|
||||
To skip XML nodes (including all child nodes), just edit the type map for
|
||||
the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Ignores all namespaces
|
||||
|
||||
=item * Does not handle mixed content
|
||||
|
||||
=item * The SOAP header is ignored
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-09-10 18:19:23 +0200 (Mo, 10 Sep 2007) $
|
||||
$LastChangedRevision: 218 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
|
||||
|
||||
261
lib/SOAP/WSDL/Expat/MessageParser.pm
Normal file
261
lib/SOAP/WSDL/Expat/MessageParser.pm
Normal file
@@ -0,0 +1,261 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::MessageParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver },
|
||||
strict => exists $args->{ strict } ? $args->{ strict } : 1,
|
||||
};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub class_resolver {
|
||||
my $self = shift;
|
||||
$self->{ class_resolver } = shift;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
$self->{ parser } = $parser;
|
||||
|
||||
delete $self->{ data }; # remove potential old results
|
||||
|
||||
my $characters;
|
||||
#my @characters_from = ();
|
||||
my $current = undef;
|
||||
my $list = []; # node list
|
||||
my $path = []; # current path
|
||||
my $skip = 0; # skip elements
|
||||
my $current_part = q{}; # are we in header or body ?
|
||||
|
||||
my $depth = 0;
|
||||
|
||||
my %content_check = $self->{strict}
|
||||
? (
|
||||
0 => sub {
|
||||
die "Bad top node $_[1]" if $_[1] ne 'Envelope';
|
||||
die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string()
|
||||
if $_[0]->namespace($_[1]) ne 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
$depth++;
|
||||
return;
|
||||
},
|
||||
1 => sub {
|
||||
$depth++;
|
||||
return;
|
||||
}
|
||||
)
|
||||
: ();
|
||||
|
||||
my $char_handler = sub {
|
||||
# push @characters_from, $_[1] if $_[1] =~m{ [^s] }xms;
|
||||
$characters .= $_[1] if $_[1] =~m{ [^\s] }xms;
|
||||
|
||||
return;
|
||||
};
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_method,
|
||||
$_class) = ();
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
# my ($parser, $element, %_attrs) = @_;
|
||||
# $depth = $parser->depth();
|
||||
|
||||
# call methods without using their parameter stack
|
||||
# That's slightly faster than $content_check{ $depth }->()
|
||||
# and we don't have to pass $_[1] to the method.
|
||||
# Yup, that's dirty.
|
||||
return &{$content_check{ $depth }} if exists $content_check{ $depth };
|
||||
|
||||
push @{ $path }, $_[1]; # step down in path
|
||||
return if $skip; # skip inside __SKIP__
|
||||
|
||||
# resolve class of this element
|
||||
$_class = $self->{ class_resolver }->get_class( $path )
|
||||
or die "Cannot resolve class for "
|
||||
. join('/', @{ $path }) . " via " . $self->{ class_resolver };
|
||||
|
||||
if ($_class eq '__SKIP__') {
|
||||
$skip = join('/', @{ $path });
|
||||
$self->setHandlers( Char => undef );
|
||||
return;
|
||||
}
|
||||
|
||||
push @$list, $current; # step down in tree ()remember current)
|
||||
|
||||
$characters = q(); # empty characters
|
||||
#@characters_from = ();
|
||||
|
||||
# Check whether we have a builtin - we implement them as classes
|
||||
# We could replace this with UNIVERSAL->isa() - but it's slow...
|
||||
# match is a bit faster if the string does not match, but WAY slower
|
||||
# if $class matches...
|
||||
if (index $_class, 'SOAP::WSDL::XSD::Typelib::Builtin', 0 < 0) {
|
||||
# check wheter there is a non-empty ARRAY reference for $_class::ISA
|
||||
# or a "new" method
|
||||
# If not, require it - all classes required here MUST
|
||||
# define new()
|
||||
# This is not exactly the same as $class->can('new'), but it's way faster
|
||||
defined *{ "$_class\::new" }{ CODE }
|
||||
or scalar @{ *{ "$_class\::ISA" }{ ARRAY } }
|
||||
or eval "require $_class" ## no critic qw(ProhibitStringyEval)
|
||||
or die $@;
|
||||
}
|
||||
|
||||
$current = $_class->new({ @_[2..$#_] }); # set new current object
|
||||
|
||||
# remember top level element
|
||||
exists $self->{ data }
|
||||
or ($self->{ data } = $current);
|
||||
$depth++;
|
||||
return;
|
||||
},
|
||||
|
||||
Char => $char_handler,
|
||||
|
||||
End => sub {
|
||||
|
||||
pop @{ $path }; # step up in path
|
||||
|
||||
if ($skip) {
|
||||
return if $skip ne join '/', @{ $path }, $_[1];
|
||||
$skip = 0;
|
||||
$_[0]->setHandler( Char => $char_handler );
|
||||
return;
|
||||
}
|
||||
|
||||
$depth--;
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
return if not ref $list->[-1];
|
||||
|
||||
# set characters in current if we are a simple type
|
||||
# we may have characters in complexTypes with simpleContent,
|
||||
# too - maybe we should rely on the presence of characters ?
|
||||
# may get a speedup by defining a ident method in anySimpleType
|
||||
# and looking it up via exists &$class::ident;
|
||||
# if ( $current->isa('SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType') ) {
|
||||
# $current->set_value( $characters );
|
||||
# }
|
||||
# currently doesn't work, as anyType does not implement value -
|
||||
# maybe change ?
|
||||
$current->set_value( $characters ) if (length $characters);
|
||||
#$current->set_value( join @characters_from ) if (@characters_from);
|
||||
$characters = q{};
|
||||
# undef @characters_from;
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
#$_method = "add_$_localname";
|
||||
$_method = "add_$_[1]";
|
||||
$list->[-1]->$_method( $current );
|
||||
|
||||
$current = pop @$list; # step up in object hierarchy...
|
||||
return;
|
||||
}
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
eval {
|
||||
$_[0]->_initialize(
|
||||
XML::Parser::Expat->new(
|
||||
Namespaces => 1
|
||||
)
|
||||
)->parse( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
$_[0]->{ parser }->xpcroak( $@ ) if $@;
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new(Namespaces => 1) )->parsefile( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
die $@, $_[1] if $@;
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
# SAX-like aliases
|
||||
sub parse_string;
|
||||
*parse_string = \&parse;
|
||||
|
||||
sub parse_file;
|
||||
*parse_file = \&parsefile;
|
||||
|
||||
sub get_data {
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Real fast expat based SOAP message parser.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=head2 Skipping unwanted items
|
||||
|
||||
Sometimes there's unneccessary information transported in SOAP messages.
|
||||
|
||||
To skip XML nodes (including all child nodes), just edit the type map for
|
||||
the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Ignores all namespaces
|
||||
|
||||
=item * Does not handle mixed content
|
||||
|
||||
=item * The SOAP header is ignored
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-09-27 21:06:29 +0200 (Don, 27 Sep 2007) $
|
||||
$LastChangedRevision: 283 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
|
||||
|
||||
241
lib/SOAP/WSDL/Expat/MessageParser_BROKEN.pm
Normal file
241
lib/SOAP/WSDL/Expat/MessageParser_BROKEN.pm
Normal file
@@ -0,0 +1,241 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::MessageParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver },
|
||||
};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub class_resolver {
|
||||
my $self = shift;
|
||||
$self->{ class_resolver } = shift;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
$self->{ parser } = $parser;
|
||||
|
||||
delete $self->{ data };
|
||||
|
||||
my $characters = q{};
|
||||
my $current = undef;
|
||||
my $list = []; # node list
|
||||
my $path = []; # current path
|
||||
my $current_part = q{}; # are we in header or body ?
|
||||
my $depth = 0;
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_method,
|
||||
$_class) = ();
|
||||
|
||||
my @check_sub_from = (
|
||||
);
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
# my ($parser, $element, %_attrs) = @_;
|
||||
#return if $skip; # skip inside __SKIP__
|
||||
return if exists $self->{ skip };
|
||||
|
||||
$_[1] =~s{ \w+: }{}xms;
|
||||
|
||||
if ($depth <=1) {
|
||||
if ($depth == 0) {
|
||||
die "Bad top node $_[1]" if $_[1] ne 'Envelope';
|
||||
# die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string()
|
||||
# if $_[0]->namespace($_[1]) ne 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
$depth++;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
die "Bad node $_[1]. Expected (Header|Body)" if $_[1] !~ m{(:?Header|Body)}xms;
|
||||
$depth++;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
push @{ $path }, $_[1]; # step down in path
|
||||
|
||||
# resolve class of this element
|
||||
$_class = $self->{ class_resolver }->get_class( $path )
|
||||
or do {
|
||||
die "Cannot resolve class for "
|
||||
. join('/', @{ $path }) . " via " . $self->{ class_resolver };
|
||||
};
|
||||
|
||||
return $self->{skip} = join('/', @{ $path }) if ($_class eq '__SKIP__');
|
||||
|
||||
push @$list, $current; # step down in tree ()remember current)
|
||||
|
||||
# $characters = q(); # empty characters
|
||||
|
||||
# Check whether we have a primitive - we implement them as classes
|
||||
# We could replace this with UNIVERSAL->isa() - but it's slow...
|
||||
# match is a bit faster if the string does not match, but WAY slower
|
||||
# if $class matches...
|
||||
|
||||
if (index $_class, 'SOAP::WSDL::XSD::Typelib::Builtin', 0 < 0) {
|
||||
# check wheter there is a non-empty ARRAY reference for $_class::ISA
|
||||
# or a "new" method
|
||||
# If not, require it - all classes required here MUST
|
||||
# define new() or inherit from something defining it.
|
||||
# This is not exactly the same as $class->can('new'), but it's way faster
|
||||
defined *{ "$_class\::new" }{ CODE }
|
||||
or scalar @{ *{ "$_class\::ISA" }{ ARRAY } }
|
||||
or eval "require $_class" ## no critic qw(ProhibitStringyEval)
|
||||
or die $@;
|
||||
}
|
||||
|
||||
# create new object and pass it all attributes - remember, we're
|
||||
# called with
|
||||
# ($parser, $element, %attrs) = @_, so we can just give it
|
||||
# everything from @_[2..$#_]...
|
||||
$current = $_class->new({ @_[2..$#_] }); # set new current object
|
||||
|
||||
# remember top level element
|
||||
defined $self->{ data }
|
||||
or $self->{ data } = $current;
|
||||
|
||||
$depth++; # step down (once again)
|
||||
},
|
||||
|
||||
Char => sub {
|
||||
return if exists $self->{skip};
|
||||
return if $_[1] =~ m{ \A \s* \z}xs;
|
||||
$characters .= $_[1];
|
||||
},
|
||||
|
||||
End => sub {
|
||||
pop @{ $path }; # step up in path
|
||||
|
||||
if (exists $self->{skip}) {
|
||||
return if $self->{skip} ne join '/', @{ $path }, $_[1];
|
||||
delete $self->{skip};
|
||||
return;
|
||||
}
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
return if not ref $list->[-1];
|
||||
|
||||
# set characters in current if we are a simple type
|
||||
# we may have characters in complexTypes with simpleContent,
|
||||
# too - maybe we should rely on the presence of characters ?
|
||||
# may get a speedup by defining a ident method in anySimpleType
|
||||
# and looking it up via exists &$class::ident;
|
||||
|
||||
$current->set_value( $characters ) if (length $characters);
|
||||
$characters = q{};
|
||||
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
#$_method = "add_$_localname";
|
||||
$_method = "add_$_[1]";
|
||||
$list->[-1]->$_method( $current );
|
||||
|
||||
$current = pop @$list; # step up in object hierarchy...
|
||||
$depth--;
|
||||
# print $self->{ data };
|
||||
}
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new() )->parse( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
die $@ if $@;
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new() )->parsefile( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
die $@, $_[1] if $@;
|
||||
return die $_[0]->{ data };
|
||||
}
|
||||
|
||||
# SAX-like aliases
|
||||
sub parse_string;
|
||||
*parse_string = \&parse;
|
||||
|
||||
sub parse_file;
|
||||
*parse_file = \&parsefile;
|
||||
|
||||
sub get_data {
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Real fast expat based SOAP message parser.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=head2 Skipping unwanted items
|
||||
|
||||
Sometimes there's unneccessary information transported in SOAP messages.
|
||||
|
||||
To skip XML nodes (including all child nodes), just edit the type map for
|
||||
the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Ignores all namespaces
|
||||
|
||||
=item * Does not handle mixed content
|
||||
|
||||
=item * The SOAP header is ignored
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-09-19 13:05:07 +0200 (Mi, 19 Sep 2007) $
|
||||
$LastChangedRevision: 261 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
|
||||
|
||||
75
lib/SOAP/WSDL/Expat/MessageStreamParser.pm
Normal file
75
lib/SOAP/WSDL/Expat/MessageStreamParser.pm
Normal file
@@ -0,0 +1,75 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::MessageStreamParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use XML::Parser::Expat;
|
||||
use SOAP::WSDL::Expat::MessageParser;
|
||||
use base qw(SOAP::WSDL::Expat::MessageParser);
|
||||
|
||||
sub parse_start {
|
||||
my $self = shift;
|
||||
$self->{ parser } = $_[0]->_initialize( XML::Parser::ExpatNB->new() );
|
||||
}
|
||||
sub init;
|
||||
*init = \&parse_start;
|
||||
|
||||
sub parse_more {
|
||||
$_[0]->{ parser }->parse_more( $_[1] );
|
||||
}
|
||||
|
||||
sub parse_done {
|
||||
$_[0]->{ parser }->parse_done();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::MessageStreamParser - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $lwp = LWP::UserAgent->new();
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
my $chunk_parser = $parser->init();
|
||||
# process response while it comes in, trying to read 32k chunks.
|
||||
$lwp->request( $request, sub { $chunk_parser->parse_more($_[0]) } , 32468 );
|
||||
$chunk_parser->parse_done();
|
||||
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ExpatNB based parser for parsing huge documents.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
See SOAP::WSDL::Expat::MessageParser
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-09-10 17:54:52 +0200 (Mon, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageStreamParser.pm $
|
||||
|
||||
213
lib/SOAP/WSDL/Expat/MessageSubParser.pm
Normal file
213
lib/SOAP/WSDL/Expat/MessageSubParser.pm
Normal file
@@ -0,0 +1,213 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::MessageSubParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
# create handlers via currying - XML::Compiled is a good teacher...
|
||||
#
|
||||
# A handler has to know
|
||||
# - the order of it's child elements
|
||||
# - the classes for these child elements
|
||||
# - the handlers for these child elements (sub refs)
|
||||
|
||||
# order is checked if provided
|
||||
|
||||
sub start_tag {
|
||||
my $self = shift;
|
||||
my $arg_ref = shift;
|
||||
|
||||
my $CHILD_ORDER = $arg_ref->{ order } || [];
|
||||
my $CHILD_CLASS = $arg_ref->{ class_of } || {};
|
||||
my $CHILD_HANDLER = $arg_ref->{ handler_of };
|
||||
my $CHILD_OCCURS = $arg_ref->{ occurs_of } || {};
|
||||
|
||||
my $CHILD_INDEX = 0;
|
||||
|
||||
|
||||
return sub {
|
||||
# parser, element, attrs
|
||||
my ($prefix, $localname) = split m{:}xms , $_[1];
|
||||
$localname ||= $_[1];
|
||||
|
||||
=pod
|
||||
|
||||
# # implement better checks...
|
||||
# if (@{ $CHILD_ORDER }) {
|
||||
# if ($CHILD_ORDER->[$CHILD_INDEX] ne $localname) {
|
||||
# if (! $CHILD_ORDER->[++$CHILD_INDEX]
|
||||
# || $CHILD_ORDER->[$CHILD_INDEX] ne $localname) {
|
||||
# die "misplaced xml element " . $parser->recognized_string()
|
||||
# . " at line "
|
||||
# . $parser->current_line()
|
||||
# . " column " . $parser->current_column() , "\n"
|
||||
# , "Element order: " . join(',' , @{ $CHILD_ORDER }), "\n"
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# if (%{ $CHILD_OCCURS }) {
|
||||
# die "too many occurances of $localname at line "
|
||||
# . $parser->current_line()
|
||||
# . " column " . $parser->current_column() , "\n"
|
||||
# if (not --$CHILD_OCCURS->{ $localname }->{ max });
|
||||
#
|
||||
# # min must be checked in end_element !
|
||||
# $CHILD_OCCURS->{ $localname }->{ min }--
|
||||
# if ($CHILD_OCCURS->{ $localname }->{ min });
|
||||
# }
|
||||
|
||||
=cut
|
||||
|
||||
# remove this some day
|
||||
return if ($localname eq 'Envelope');
|
||||
return if ($localname eq 'Body');
|
||||
|
||||
# step down in tree (remember current)
|
||||
push @{ $self->{ list } }, $self->{ current };
|
||||
$self->{ current } = $CHILD_CLASS->{ $localname }->new({ @_[2..$#_] });
|
||||
|
||||
# Set (and remember) next state
|
||||
push @{ $self->{ handlers } }, $CHILD_HANDLER->{ $localname };
|
||||
$_[0]->setHandlers( %{ $CHILD_HANDLER->{ $localname } } );
|
||||
};
|
||||
}
|
||||
|
||||
# characters is a good candidate for replacement when not needed -
|
||||
# expat calls it for those whitespaces in non-mixed-content-elements, too
|
||||
sub characters {
|
||||
my $self = shift;
|
||||
return sub { $self->{ characters } .= $_[1] };
|
||||
}
|
||||
|
||||
# end_tag is a somewhat generic thingy - don't know whether we should
|
||||
# curry it, and whether this will speed us up...
|
||||
sub end_tag {
|
||||
my $self = shift;
|
||||
|
||||
return sub {
|
||||
# step down handler hierarchy
|
||||
pop @{ $self->{ handlers } };
|
||||
|
||||
# restore state: set handler to last handler
|
||||
$_[0]->setHandlers( %{ $self->{ handlers }->[ -1 ] } );
|
||||
|
||||
my ($prefix, $localname) = split m{:}xms , $_[1];
|
||||
$localname ||= $_[1]; # for non-prefixed elements
|
||||
|
||||
# we only have characters if we need them - if not Char handler
|
||||
# has to be set to undef
|
||||
$self->{ current }->set_value( $self->{ characters } )
|
||||
if ($self->{ characters });
|
||||
|
||||
# empty temp characters
|
||||
undef $self->{ characters };
|
||||
|
||||
# return if we're top node
|
||||
# This one easily handles ignores for us, too...
|
||||
#
|
||||
# Hmm... could be replaced by something else, maybe ???
|
||||
# Maybe by defining an empty end_tag handler for the top node ?
|
||||
# Can we do this ???
|
||||
return if not defined $self->{ list }->[-1];
|
||||
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
my $method = "add_$localname";
|
||||
$self->{ list }->[-1]->$method( $self->{ current } );
|
||||
|
||||
# step up in object hierarchy...
|
||||
$self->{ current } = pop @{ $self->{ list } };
|
||||
};
|
||||
}
|
||||
|
||||
sub end_top_tag {
|
||||
my $self = shift;
|
||||
return sub {};
|
||||
}
|
||||
|
||||
sub initialize {
|
||||
my ($self, $handler_of_ref, $parser ) = @_;
|
||||
$parser ||= XML::Parser::Expat->new();
|
||||
$self->{ list } = undef;
|
||||
$self->{ current } = undef;
|
||||
$self->{ characters } = q{}; # empty characters
|
||||
$self->{ handlers } = [ $handler_of_ref ];
|
||||
$parser->setHandlers( %$handler_of_ref );
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
return $_[0]->{ current };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Real fast expat based SOAP message parser.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=head2 Skipping unwanted items
|
||||
|
||||
Sometimes there's unneccessary information transported in SOAP messages.
|
||||
|
||||
To skip XML nodes (including all child nodes), just edit the type map for
|
||||
the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Ignores all namespaces
|
||||
|
||||
=item * Does not handle mixed content
|
||||
|
||||
=item * The SOAP header is ignored
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-09-10 17:54:52 +0200 (Mon, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageSubParser.pm $
|
||||
|
||||
|
||||
219
lib/SOAP/WSDL/Expat/SubParser.pm
Normal file
219
lib/SOAP/WSDL/Expat/SubParser.pm
Normal file
@@ -0,0 +1,219 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::MessageSubParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver }
|
||||
};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub class_resolver {
|
||||
my $self = shift;
|
||||
$self->{ class_resolver } = shift;
|
||||
}
|
||||
|
||||
sub _start;
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
|
||||
delete $self->{ data };
|
||||
|
||||
my $characters;
|
||||
my $current = undef;
|
||||
my $ignore = [ 'Envelope', 'Body' ]; # top level elements to ignore
|
||||
my $list = []; # node list
|
||||
my $path = []; # current path (without
|
||||
# number)
|
||||
my $skip = 0; # skip elements
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_localname, $_element, $_method,
|
||||
$_class, $_parser, %_attrs) = ();
|
||||
|
||||
no strict qw(refs);
|
||||
|
||||
my $start_sub = sub {
|
||||
($_parser, $_element, %_attrs) = @_;
|
||||
($_prefix, $_localname) = split m{:}xms , $_element;
|
||||
|
||||
# $parser->setHandlers( Start => \&_start );
|
||||
|
||||
$_localname ||= $_element; # for non-prefixed elements
|
||||
|
||||
# ignore top level elements
|
||||
if (@{ $ignore } && $_localname eq $ignore->[0]) {
|
||||
shift @{ $ignore };
|
||||
return;
|
||||
}
|
||||
|
||||
push @{ $path }, $_localname; # step down in path
|
||||
return if $skip; # skip inside __SKIP__
|
||||
|
||||
# resolve class of this element
|
||||
$_class = $self->{ class_resolver }->get_class( $path )
|
||||
or die "Cannot resolve class for "
|
||||
. join('/', @{ $path }) . " via $self->{ class_resolver }";
|
||||
|
||||
# maybe write as "return $skip = join ... if (...)" ?
|
||||
# would save a BLOCK...
|
||||
return $skip = join('/', @{ $path }) if ($_class eq '__SKIP__');
|
||||
|
||||
push @$list, $current; # step down in tree ()remember current)
|
||||
|
||||
$characters = q{}; # empty characters
|
||||
|
||||
# Check whether we have a primitive - we implement them as classes
|
||||
# We could replace this with UNIVERSAL->isa() - but it's slow...
|
||||
# match is a bit faster if the string does not match, but WAY slower
|
||||
# if $class matches...
|
||||
|
||||
if (index $_class, 'SOAP::WSDL::XSD::Typelib::Builtin', 0 < 0) {
|
||||
# check wheter there is a CODE reference for $class::new.
|
||||
# If not, require it - all classes required here MUST
|
||||
# define new()
|
||||
# This is the same as $class->can('new'), but it's way faster
|
||||
*{ "$_class\::new" }{ CODE }
|
||||
or eval "require $_class" ## no critic qw(ProhibitStringyEval)
|
||||
or die $@;
|
||||
}
|
||||
|
||||
$current = $_class->new({ %_attrs }); # set new current object
|
||||
|
||||
# remember top level element
|
||||
defined $self->{ data }
|
||||
or ($self->{ data } = $current);
|
||||
};
|
||||
|
||||
my $char_sub = sub {
|
||||
return if $skip;
|
||||
$characters .= $_[1];
|
||||
};
|
||||
|
||||
my $end_sub = sub {
|
||||
$_element = $_[1];
|
||||
|
||||
($_prefix, $_localname) = split m{:}xms , $_element;
|
||||
$_localname ||= $_element; # for non-prefixed elements
|
||||
|
||||
pop @{ $path }; # step up in path
|
||||
|
||||
if ($skip) {
|
||||
return if $skip ne join '/', @{ $path }, $_localname;
|
||||
$skip = 0;
|
||||
return;
|
||||
}
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
return if not ref $$list[-1];
|
||||
|
||||
# set characters in current if we are a simple type
|
||||
# we may have characters in complexTypes with simpleContent,
|
||||
# too - maybe we should rely on the presence of characters ?
|
||||
# may get a speedup by defining a ident method in anySimpleType
|
||||
# and looking it up via exists &$class::ident;
|
||||
if ( $current->isa('SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType') ) {
|
||||
$current->set_value( $characters );
|
||||
}
|
||||
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
$_method = "add_$_localname";
|
||||
$$list[-1]->$_method( $current );
|
||||
|
||||
$current = pop @$list; # step up in object hierarchy...
|
||||
};
|
||||
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
$_[0]->setHandlers( Start => $start_sub );
|
||||
$start_sub->(@_) },
|
||||
Char => $char_sub,
|
||||
End => $end_sub,
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new() )->parse( $_[1] );
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new() )->parsefile( $_[1] );
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Real fast expat based SOAP message parser.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=head2 Skipping unwanted items
|
||||
|
||||
Sometimes there's unneccessary information transported in SOAP messages.
|
||||
|
||||
To skip XML nodes (including all child nodes), just edit the type map for
|
||||
the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Ignores all namespaces
|
||||
|
||||
=item * Does not handle mixed content
|
||||
|
||||
=item * The SOAP header is ignored
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-09-10 17:54:52 +0200 (Mon, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/SubParser.pm $
|
||||
|
||||
|
||||
178
lib/SOAP/WSDL/Expat/WSDLParser.pm
Normal file
178
lib/SOAP/WSDL/Expat/WSDLParser.pm
Normal file
@@ -0,0 +1,178 @@
|
||||
package SOAP::WSDL::Expat::WSDLParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use SOAP::WSDL::TypeLookup;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
|
||||
# init object data
|
||||
$self->{ parser } = $parser;
|
||||
delete $self->{ data };
|
||||
|
||||
# setup local variables for keeping temp data
|
||||
my $characters = undef;
|
||||
my $current = undef;
|
||||
my $list = []; # node list
|
||||
|
||||
# TODO skip non-XML Schema namespace tags
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
my ($parser, $localname, %attrs) = @_;
|
||||
$characters = q{};
|
||||
|
||||
my $action = SOAP::WSDL::TypeLookup->lookup(
|
||||
$parser->namespace($localname),
|
||||
$localname
|
||||
);
|
||||
|
||||
return if not $action;
|
||||
|
||||
if ($action->{ type } eq 'CLASS') {
|
||||
eval "require $action->{ class }";
|
||||
croak $@ if ($@);
|
||||
|
||||
my $obj = $action->{ class }->new({ parent => $current })
|
||||
->init( _fixup_attrs( $parser, %attrs ) );
|
||||
|
||||
if ($current) {
|
||||
# inherit namespace, but don't override
|
||||
$obj->set_targetNamespace( $current->get_targetNamespace() )
|
||||
if not $obj->get_targetNamespace();
|
||||
|
||||
# push on parent's element/type list
|
||||
my $method = "push_$localname";
|
||||
|
||||
no strict qw(refs);
|
||||
$current->$method( $obj );
|
||||
|
||||
# remember element for stepping back
|
||||
push @{ $list }, $current;
|
||||
}
|
||||
else {
|
||||
$self->{ data } = $obj;
|
||||
}
|
||||
# set new element (step down)
|
||||
$current = $obj;
|
||||
}
|
||||
elsif ($action->{ type } eq 'PARENT') {
|
||||
$current->init( _fixup_attrs($parser, %attrs) );
|
||||
}
|
||||
elsif ($action->{ type } eq 'METHOD') {
|
||||
my $method = $action->{ method } || $localname;
|
||||
|
||||
no strict qw(refs);
|
||||
# call method with
|
||||
# - default value ($action->{ value } if defined,
|
||||
# dereferencing lists
|
||||
# - the values of the elements Attributes hash
|
||||
# TODO: add namespaces declared to attributes.
|
||||
# Expat consumes them, so we have to re-add them here.
|
||||
$current->$method( defined $action->{ value }
|
||||
? ref $action->{ value }
|
||||
? @{ $action->{ value } }
|
||||
: ($action->{ value })
|
||||
: _fixup_attrs($parser, %attrs)
|
||||
);
|
||||
}
|
||||
|
||||
return;
|
||||
},
|
||||
|
||||
Char => sub { $characters .= $_[1]; return; },
|
||||
|
||||
End => sub {
|
||||
my ($parser, $localname) = @_;
|
||||
|
||||
my $action = SOAP::WSDL::TypeLookup->lookup(
|
||||
$parser->namespace( $localname ),
|
||||
$localname
|
||||
) || {};
|
||||
|
||||
return if not ($action->{ type });
|
||||
if ( $action->{ type } eq 'CLASS' ) {
|
||||
$current = pop @{ $list };
|
||||
}
|
||||
elsif ($action->{ type } eq 'CONTENT' ) {
|
||||
my $method = $action->{ method };
|
||||
|
||||
# normalize whitespace
|
||||
$characters =~s{ ^ \s+ (.+) \s+ $ }{$1}xms;
|
||||
$characters =~s{ \s+ }{ }xmsg;
|
||||
|
||||
no strict qw(refs);
|
||||
$current->$method( $characters );
|
||||
}
|
||||
return;
|
||||
}
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
# make attrs SAX style
|
||||
sub _fixup_attrs {
|
||||
my ($parser, %attrs_of) = @_;
|
||||
|
||||
my @attrs_from = map { $_ =
|
||||
{
|
||||
Name => $_,
|
||||
Value => $attrs_of{ $_ },
|
||||
LocalName => $_
|
||||
}
|
||||
} keys %attrs_of;
|
||||
|
||||
# add xmlns: attrs. expat eats them.
|
||||
push @attrs_from, map {
|
||||
# ignore xmlns=FOO namespaces - must be XML schema
|
||||
# Other nodes should be ignored somewhere else
|
||||
($_ eq '#default')
|
||||
? ()
|
||||
:
|
||||
{
|
||||
Name => "xmlns:$_",
|
||||
Value => $parser->expand_ns_prefix( $_ ),
|
||||
LocalName => $_
|
||||
}
|
||||
} $parser->new_ns_prefixes();
|
||||
return @attrs_from;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new(
|
||||
Namespaces => 1
|
||||
) )->parse( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new(
|
||||
Namespaces => 1
|
||||
) )->parsefile( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
# aliases to make it more SAX-like
|
||||
sub parse_file;
|
||||
*parse_file = \&parsefile;
|
||||
|
||||
sub parse_string;
|
||||
*parse_string = \&parse;
|
||||
|
||||
|
||||
sub get_data {
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
152
lib/SOAP/WSDL/Factory/Deserializer.pm
Normal file
152
lib/SOAP/WSDL/Factory/Deserializer.pm
Normal file
@@ -0,0 +1,152 @@
|
||||
package SOAP::WSDL::Factory::Deserializer;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %DESERIALIZER = (
|
||||
'1.1' => 'SOAP::WSDL::Deserializer::SOAP11',
|
||||
);
|
||||
|
||||
# class method
|
||||
sub register {
|
||||
my ($class, $ref_type, $package) = @_;
|
||||
$DESERIALIZER{ $ref_type } = $package;
|
||||
}
|
||||
|
||||
sub get_deserializer {
|
||||
my ($self, $args_of_ref) = @_;
|
||||
|
||||
# sanity check
|
||||
die "no deserializer registered for SOAP version $args_of_ref->{ soap_version }"
|
||||
if not exists ($DESERIALIZER{ $args_of_ref->{ soap_version } });
|
||||
|
||||
# load module
|
||||
eval "require $DESERIALIZER{ $args_of_ref->{ soap_version } }"
|
||||
or die "Cannot load serializer $DESERIALIZER{ $args_of_ref->{ soap_version } }", $@;
|
||||
|
||||
return $DESERIALIZER{ $args_of_ref->{ soap_version } }->new($args_of_ref);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Factory::Deserializer - Factory for retrieving Deserializer objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# from SOAP::WSDL::Client:
|
||||
$deserializer = SOAP::WSDL::Factory::Deserializer->get_deserializer({
|
||||
soap_version => $soap_version,
|
||||
class_resolver => $class_resolver,
|
||||
});
|
||||
|
||||
# in deserializer class:
|
||||
package MyWickedDeserializer;
|
||||
use SOAP::WSDL::Factory::Deserializer;
|
||||
|
||||
# register class as deserializer for SOAP1.2 messages
|
||||
SOAP::WSDL::Factory::Deserializer->register( '1.2' , __PACKAGE__ );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SOAP::WSDL::Factory::Deserializer serves as factory for retrieving
|
||||
deserializer objects for SOAP::WSDL.
|
||||
|
||||
The actual work is done by specific deserializer classes.
|
||||
|
||||
SOAP::WSDL::Deserializer tries to load one of the following classes:
|
||||
|
||||
=over
|
||||
|
||||
=item * The class registered for the scheme via register()
|
||||
|
||||
=back
|
||||
|
||||
By default, L<SOAP::WSDL::Deserializer::SOAP11|SOAP::WSDL::Deserializer::SOAP11>
|
||||
is registered for SOAP1.1 messages.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 register
|
||||
|
||||
SOAP::WSDL::Deserializer->register('1.1', 'MyWickedDeserializer');
|
||||
|
||||
Globally registers a class for use as deserializer class.
|
||||
|
||||
=head2 get_deserializer
|
||||
|
||||
Returns an object of the deserializer class for this endpoint.
|
||||
|
||||
=head1 WRITING YOUR OWN DESERIALIZER CLASS
|
||||
|
||||
Deserializer classes may register with SOAP::WSDL::Factory::Deserializer.
|
||||
|
||||
=head2 Registering a deserializer
|
||||
|
||||
Registering a deserializer class with SOAP::WSDL::Factory::Deserializer
|
||||
is done by executing the following code where $version is the SOAP version
|
||||
the class should be used for, and $class is the class name.
|
||||
|
||||
SOAP::WSDL::Factory::Deserializer->register( $version, $class);
|
||||
|
||||
To auto-register your transport class on loading, execute register()
|
||||
in your tranport class (see L<SYNOPSIS|SYNOPSIS> above).
|
||||
|
||||
=head2 Deserializer package layout
|
||||
|
||||
Deserializer modules must be named equal to the deserializer class they
|
||||
contain. There can only be one deserializer class per deserializer module.
|
||||
|
||||
=head2 Methods to implement
|
||||
|
||||
Deserializer classes must implement the following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item * new
|
||||
|
||||
Constructor.
|
||||
|
||||
=item * deserialize
|
||||
|
||||
Deserialize data from XML to arbitrary formats.
|
||||
|
||||
deserialize() must return a fault indicating that deserializing failed if
|
||||
any error is encountered during the process of deserializing the XML message.
|
||||
|
||||
The following positional parameters are passed to the deserialize method:
|
||||
|
||||
$content - the xml message
|
||||
|
||||
=item * generate_fault
|
||||
|
||||
Generate a fault in the supported format. The following named parameters are
|
||||
passed as a single hash ref:
|
||||
|
||||
code - The fault code, e.g. 'soap:Server' or the like
|
||||
role - The fault role (actor in SOAP1.1)
|
||||
message - The fault message (faultstring in SOAP1.1)
|
||||
|
||||
=back
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 176 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Serializer.pm 176 2007-08-31 15:28:29Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Serializer.pm $
|
||||
|
||||
=cut
|
||||
144
lib/SOAP/WSDL/Factory/Serializer.pm
Normal file
144
lib/SOAP/WSDL/Factory/Serializer.pm
Normal file
@@ -0,0 +1,144 @@
|
||||
package SOAP::WSDL::Factory::Serializer;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %SERIALIZER = (
|
||||
'1.1' => 'SOAP::WSDL::Serializer::SOAP11',
|
||||
);
|
||||
|
||||
# class method
|
||||
sub register {
|
||||
my ($class, $ref_type, $package) = @_;
|
||||
$SERIALIZER{ $ref_type } = $package;
|
||||
}
|
||||
|
||||
sub get_serializer {
|
||||
my ($self, $args_of_ref) = @_;
|
||||
|
||||
# sanity check
|
||||
die "no deserializer registered for SOAP version $args_of_ref->{ soap_version }"
|
||||
if not exists ($SERIALIZER{ $args_of_ref->{ soap_version } });
|
||||
|
||||
# load module
|
||||
eval "require $SERIALIZER{ $args_of_ref->{ soap_version } }"
|
||||
or die "Cannot load serializer $SERIALIZER{ $args_of_ref->{ soap_version } }", $@;
|
||||
|
||||
return $SERIALIZER{ $args_of_ref->{ soap_version } }->new();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Factory::Serializer - Factory for retrieving serializer objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# from SOAP::WSDL::Client:
|
||||
$serializer = SOAP::WSDL::Factory::Serializer->get_serializer({
|
||||
soap_version => $soap_version,
|
||||
});
|
||||
|
||||
# in serializer class:
|
||||
package MyWickedSerializer;
|
||||
use SOAP::WSDL::Factory::Serializer;
|
||||
|
||||
# register as serializer for SOAP1.2 messages
|
||||
SOAP::WSDL::Factory::Serializer->register( '1.2' , __PACKAGE__ );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SOAP::WSDL::Factory::Serializer serves as factory for retrieving
|
||||
serializer objects for SOAP::WSDL.
|
||||
|
||||
The actual work is done by specific serializer classes.
|
||||
|
||||
SOAP::WSDL::Serializer tries to load one of the following classes:
|
||||
|
||||
=over
|
||||
|
||||
=item * the class registered for the scheme via register()
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 register
|
||||
|
||||
SOAP::WSDL::Serializer->register('1.1', 'MyWickedSerializer');
|
||||
|
||||
Globally registers a class for use as serializer class.
|
||||
|
||||
=head2 get_serializer
|
||||
|
||||
Returns an object of the serializer class for this endpoint.
|
||||
|
||||
=head1 WRITING YOUR OWN SERIALIZER CLASS
|
||||
|
||||
=head2 Registering a deserializer
|
||||
|
||||
Serializer classes may register with SOAP::WSDL::Factory::Serializer.
|
||||
|
||||
Serializer objects may also be passed directly to SOAP::WSDL::Client by
|
||||
using the set_serializer method. Note that serializers objects set via
|
||||
SOAP::WSDL::Client's set_serializer method are discarded when the SOAP
|
||||
version is changed via set_soap_version.
|
||||
|
||||
Registering a serializer class with SOAP::WSDL::Factory::Serializer is done
|
||||
by executing the following code where $version is the SOAP version the
|
||||
class should be used for, and $class is the class name.
|
||||
|
||||
SOAP::WSDL::Factory::Serializer->register( $version, $class);
|
||||
|
||||
To auto-register your transport class on loading, execute register() in
|
||||
your tranport class (see L<SYNOPSIS|SYNOPSIS> above).
|
||||
|
||||
=head2 Serializer package layout
|
||||
|
||||
Serializer modules must be named equal to the serializer class they contain.
|
||||
There can only be one serializer class per serializer module.
|
||||
|
||||
=head2 Methods to implement
|
||||
|
||||
Serializer classes must implement the following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item * new
|
||||
|
||||
Constructor.
|
||||
|
||||
=item * serialize
|
||||
|
||||
Serializes data to XML. The following named parameters are passed to the
|
||||
serialize method in a anonymous hash ref:
|
||||
|
||||
{
|
||||
method => $operation_name,
|
||||
header => $header_data,
|
||||
body => $body_data,
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 265 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Serializer.pm 265 2007-09-20 21:51:31Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Serializer.pm $
|
||||
|
||||
=cut
|
||||
240
lib/SOAP/WSDL/Factory/Transport.pm
Normal file
240
lib/SOAP/WSDL/Factory/Transport.pm
Normal file
@@ -0,0 +1,240 @@
|
||||
package SOAP::WSDL::Factory::Transport;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# class data
|
||||
my %registered_transport_of = ();
|
||||
|
||||
# Local constants
|
||||
# Could be made readonly, but that's just for the paranoid...
|
||||
my %SOAP_LITE_TRANSPORT_OF = (
|
||||
ftp => 'SOAP::Transport::FTP',
|
||||
http => 'SOAP::Transport::HTTP',
|
||||
https => 'SOAP::Transport::HTTPS',
|
||||
mailto => 'SOAP::Transport::MAILTO',
|
||||
'local' => 'SOAP::Transport::LOCAL',
|
||||
jabber => 'SOAP::Transport::JABBER',
|
||||
mq => 'SOAP::Transport::MQ',
|
||||
);
|
||||
|
||||
my %SOAP_WSDL_TRANSPORT_OF = (
|
||||
http => 'SOAP::WSDL::Transport::HTTP',
|
||||
https => 'SOAP::WSDL::Transport::HTTP',
|
||||
);
|
||||
|
||||
# class methods only
|
||||
sub register {
|
||||
my ($class, $scheme, $package) = @_;
|
||||
die "cannot use reference as scheme" if ref $scheme;
|
||||
$registered_transport_of{ $scheme } = $package;
|
||||
}
|
||||
|
||||
sub get_transport {
|
||||
my ($class, $scheme, %attrs) = @_;
|
||||
|
||||
$scheme =~s{ \A ([^\:]+) \: .+ }{$1}smx;
|
||||
|
||||
if (exists $registered_transport_of{ $scheme }) {
|
||||
eval "require $registered_transport_of{ $scheme }" or die $@;
|
||||
|
||||
# try "foo::Client" class first - SOAP::Tranport always requires
|
||||
# a package withoug the ::Client appended, and then
|
||||
# instantiates a ::Client object...
|
||||
# ... pretty weird ...
|
||||
# ... must be from some time when the max number of files was a
|
||||
# sparse resource ...
|
||||
# ... but we've decided to mimic SOAP::Lite...
|
||||
|
||||
my $protocol_class = $SOAP_LITE_TRANSPORT_OF{ $scheme } . '::Client';
|
||||
my $transport;
|
||||
eval {
|
||||
$transport = $protocol_class->new( %attrs );
|
||||
};
|
||||
return $transport if not $@;
|
||||
return $registered_transport_of{ $scheme }->new( %attrs );
|
||||
}
|
||||
|
||||
# try SOAP::Lite's Transport module - just skip if not require'able
|
||||
SOAP_Lite: {
|
||||
if (exists $SOAP_LITE_TRANSPORT_OF{ $scheme }) {
|
||||
eval "require $SOAP_LITE_TRANSPORT_OF{ $scheme }"
|
||||
or last SOAP_Lite;
|
||||
my $protocol_class = $SOAP_LITE_TRANSPORT_OF{ $scheme } . '::Client';
|
||||
return $protocol_class->new( %attrs );
|
||||
}
|
||||
}
|
||||
|
||||
if (exists $SOAP_WSDL_TRANSPORT_OF{ $scheme }) {
|
||||
eval "require $SOAP_WSDL_TRANSPORT_OF{ $scheme }" or die $@;
|
||||
return $SOAP_WSDL_TRANSPORT_OF{ $scheme }->new( %attrs );
|
||||
}
|
||||
|
||||
die "no transport class found for scheme <$scheme>";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Factory::Transport - Factory for retrieving transport objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# from SOAP::WSDL::Client:
|
||||
$transport = SOAP::WSDL::Factory::Transport->get_transport( $url, @opt );
|
||||
|
||||
# in transport class:
|
||||
package MyWickedTransport;
|
||||
use SOAP::WSDL::Factory::Transport;
|
||||
|
||||
# register class as transport module for httpr and https
|
||||
# (httpr is "reliable http", a protocol developed by IBM).
|
||||
SOAP::WSDL::Factory::Transport->register( 'httpr' , __PACKAGE__ );
|
||||
SOAP::WSDL::Factory::Transport->register( 'https' , __PACKAGE__ );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SOAP::WSDL::Transport serves as factory for retrieving transport objects for
|
||||
SOAP::WSDL.
|
||||
|
||||
The actual work is done by specific transport classes.
|
||||
|
||||
SOAP::WSDL::Transport tries to load one of the following classes:
|
||||
|
||||
=over
|
||||
|
||||
=item * the class registered for the scheme via register()
|
||||
|
||||
=item * the SOAP::Lite class matching the scheme
|
||||
|
||||
=item * the SOAP::WSDL class matching the scheme
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 register
|
||||
|
||||
SOAP::WSDL::Transport->register('https', 'MyWickedTransport');
|
||||
|
||||
Globally registers a class for use as transport class.
|
||||
|
||||
=head2 proxy
|
||||
|
||||
$trans->proxy('http://soap-wsdl.sourceforge.net');
|
||||
|
||||
Sets the proxy (endpoint).
|
||||
|
||||
Returns the transport for this protocol.
|
||||
|
||||
=head2 set_transport
|
||||
|
||||
Sets the current transport object.
|
||||
|
||||
=head2 get_transport
|
||||
|
||||
Gets the current transport object.
|
||||
|
||||
=head1 WRITING YOUR OWN TRANSPORT CLASS
|
||||
|
||||
=head2 Registering a transport class
|
||||
|
||||
Transport classes must be registered with SOAP::WSDL::Factory::Transport.
|
||||
|
||||
This is done by executing the following code where $scheme is the URL scheme
|
||||
the class should be used for, and $module is the class' module name.
|
||||
|
||||
SOAP::WSDL::Factory::Transport->register( $scheme, $module);
|
||||
|
||||
To auto-register your transport class on loading, execute register() in your
|
||||
tranport class (see L<SYNOPSIS|SYNOPSIS> above).
|
||||
|
||||
Multiple protocols ore multiple classes are registered by multiple calls to
|
||||
register().
|
||||
|
||||
=head2 Transport plugin package layout
|
||||
|
||||
You may only use transport classes whose name is either
|
||||
the module name or the module name with '::Client' appended.
|
||||
|
||||
=head2 Methods to implement
|
||||
|
||||
Transport classes must implement the interface required for SOAP::Lite
|
||||
transport classes (see L<SOAP::Lite::Transport> for details,
|
||||
L<SOAP::WSDL::Transport::HTTP|SOAP::WSDL::Transport::HTTP> for an example).
|
||||
|
||||
To provide this interface, transport modules must implement the following
|
||||
methods:
|
||||
|
||||
=over
|
||||
|
||||
=item * new
|
||||
|
||||
=item * send_receive
|
||||
|
||||
Dispatches a request and returns the content of the response.
|
||||
|
||||
=item * code
|
||||
|
||||
Returns the status code of the last send_receive call (if any).
|
||||
|
||||
=item * message
|
||||
|
||||
Returns the status message of the last send_receive call (if any).
|
||||
|
||||
=item * status
|
||||
|
||||
Returns the status of the last send_receive call (if any).
|
||||
|
||||
=item * is_success
|
||||
|
||||
Returns true after a send_receive was successful, false if it was not.
|
||||
|
||||
=back
|
||||
|
||||
SOAP::Lite requires transport modules to pack client and server
|
||||
classes in one file, and to follow this naming scheme:
|
||||
|
||||
Module name:
|
||||
"SOAP::Transport::" . uc($scheme)
|
||||
|
||||
Client class (additional package in module):
|
||||
"SOAP::Transport::" . uc($scheme) . "::Client"
|
||||
|
||||
Server class (additional package in module):
|
||||
"SOAP::Transport::" . uc($scheme) . "::Client"
|
||||
|
||||
SOAP::WSDL does not require you to follow these restrictions.
|
||||
|
||||
There is only one restriction in SOAP::WSDL:
|
||||
|
||||
You may only use transport classes whose name is either the module name or
|
||||
the module name with '::Client' appended.
|
||||
|
||||
SOAP::WSDL will try to instantiate an object of your transport class with
|
||||
'::Client' appended to allow using transport classes written for SOAP::Lite.
|
||||
|
||||
This may lead to errors when a different module with the name of your
|
||||
transport module suffixed with ::Client is also loaded.
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 265 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Transport.pm 265 2007-09-20 21:51:31Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Transport.pm $
|
||||
|
||||
=cut
|
||||
47
lib/SOAP/WSDL/Generator/Template.pm
Normal file
47
lib/SOAP/WSDL/Generator/Template.pm
Normal file
@@ -0,0 +1,47 @@
|
||||
package SOAP::WSDL::Generator::Template;
|
||||
use strict;
|
||||
use Template;
|
||||
use Class::Std::Storable;
|
||||
|
||||
my %tt_of :ATTR(:get<tt>);
|
||||
my %definitions_of :ATTR(:name<definitions> :default<()>);
|
||||
my %interface_prefix_of :ATTR(:name<interface_prefix> :default<MyInterface>);
|
||||
my %typemap_prefix_of :ATTR(:name<typemap_prefix> :default<MyTypemap>);
|
||||
my %type_prefix_of :ATTR(:name<type_prefix> :default<MyTypes>);
|
||||
my %element_prefix_of :ATTR(:name<element_prefix> :default<MyElements>);
|
||||
my %INCLUDE_PATH_of :ATTR(:name<INCLUDE_PATH> :default<()>);
|
||||
my %EVAL_PERL_of :ATTR(:name<EVAL_PERL> :default<0>);
|
||||
my %RECURSION_of :ATTR(:name<RECURSION> :default<0>);
|
||||
my %OUTPUT_PATH_of :ATTR(:name<OUTPUT_PATH> :default<.>);
|
||||
|
||||
sub START {
|
||||
my ($self, $ident, $arg_ref) = @_;
|
||||
$tt_of{$ident} = Template->new(
|
||||
DEBUG => 1,
|
||||
EVAL_PERL => $EVAL_PERL_of{ $ident },
|
||||
RECURSION => $RECURSION_of{ $ident },
|
||||
INCLUDE_PATH => $INCLUDE_PATH_of{ $ident },
|
||||
OUTPUT_PATH => $OUTPUT_PATH_of{ $ident },
|
||||
);
|
||||
}
|
||||
|
||||
sub _process :PROTECTED {
|
||||
my ($self, $template, $arg_ref, $output) = @_;
|
||||
my $tt = $self->get_tt();
|
||||
$tt->process( $template,
|
||||
{
|
||||
definitions => $self->get_definitions,
|
||||
interface_prefix => $self->get_interface_prefix,
|
||||
type_prefix => $self->get_type_prefix,
|
||||
typemap_prefix => $self->get_typemap_prefix,
|
||||
TYPE_PREFIX => $self->get_type_prefix,
|
||||
element_prefix => $self->get_element_prefix,
|
||||
NO_POD => delete $arg_ref->{ NO_POD } ? 1 : 0 ,
|
||||
%{ $arg_ref }
|
||||
},
|
||||
$output)
|
||||
or die $tt->error();
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
126
lib/SOAP/WSDL/Generator/Template/XSD.pm
Normal file
126
lib/SOAP/WSDL/Generator/Template/XSD.pm
Normal file
@@ -0,0 +1,126 @@
|
||||
package SOAP::WSDL::Generator::Template::XSD;
|
||||
use strict;
|
||||
use Template;
|
||||
use Class::Std::Storable;
|
||||
use File::Basename;
|
||||
use File::Spec;
|
||||
|
||||
use SOAP::WSDL::Generator::Visitor::Typemap;
|
||||
use SOAP::WSDL::Generator::Visitor::Typelib;
|
||||
use base qw(SOAP::WSDL::Generator::Template);
|
||||
|
||||
my %output_of :ATTR(:name<output> :default<()>);
|
||||
|
||||
sub BUILD {
|
||||
my ($self, $ident, $arg_ref) = @_;
|
||||
$self->set_EVAL_PERL(1);
|
||||
$self->set_RECURSION(1);
|
||||
$self->set_INCLUDE_PATH( exists $arg_ref->{INCLUDE_PATH}
|
||||
? $arg_ref->{INCLUDE_PATH}
|
||||
: File::Spec->rel2abs( dirname __FILE__ ). '/XSD/'
|
||||
);
|
||||
}
|
||||
|
||||
sub generate_typelib {
|
||||
my ($self) = @_;
|
||||
|
||||
# $output_of{ ident $self } = "";
|
||||
|
||||
my @schema = @{ $self->get_definitions()->first_types()->get_schema() };
|
||||
for my $type (map { @{ $_->get_type() } , @{ $_->get_element() } } @schema[1..$#schema] ) {
|
||||
$type->_accept( $self );
|
||||
}
|
||||
|
||||
# return $output_of{ ident $self };
|
||||
|
||||
}
|
||||
|
||||
sub generate_interface {
|
||||
my $self = shift;
|
||||
my $ident = ident $self;
|
||||
my $arg_ref = shift;
|
||||
my $tt = $self->get_tt();
|
||||
for my $service (@{ $self->get_definitions->get_service }) {
|
||||
for my $port (@{ $service->get_port() }) {
|
||||
# Skip ports without (known) address
|
||||
next if not $port->first_address;
|
||||
next if not $port->first_address->isa('SOAP::WSDL::SOAP::Address');
|
||||
|
||||
my $output = $arg_ref->{ output }
|
||||
? $arg_ref->{ output }
|
||||
: $self->_generate_filename( $self->get_interface_prefix(), $service->get_name(), $port->get_name );
|
||||
|
||||
$self->_process('Interface.tt',
|
||||
{
|
||||
service => $service,
|
||||
port => $port,
|
||||
NO_POD => $arg_ref->{ NO_POD } ? 1 : 0 ,
|
||||
},
|
||||
$output);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub generate_typemap {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
my $visitor = SOAP::WSDL::Generator::Visitor::Typemap->new({
|
||||
type_prefix => $self->get_type_prefix(),
|
||||
element_prefix => $self->get_element_prefix(),
|
||||
definitions => $self->get_definitions(),
|
||||
typemap => {
|
||||
'Fault' => 'SOAP::WSDL::SOAP::Typelib::Fault11',
|
||||
'Fault/faultcode' => 'SOAP::WSDL::XSD::Typelib::Builtin::anyURI',
|
||||
'Fault/faultactor' => 'SOAP::WSDL::XSD::Typelib::Builtin::TOKEN',
|
||||
'Fault/faultstring' => 'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
'Fault/detail' => 'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
}
|
||||
});
|
||||
for my $service (@{ $self->get_definitions->get_service }) {
|
||||
$visitor->visit_Service( $service );
|
||||
my $output = $arg_ref->{ output }
|
||||
? $arg_ref->{ output }
|
||||
: $self->_generate_filename( $self->get_typemap_prefix(), $service->get_name() );
|
||||
$self->_process('Typemap.tt',
|
||||
{
|
||||
service => $service,
|
||||
typemap => $visitor->get_typemap(),
|
||||
NO_POD => $arg_ref->{ NO_POD } ? 1 : 0 ,
|
||||
},
|
||||
$output);
|
||||
}
|
||||
}
|
||||
|
||||
sub _generate_filename :PRIVATE {
|
||||
my ($self, @parts) = @_;
|
||||
my $name = join '::', @parts;
|
||||
$name =~s{ \. }{::}xmsg;
|
||||
$name =~s{ :: }{/}xmsg;
|
||||
return "$name.pm";
|
||||
}
|
||||
|
||||
sub visit_XSD_Element {
|
||||
my ($self, $element) = @_;
|
||||
my $output = defined $output_of{ ident $self }
|
||||
? $output_of{ ident $self }
|
||||
: $self->_generate_filename( $self->get_element_prefix(), $element->get_name() );
|
||||
$self->_process('element.tt', { element => $element } , $output);
|
||||
}
|
||||
|
||||
sub visit_XSD_SimpleType {
|
||||
my ($self, $type) = @_;
|
||||
my $output = defined $output_of{ ident $self }
|
||||
? $output_of{ ident $self }
|
||||
: $self->_generate_filename( $self->get_type_prefix(), $type->get_name() );
|
||||
$self->_process('simpleType.tt', { simpleType => $type } , $output);
|
||||
}
|
||||
|
||||
sub visit_XSD_ComplexType {
|
||||
my ($self, $type) = @_;
|
||||
my $output = defined $output_of{ ident $self }
|
||||
? $output_of{ ident $self }
|
||||
: $self->_generate_filename( $self->get_type_prefix(), $type->get_name() );
|
||||
$self->_process('complexType.tt', { complexType => $type } , $output);
|
||||
}
|
||||
|
||||
1;
|
||||
69
lib/SOAP/WSDL/Generator/Template/XSD/Interface.tt
Normal file
69
lib/SOAP/WSDL/Generator/Template/XSD/Interface.tt
Normal file
@@ -0,0 +1,69 @@
|
||||
package [% interface_prefix %]::[% service.get_name %]::[% port.get_name %];
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Client::Base);
|
||||
|
||||
sub START {
|
||||
$_[0]->set_proxy('[% port.first_address.get_location %]') if not $_[2]->{proxy};
|
||||
$_[0]->set_class_resolver('[% typemap_prefix %]::[% service.get_name %]')
|
||||
if not $_[2]->{class_resolver};
|
||||
}
|
||||
|
||||
[% binding = definitions.find_binding( port.expand( port.get_binding ) );
|
||||
FOREACH operation = binding.get_operation;
|
||||
%][% INCLUDE Interface/Operation.tt %]
|
||||
[%
|
||||
END;
|
||||
%]
|
||||
|
||||
1;
|
||||
|
||||
[% IF NO_POD; STOP; END %]
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
||||
[% interface_prefix %]::[% service.get_name %]::[% port.get_name %] - SOAP Interface for the [% service.get_name %] Web Service
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SOAP Interface for the [% service.get_name %] web service
|
||||
located at [% port.first_address.get_location %].
|
||||
|
||||
=head1 SERVICE [% service.get_name %]
|
||||
|
||||
[% service.get_documentation %]
|
||||
|
||||
=head2 Port [% port.get_name %]
|
||||
|
||||
[% port.get_documentation %]
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 General methods
|
||||
|
||||
=head3 new
|
||||
|
||||
Constructor.
|
||||
|
||||
All arguments are forwarded to L<SOAP::WSDL::Client|SOAP::WSDL::Client>.
|
||||
|
||||
=head2 SOAP Service methods
|
||||
|
||||
[% INCLUDE Interface/POD/method_info.tt %]
|
||||
|
||||
|
||||
[% FOREACH operation = binding.get_operation;
|
||||
%][% INCLUDE Interface/POD/Operation.tt %]
|
||||
[% END %]
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Generated by SOAP::WSDL on [% PERL %]print scalar localtime() [% END %]
|
||||
|
||||
=pod
|
||||
65
lib/SOAP/WSDL/Generator/Template/XSD/Interface/Body.tt
Normal file
65
lib/SOAP/WSDL/Generator/Template/XSD/Interface/Body.tt
Normal file
@@ -0,0 +1,65 @@
|
||||
[% RETURN IF NOT item;
|
||||
type = definitions.find_portType( binding.expand( binding.get_type ) );
|
||||
port_op = type.find_operation( definitions.get_targetNamespace, operation.get_name );
|
||||
message = definitions.find_message( port_op.first_input.expand( port_op.first_input.get_message ) );
|
||||
part_from = message.get_part;
|
||||
PERL %]
|
||||
my $item = $stash->{ item };
|
||||
my $def = $stash->{ definitions };
|
||||
my $part_from = $stash->{ part_from };
|
||||
my $type_prefix = $stash->{ type_prefix };
|
||||
my $element_prefix = $stash->{ element_prefix };
|
||||
|
||||
my @body_part_from = split m{\s}, $item->get_parts;
|
||||
|
||||
my @parts;
|
||||
if (@body_part_from) {
|
||||
@parts = map {
|
||||
my $part = $_;
|
||||
(grep {
|
||||
my ($ns, $lname) = $def->expand( $_ );
|
||||
($lname eq $part->get_name)
|
||||
} @body_part_from
|
||||
)
|
||||
? do {
|
||||
my $name;
|
||||
($name = $part->get_element)
|
||||
? do {
|
||||
$name =~s{ ^[^:]+: }{}xms;
|
||||
$element_prefix . '::' . $name;
|
||||
}
|
||||
: ($name = $part->get_type)
|
||||
? do {
|
||||
$name =~s{ ^[^:]+: }{}xms;
|
||||
$type_prefix . '::' . $name;
|
||||
}
|
||||
: die "input must have either type or element"
|
||||
}
|
||||
: ()
|
||||
} @{ $part_from };
|
||||
}
|
||||
else {
|
||||
@parts = map {
|
||||
my $part = $_;
|
||||
my $name;
|
||||
($name = $part->get_element)
|
||||
? do {
|
||||
$name =~s{ ^[^:]+: }{}xms;
|
||||
"$element_prefix\::$name"
|
||||
}
|
||||
: ($name = $part->get_type)
|
||||
? do {
|
||||
$name =~s{ ^[^:]+: }{}xms;
|
||||
"$type_prefix\::$name"
|
||||
}
|
||||
: die "input must have either type or element";
|
||||
} @{ $part_from };
|
||||
}
|
||||
$stash->{ parts } = \@parts;
|
||||
|
||||
[% END;
|
||||
%]
|
||||
'use' => '[% item.get_use %]',
|
||||
namespace => '[% item.get_namespace %]',
|
||||
encodingStyle => '[% item.get_encodingStyle %]',
|
||||
parts => [qw( [% parts.join(' ') %] )],
|
||||
28
lib/SOAP/WSDL/Generator/Template/XSD/Interface/Header.tt
Normal file
28
lib/SOAP/WSDL/Generator/Template/XSD/Interface/Header.tt
Normal file
@@ -0,0 +1,28 @@
|
||||
[%
|
||||
RETURN IF NOT item;
|
||||
message = definitions.find_message( item.expand( item.get_message ) );
|
||||
PERL %]
|
||||
my $message = $stash->{ message };
|
||||
my $item = $stash->{ item };
|
||||
my $def = $stash->{ definitions };
|
||||
my $type_prefix = $stash->{ type_prefix };
|
||||
my $element_prefix = $stash->{ element_prefix };
|
||||
my ($ns, $lname) = $def->expand( $item->get_part() );
|
||||
my ($part) = grep {
|
||||
$_->get_name eq $lname
|
||||
&& $_->get_targetNamespace eq $ns } @{ $message->get_part( ) };
|
||||
my $part_class = do {
|
||||
my $name;
|
||||
($name = $part->get_element)
|
||||
? "$element_prefix::$name"
|
||||
: ($name = $part->get_type)
|
||||
? "$type_prefix::$name"
|
||||
: die "input must have either type or element";
|
||||
};
|
||||
$stash->{ part_class } = $part_class;
|
||||
[% END;
|
||||
%]
|
||||
'use' => '[% item.get_use %]',
|
||||
namespace => '[% item.get_namespace %]',
|
||||
encodingStyle => '[% item.get_encodingStyle %]',
|
||||
parts => '[qw( [% part_class %] )]',
|
||||
17
lib/SOAP/WSDL/Generator/Template/XSD/Interface/Operation.tt
Normal file
17
lib/SOAP/WSDL/Generator/Template/XSD/Interface/Operation.tt
Normal file
@@ -0,0 +1,17 @@
|
||||
sub [% operation.get_name %] {
|
||||
my ($self, $body, $header) = @_;
|
||||
return $self->SUPER::call({
|
||||
operation => '[% operation.get_name %]',
|
||||
soap_action => '[% operation.first_operation.get_soapAction %]',
|
||||
style => '[% operation.get_style || binding.get_style %]',
|
||||
body => {
|
||||
[% INCLUDE Interface/Body.tt( item = operation.first_input.first_body ); %]
|
||||
},
|
||||
header => {
|
||||
[% INCLUDE Interface/Header.tt( item = operation.first_input.first_header ); %]
|
||||
},
|
||||
headerfault => {
|
||||
[% INCLUDE Interface/Header.tt( item = operation.first_input.first_headerfault ); %]
|
||||
}
|
||||
}, $body, $header);
|
||||
}
|
||||
@@ -0,0 +1,13 @@
|
||||
|
||||
[% INDENT; %][% element.get_name %] => [%-
|
||||
IF (element.get_ref);
|
||||
element = element.get_ref();
|
||||
END;
|
||||
IF (type_name = element.get_type);
|
||||
INCLUDE Interface/POD/Type.tt(type = definitions.first_types.find_type( element.expand(type_name) ) );
|
||||
ELSIF (type = element.first_complexType);
|
||||
INCLUDE Interface/POD/Type.tt(type = type );
|
||||
ELSIF (type = element.first_simpleType);
|
||||
INCLUDE Interface/POD/Type.tt(type = type );
|
||||
END;
|
||||
%]
|
||||
@@ -0,0 +1,9 @@
|
||||
[%
|
||||
message_name = port_op.first_input.get_message();
|
||||
# message_name;
|
||||
|
||||
part_from = definitions.find_message( port_op.first_input.expand( message_name ) ).get_part;
|
||||
FOREACH part = part_from;
|
||||
INCLUDE Interface/POD/Part.tt(part = part);
|
||||
END;
|
||||
%]
|
||||
@@ -0,0 +1,8 @@
|
||||
=head3 [% operation.get_name %]
|
||||
|
||||
[% type = definitions.find_portType( binding.expand( binding.get_type ) );
|
||||
port_op = type.find_operation( definitions.get_targetNamespace, operation.get_name );
|
||||
port_op.get_documentation %]
|
||||
|
||||
$interface->[% operation.get_name %]([% INCLUDE Interface/POD/Message.tt %] );
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
[% element = definitions.first_types.find_element( part.expand( part.get_element ) );
|
||||
#element.get_name();
|
||||
#element;
|
||||
#STOP;
|
||||
type = element.first_complexType || element.first_simpleType || definitions.first_types.find_type(
|
||||
element.expand( element.get_type ) );
|
||||
INCLUDE Interface/POD/Type.tt;%],
|
||||
11
lib/SOAP/WSDL/Generator/Template/XSD/Interface/POD/Type.tt
Normal file
11
lib/SOAP/WSDL/Generator/Template/XSD/Interface/POD/Type.tt
Normal file
@@ -0,0 +1,11 @@
|
||||
[%- INDENT = INDENT _ ' ';
|
||||
IF type.isa('SOAP::WSDL::XSD::ComplexType'); -%]
|
||||
{ #[% IF (type.get_name); %][% TYPE_PREFIX %]::[% type.get_name %][% ELSE; %]__ATOMIC__[% END;
|
||||
FOREACH element = type.get_element;
|
||||
INCLUDE Interface/POD/Element.tt( element = element );
|
||||
END %]
|
||||
[% INDENT; %]}
|
||||
[%- ELSE -%]
|
||||
$someValue,
|
||||
[%- END;
|
||||
INDENT.replace('\s{2}$',''); %]
|
||||
@@ -0,0 +1,7 @@
|
||||
Method synopsis is displayed with hash refs as parameters.
|
||||
|
||||
The commented class names in the method's parameters denote that objects
|
||||
of the corresponding class can be passed instead of the marked hash ref.
|
||||
|
||||
You may pass any combination of objects, hash and list refs to these
|
||||
methods, as long as you meet the structure.
|
||||
28
lib/SOAP/WSDL/Generator/Template/XSD/Typemap.tt
Normal file
28
lib/SOAP/WSDL/Generator/Template/XSD/Typemap.tt
Normal file
@@ -0,0 +1,28 @@
|
||||
package [% typemap_prefix %]::[% service.get_name.replace('\.','::') %];
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our [% USE Dumper(varname = 'typemap_'); Dumper.dump( typemap ) %];
|
||||
|
||||
sub get_class {
|
||||
my $name = join '/', @{ $_[1] };
|
||||
exists $typemap_1->{ $name } or die "Cannot resolve $name via " . __PACKAGE__;
|
||||
return $typemap_1->{ $name };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
[% typemap_prefix %]::[% service.get_name.replace('\.','::') %]; - typemap for ::[% service.get_name %];
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Typemap created by SOAP::WSDL for map-based SOAP message parsers.
|
||||
|
||||
=cut
|
||||
|
||||
6
lib/SOAP/WSDL/Generator/Template/XSD/_type_class.tt
Normal file
6
lib/SOAP/WSDL/Generator/Template/XSD/_type_class.tt
Normal file
@@ -0,0 +1,6 @@
|
||||
[% type_name = node.expand( type );
|
||||
IF (type_name.0 == 'http://www.w3.org/2001/XMLSchema'); -%]
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::[% type_name.1 %]
|
||||
[% ELSE -%]
|
||||
[% type_prefix %]::[% type_name.1 %]
|
||||
[% END -%]
|
||||
45
lib/SOAP/WSDL/Generator/Template/XSD/complexType.tt
Normal file
45
lib/SOAP/WSDL/Generator/Template/XSD/complexType.tt
Normal file
@@ -0,0 +1,45 @@
|
||||
package [% type_prefix %]::[% complexType.get_name %];
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::ComplexType);
|
||||
[% INCLUDE complexType/contentModel.tt %]
|
||||
[%#
|
||||
# Don't include any perl source here - there may be sub-packages...
|
||||
#-%]
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
[% type_prefix %]::[% complexType.get_name %]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl data type class for the XML Schema defined complextype
|
||||
[% complexType.get_name %] from the namespace [% complexType.get_xmlns %].
|
||||
|
||||
=head2 PROPERTIES
|
||||
|
||||
The following properties may be accessed using get_PROPERTY / set_PROPERTY
|
||||
methods:
|
||||
|
||||
[% FOREACH element = complexType.get_element -%]
|
||||
[% element.get_name %]
|
||||
[% END %]
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
Constructor. The following data structure may be passed to new():
|
||||
|
||||
[% indent = ' '; INCLUDE complexType/POD/structure.tt %]
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Generated by SOAP::WSDL
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,7 @@
|
||||
[% indent %]{
|
||||
[%- IF complexType.get_name %] # [% type_prefix %]::[% complexType.get_name %][% END %]
|
||||
[%- indent = indent _ ' ';
|
||||
FOREACH element = complexType.get_element %]
|
||||
[% indent %][% element.get_name %] => [% INCLUDE element/POD/structure.tt -%]
|
||||
[% END %]
|
||||
[% indent.replace('\s{2}$', ''); %]}
|
||||
44
lib/SOAP/WSDL/Generator/Template/XSD/complexType/all.tt
Normal file
44
lib/SOAP/WSDL/Generator/Template/XSD/complexType/all.tt
Normal file
@@ -0,0 +1,44 @@
|
||||
{ # BLOCK to scope variables
|
||||
[%
|
||||
atomic_types = [];
|
||||
|
||||
FOREACH element = complexType.get_element %]
|
||||
my %[% element.get_name %]_of :ATTR(:get<[% element.get_name %]>);
|
||||
[%- END %]
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
[ qw([% FOREACH element = complexType.get_element %]
|
||||
[% element.get_name -%]
|
||||
[% END %]
|
||||
) ],
|
||||
{
|
||||
[% FOREACH element = complexType.get_element -%]
|
||||
[% element.get_name %] => \%[% element.get_name %]_of,
|
||||
[% END -%]
|
||||
},
|
||||
{
|
||||
[% FOREACH element = complexType.get_element;
|
||||
IF (type = element.get_type);
|
||||
element_type = complexType.expand( type );
|
||||
IF (element_type.0 == 'http://www.w3.org/2001/XMLSchema'); -%]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% element_type.1 %]',
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %]::[% element_type.1 %]',
|
||||
[% END;
|
||||
ELSE;
|
||||
IF (element.first_simpleType);
|
||||
atomic_types.push( element.first_simpleType );
|
||||
ELSIF (element.first_simpleType);
|
||||
atomic_types.push( element.first_simpleType );
|
||||
ELSE;
|
||||
THROW NOT_IMPLEMENTED , "atomic types in complexType elements not supported yet";
|
||||
END; %]
|
||||
[% element.get_name %] => '[% type_prefix %]::[% complexType.get_name %]::_[% element.get_name %]',
|
||||
[% END;
|
||||
END -%]
|
||||
}
|
||||
);
|
||||
|
||||
} # end BLOCK
|
||||
|
||||
[% INCLUDE complexType/atomicTypes.tt(atomic_types = atomic_types) %]
|
||||
@@ -0,0 +1,19 @@
|
||||
|
||||
[% FOREACH type = atomic_types; %]
|
||||
|
||||
package [% type_prefix %]::[% complexType.get_name %]::_[% element.get_name %];
|
||||
use strict;
|
||||
use warnings;
|
||||
{
|
||||
[% IF ( type.isa('SOAP::WSDL::XSD::ComplexType') );
|
||||
INCLUDE complexType/contentModel.tt(complexType = type );
|
||||
ELSIF ( type.isa('SOAP::WSDL::XSD::SimpleType') );
|
||||
INCLUDE simpleType/contentModel.tt(simpleType = type );
|
||||
ELSE;
|
||||
PERL; %] die $stash->{ type }->_DUMP [% END;
|
||||
THROW UNKNOWN, "neither complex nor simple type - don't know what to do";
|
||||
END
|
||||
%]
|
||||
}
|
||||
|
||||
[% END %]
|
||||
@@ -0,0 +1,13 @@
|
||||
[% IF (complexType.get_variety == 'all');
|
||||
INCLUDE complexType/all.tt(complexType = complexType);
|
||||
ELSIF (complexType.get_variety == 'sequence');
|
||||
INCLUDE complexType/all.tt(complexType = complexType);
|
||||
ELSIF (complexType.get_variety == 'group');
|
||||
THROW NOT_IMPLEMENTED, "${ element.get_name } - complexType group not implemented yet";
|
||||
ELSIF (complexType.get_variety == 'choice');
|
||||
THROW NOT_IMPLEMENTED, "${ element.get_name } - complexType choice not implemented yet";
|
||||
ELSIF (complexType.get_variety == 'simpleContent');
|
||||
THROW NOT_IMPLEMENTED, "${ element.get_name } - complexType choice not implemented yet";
|
||||
ELSIF (complexType.get_variety == 'complexContent');
|
||||
THROW NOT_IMPLEMENTED, "${ element.get_name } - complexType choice not implemented yet";
|
||||
END %]
|
||||
71
lib/SOAP/WSDL/Generator/Template/XSD/element.tt
Normal file
71
lib/SOAP/WSDL/Generator/Template/XSD/element.tt
Normal file
@@ -0,0 +1,71 @@
|
||||
package [% element_prefix %]::[% element.get_name %];
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
{ # BLOCK to scope variables
|
||||
|
||||
sub get_xmlns { '[% element.get_targetNamespace %]' }
|
||||
|
||||
__PACKAGE__->__set_name('[% element.get_name %]');
|
||||
__PACKAGE__->__set_nillable([% element.get_nillable %]);
|
||||
__PACKAGE__->__set_minOccurs([% element.get_minOccurs %]);
|
||||
__PACKAGE__->__set_maxOccurs([% element.get_maxOccurs %]);
|
||||
__PACKAGE__->__set_ref([% IF element.get_ref; %]'[% element.get_ref %]'[% END %]);
|
||||
|
||||
[%- IF (type = element.get_type); -%]
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
[% INCLUDE _type_class.tt( type = type, node = element ) %]
|
||||
);
|
||||
[%- ELSIF (ref = element.get_ref); -%]
|
||||
# element ref="[% ref %]"
|
||||
use base qw(
|
||||
[% element_prefix %]::[% ref.split(':').1 %]
|
||||
);
|
||||
[%- ELSIF (simpleType = element.first_simpleType) %]
|
||||
# atomic simpleType: <element><simpleType
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
);
|
||||
[% INCLUDE simpleType/contentModel.tt %]
|
||||
[% ELSIF (complexType = element.first_complexType) %]
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
SOAP::WSDL::XSD::Typelib::ComplexType
|
||||
);
|
||||
[% INCLUDE complexType/contentModel.tt;
|
||||
END %]
|
||||
|
||||
|
||||
} # end of BLOCK
|
||||
1;
|
||||
|
||||
# __END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
[% element_prefix %]::[% element.get_name %]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl data type class for the XML Schema defined element
|
||||
[% element.get_name %] from the namespace [% element.get_targetNamespace %].
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
my $element = [% element_prefix %]::[% element.get_name %]->new($data);
|
||||
|
||||
Constructor. The following data structure may be passed to new():
|
||||
|
||||
[% indent = ' '; INCLUDE element/POD/structure.tt; %]
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Generated by SOAP::WSDL
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,30 @@
|
||||
[%- IF (name = element.get_type);
|
||||
type_name = element.expand(name);
|
||||
IF (type_name.0 == 'http://www.w3.org/2001/XMLSchema'); -%]
|
||||
$some_value, # [% type_name.1 %]
|
||||
[%-
|
||||
RETURN;
|
||||
ELSIF (type = definitions.first_types.find_type( type_name ));
|
||||
IF (type.isa('SOAP::WSDL::XSD::ComplexType') );
|
||||
INCLUDE complexType/POD/structure.tt(complexType = type);
|
||||
RETURN;
|
||||
ELSE;
|
||||
INCLUDE simpleType/POD/structure.tt(simpleType = type);
|
||||
END;
|
||||
RETURN;
|
||||
END;
|
||||
THROW NOT_FOUND, "no type found for {${type_name.0}}${type_name.1}";
|
||||
ELSIF (ref = element.get_ref);
|
||||
ref_element = definitions.first_types.find_element( element.expand( ref ) );
|
||||
INCLUDE element/POD/structure.tt(element = ref_element);
|
||||
RETURN;
|
||||
ELSIF (type = element.first_simpleType);
|
||||
INCLUDE simpleType/POD/structure.tt(simpleType = type);
|
||||
RETURN;
|
||||
ELSIF (type = element.first_complexType);
|
||||
INCLUDE complexType/POD/structure.tt(complexType = type);
|
||||
ELSE;
|
||||
THROW NOT_FOUND, "no type found for ${element.get_name}";
|
||||
%]
|
||||
NO TYPE FOUND FOR ELEMENT [% element.get_name %]
|
||||
[% END -%]
|
||||
56
lib/SOAP/WSDL/Generator/Template/XSD/simpleType.tt
Normal file
56
lib/SOAP/WSDL/Generator/Template/XSD/simpleType.tt
Normal file
@@ -0,0 +1,56 @@
|
||||
package [% type_prefix %]::[% simpleType.get_name %];
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub get_xmlns { '[% simpleType.get_targetNamespace %]'};
|
||||
|
||||
[% INCLUDE simpleType/contentModel.tt %]
|
||||
[%#
|
||||
# Don't include any perl source here - there may be sub-packages...
|
||||
#-%]
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 [% type_prefix %]::[% simpleType.get_name %]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl data type class for the XML Schema defined simpleType
|
||||
[% simpleType.get_name %] from the namespace [% simpleType.get_targetNamespace %].
|
||||
|
||||
[% IF (simpleType.get_variety == 'list');
|
||||
INCLUDE simpleType/POD/list.tt;
|
||||
ELSIF (simpleType.get_variety == 'restriction');
|
||||
INCLUDE simpleType/POD/restriction.tt;
|
||||
ELSE;
|
||||
THROW NOT_IMPLEMENTED "simpleType union not implemented yet in $simpleType.get_name";
|
||||
END %]
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
Constructor.
|
||||
|
||||
=head2 get_value / set_value
|
||||
|
||||
Getter and setter for the simpleType's value.
|
||||
|
||||
=head1 OVERLOADING
|
||||
|
||||
Depending on the simple type's base type, the following operations are overloaded
|
||||
|
||||
Stringification
|
||||
Numerification
|
||||
Boolification
|
||||
|
||||
Check L<SOAP::WSDL::XSD::Typelib::Builtin> for more information.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Generated by SOAP::WSDL
|
||||
|
||||
=cut
|
||||
|
||||
20
lib/SOAP/WSDL/Generator/Template/XSD/simpleType/POD/list.tt
Normal file
20
lib/SOAP/WSDL/Generator/Template/XSD/simpleType/POD/list.tt
Normal file
@@ -0,0 +1,20 @@
|
||||
This clase is derived from
|
||||
[%-
|
||||
IF (name = simpleType.get_itemType);
|
||||
type_name = simpleType.expand( name );
|
||||
IF (type_name.0 == 'http://www.w3.org/2001/XMLSchema'); -%]
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::[% type_name.1 %]
|
||||
[% ELSE -%]
|
||||
[% type_prefix %]::[% type_name.1 %]
|
||||
[% END;
|
||||
ELSE;
|
||||
# THROW NOT_IMPLEMENTED "atomic simpleType list not implemented yet in $simpleType.get_name";
|
||||
%] a atomic base type. Unfortunately there's no documenatation generation for atomic base types yet. [%
|
||||
END -%].
|
||||
|
||||
You may pass the following structure to new():
|
||||
|
||||
[ $value_1, .. $value_n ]
|
||||
|
||||
All elements of the list must be of the class' base type (or
|
||||
valid arguments to it's constructor).
|
||||
@@ -0,0 +1,17 @@
|
||||
This clase is derived from
|
||||
[%-
|
||||
IF (name = simpleType.get_base);
|
||||
type_name = simpleType.expand( name );
|
||||
IF (type_name.0 == 'http://www.w3.org/2001/XMLSchema'); -%]
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::[% type_name.1 %]
|
||||
[% ELSE -%]
|
||||
[% type_prefix %]::[% type_name.1 %]
|
||||
[% END;
|
||||
ELSE;
|
||||
# THROW NOT_IMPLEMENTED "atomic simpleType restriction not implemented yet in $simpleType.get_name";
|
||||
%] a atomic base type. Unfortunately there's no documenatation generation for atomic base types yet. [%
|
||||
END -%]
|
||||
. SOAP::WSDL's schema implementation does not validate data, so you can use it exactly
|
||||
like it's base type.
|
||||
|
||||
# Description of restrictions not implemented yet.
|
||||
@@ -0,0 +1 @@
|
||||
$some_value, # [% IF (simpleType.get_name); simpleType.get_name; ELSE %]atomic[% END %]
|
||||
@@ -0,0 +1,3 @@
|
||||
# atomic simple type.
|
||||
|
||||
[% INCLUDE simpleType/contentModel.tt(simpleType = type ); %]
|
||||
@@ -0,0 +1,7 @@
|
||||
[% IF (simpleType.get_variety == 'list');
|
||||
INCLUDE simpleType/list.tt(simpleType = simpleType);
|
||||
ELSIF (simpleType.get_variety == 'restriction');
|
||||
INCLUDE simpleType/restriction.tt(type = simpleType);
|
||||
ELSE;
|
||||
THROW NOT_IMPLEMENTED "${ element.get_name } - ${ simpleType.get_variety } not supported yet";
|
||||
END %]
|
||||
21
lib/SOAP/WSDL/Generator/Template/XSD/simpleType/list.tt
Normal file
21
lib/SOAP/WSDL/Generator/Template/XSD/simpleType/list.tt
Normal file
@@ -0,0 +1,21 @@
|
||||
# list derivation
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::list
|
||||
[%
|
||||
IF (name = simpleType.get_itemType);
|
||||
type_name = simpleType.expand( name );
|
||||
IF (type_name.0 == 'http://www.w3.org/2001/XMLSchema'); -%]
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::[% type_name.1 %]
|
||||
);
|
||||
[% ELSE -%]
|
||||
[% type_prefix %]::[% type_name.1 %]
|
||||
);
|
||||
[% END;
|
||||
ELSIF (type = simpleType.first_simpleType); %]
|
||||
);
|
||||
|
||||
[% INCLUDE simpleType/atomicType.tt(type = type);
|
||||
ELSE; PERL %]die $stash->{simpleType}._DUMP [% END;
|
||||
THROW UNKNOWN , "No list itemTape and no atomic simpleType - don't know what to do";
|
||||
END %]
|
||||
|
||||
@@ -0,0 +1,9 @@
|
||||
# derivation by restriction
|
||||
[% IF (base = simpleType.get_base) -%]
|
||||
use base qw(
|
||||
[% INCLUDE _type_class.tt(type = base, node=simpleType) %]);
|
||||
[% ELSIF (type = simpleType.first_simpleType() );
|
||||
INCLUDE simpleType/atomicType.tt(type = type);
|
||||
ELSE;
|
||||
THROW "neither base nor atomic type - don't know what to do" %]
|
||||
[% END %]
|
||||
283
lib/SOAP/WSDL/Generator/Visitor.pm
Normal file
283
lib/SOAP/WSDL/Generator/Visitor.pm
Normal file
@@ -0,0 +1,283 @@
|
||||
package SOAP::WSDL::Generator::Visitor;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
my %definitions_of :ATTR(:name<definitions> :default<()>);
|
||||
my %type_prefix_of :ATTR(:name<type_prefix> :default<()>);
|
||||
my %element_prefix_of :ATTR(:name<element_prefix> :default<()>);
|
||||
|
||||
sub START {
|
||||
my ($self, $ident, $arg_ref) = @_;
|
||||
$type_prefix_of{ $ident } = 'MyType' if not exists
|
||||
$arg_ref->{ 'type_prefix' };
|
||||
$element_prefix_of{ $ident } = 'MyElement' if not exists
|
||||
$arg_ref->{ 'element_prefix' };
|
||||
|
||||
}
|
||||
|
||||
|
||||
# WSDL stuff
|
||||
sub visit_Definitions {}
|
||||
sub visit_Binding {}
|
||||
sub visit_Message {}
|
||||
sub visit_Operation {}
|
||||
sub visit_OpMessage {}
|
||||
sub visit_Part {}
|
||||
sub visit_Port {}
|
||||
sub visit_PortType {}
|
||||
sub visit_Service {}
|
||||
sub visit_SoapOperation {}
|
||||
sub visit_Types {}
|
||||
|
||||
# XML Schema stuff
|
||||
sub visit_XSD_Schema {}
|
||||
sub visit_XSD_ComplexType {}
|
||||
sub visit_XSD_Element {}
|
||||
sub visit_XSD_SimpleType {}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Generator::Visitor - SOAP::WSDL's Visitor-based Code Generator
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SOAP::WSDL featores a code generating facility. This code generation facility
|
||||
(in fact there are several of them) is implemented as Visitor to
|
||||
SOAP::WSDL::Base-derived objects.
|
||||
|
||||
=head2 The Visitor Pattern
|
||||
|
||||
The Visitor design pattern is one of the object oriented design pattern
|
||||
described by [GHJV1995].
|
||||
|
||||
A Visitor is an object implementing some behaviour for a fixed set of classes,
|
||||
whose implementation would otherwise need to be scattered accross those
|
||||
classes' implementations.
|
||||
|
||||
Visitors are usually combined with Iterators for traversing either a list or
|
||||
tree of objects.
|
||||
|
||||
A Visitor's methods are called using the so-called double dispatch technique.
|
||||
To allow double dispatching, the Visitor implements one method for every class
|
||||
ro be handled, whereas every class implements just one method (commonly named
|
||||
"access"), which does nothing more than calling a method on the reference
|
||||
given, with the self object as parameter.
|
||||
|
||||
If all this sounds strange, maybe an example helps. Imagine you had a list of
|
||||
person objects and wanted to print out a list of their names (or address
|
||||
stamps or everything elseyou like). This can easily be implemented with a
|
||||
Visitor:
|
||||
|
||||
package PersonVisitor;
|
||||
use Class::Std; # handles all basic stuff like constructors etc.
|
||||
|
||||
sub visit_Person {
|
||||
my ( $self, $object ) = @_;
|
||||
print "Person name is ", $object->get_name(), "\n";
|
||||
}
|
||||
|
||||
package Person;
|
||||
use Class::Std;
|
||||
my %name : ATTR(:name<name> :default<anonymous>);
|
||||
|
||||
sub accept { $_[1]->visit_Person( $_[0] ) }
|
||||
|
||||
package main;
|
||||
my @person_from = ();
|
||||
for (qw(Gamma Helm Johnson Vlissides)) {
|
||||
push @person_from, Person->new( { name => $_ } );
|
||||
}
|
||||
|
||||
my $visitor = PersonVisitor->new();
|
||||
for (@person_from) {
|
||||
$_->accept($visitor);
|
||||
}
|
||||
|
||||
# will print
|
||||
Person name is Gamma
|
||||
Person name is Helm
|
||||
Person name is Johnson
|
||||
Person name is Vlissides
|
||||
|
||||
While using this pattern for just printing a list may look a bit over-sized,
|
||||
but it may become handy if you need multiple output formats and different
|
||||
classes to operate on.
|
||||
|
||||
The main benefits using visitors are:
|
||||
|
||||
=over
|
||||
|
||||
=item * Grouping related behaviour in one class
|
||||
|
||||
Related behaviour for several classes can be grouped together in the Visitor
|
||||
class. The behaviour can easily be changed by changing the code in one class,
|
||||
instead of having to change all the visited classes.
|
||||
|
||||
=item * Cleaning up the data classes' implementations
|
||||
|
||||
If classes holding data also implement several different output formats or
|
||||
other (otherwise unrelated) behaviour, they tend to get bloated.
|
||||
|
||||
=item * Adding behaviour is easy
|
||||
|
||||
Swapping out the visitor class allows easy alterations of behaviour. So on a
|
||||
list of Persons, one Visitor may print address stamps, while another one prints
|
||||
out a phone number list.
|
||||
|
||||
=back
|
||||
|
||||
Of course, there are also drawbacks in the visitor pattern:
|
||||
|
||||
=over
|
||||
|
||||
=item * Changes in the visited classes are expensive
|
||||
|
||||
If one of the visited classes changes (or is added), all visitors must be
|
||||
updated to reflect this change. This may be rather expensive if classes change
|
||||
often.
|
||||
|
||||
=item * The visited classes must expose all data required
|
||||
|
||||
Visitors may need to use the internals of a class. This may result in fidelling
|
||||
with a object's internals, or a bloated interface in the visited class.
|
||||
|
||||
=back
|
||||
|
||||
Visitors are usually accompanied by a Iterator. The Iterator may be implemented
|
||||
in the visited classes, in the Visitor, or somewhere else (in the example it
|
||||
was somewhere else).
|
||||
|
||||
The Iterator decides which object to visit next.
|
||||
|
||||
=head2 Why SOAP::WSDL uses the Visitor pattern for Code Generation
|
||||
|
||||
Code generation in SOAP::WSDL means generating various artefacts:
|
||||
|
||||
=over
|
||||
|
||||
=item * Typemaps
|
||||
|
||||
For every WSDL definition, a Typemap is created. The Typemap is used later as
|
||||
an aid in parsing the SOAP XML messages.
|
||||
|
||||
=item * Type Classes
|
||||
|
||||
For every type defined in the WSDL's schema, a Type Class is generated.
|
||||
|
||||
These classes are instantiated later as a result of parsing SOAP XML messages.
|
||||
|
||||
=item * Interface Classes
|
||||
|
||||
For every service, a interface class is generated. This class is later used by
|
||||
programmers accessing the service
|
||||
|
||||
=item * Documentation
|
||||
|
||||
Both Type Classes and Interface Classes include documentation. Additional
|
||||
documentation may be generated as a hint for programmers, or later for
|
||||
mimicing .NET's .asmx example pages.
|
||||
|
||||
=back
|
||||
|
||||
All these behaviours could well (and has historically been) implemented in the
|
||||
classes holding the WSDL data. This made these classes rather bloated, and
|
||||
made it hard to change behaviour (like, supporting SOAP Headers,
|
||||
supporting atomic types and other features which were missing from early
|
||||
versions of SOAP::WSDL).
|
||||
|
||||
Implementing these behaviours in Visitor classes eases adding new behaviours,
|
||||
and reducing the incompletenesses still inherent in SOAP::WSDL's WSDL and XML
|
||||
schema implementation.
|
||||
|
||||
=head2 Implementation
|
||||
|
||||
=head3 _accept
|
||||
|
||||
SOAP::WSDL::Base defines an _accept method which expects a Visitor as only
|
||||
parameter. The method is named _accept (and not the common "accept") to avoid
|
||||
interferance with possible XML names (XML names must not start with a _).
|
||||
|
||||
Don't let the _ prefix fool you: The method is B<not> private (though it is
|
||||
meant to be called by Visitors only).
|
||||
|
||||
The method visit_Foo_Bar is called on the visitor, whith the self object as
|
||||
parameter.
|
||||
|
||||
The actual method name is constructed this way:
|
||||
|
||||
=over
|
||||
|
||||
=item * SOAP::WSDL is stripped from the class name
|
||||
|
||||
=item * All remaining :: s are replaced by _
|
||||
|
||||
=back
|
||||
|
||||
Example:
|
||||
|
||||
When visiting a SOAP::WSDL::XSD::ComplexType object, the method
|
||||
visit_XSD_ComplexType is called on the visitor.
|
||||
|
||||
=head2 Writing your own visitor
|
||||
|
||||
SOAP::WSDL eases writing your own visitor. This might be required if you need
|
||||
some special output format from a WSDL file, or want to feed your own
|
||||
serializer/deserializer pair with custom configuration data. Or maybe you want
|
||||
to generate C# code from it...
|
||||
|
||||
To write your own code generating visitor, you should subclass
|
||||
SOAP::WSDL::Generator::Visitor. It implements (empty) default methods for all
|
||||
SOAP::WSDL data classes.
|
||||
|
||||
In your Visitor, you must implement visit_Foo methods for all classes you wish
|
||||
to visit.
|
||||
|
||||
Currently, all SOAP::WSDL::Generator::Visitor implementations include their own
|
||||
Iterator (which means they know how to find the next objects to visit). You
|
||||
may or may not choose to implement a separate Iterator.
|
||||
|
||||
Letting a visitor implementing it's own Iterator visit a WSDL definition is as
|
||||
easy as writing something like this:
|
||||
|
||||
my $visitor = MyVisitor->new();
|
||||
my $parser = SOAP::WSDL::Expat::WSDLParser->new();
|
||||
my $definitions = $parser->parse_file('my.wsdl'):
|
||||
|
||||
$definitions->_accept( $visitor );
|
||||
|
||||
=head1 REFERENCES
|
||||
|
||||
=over
|
||||
|
||||
=item * [GHJV1995]
|
||||
|
||||
Erich Gamma, Richard Helm, Ralph E. Johnson, John Vlissides, (1995):
|
||||
Design Patterns. Elements of Reusable Object-Oriented Software.
|
||||
Addison-Wesley Longman, Amsterdam.
|
||||
|
||||
=back
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 239 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Client.pm 239 2007-09-11 09:45:42Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Client.pm $
|
||||
|
||||
=cut
|
||||
10
lib/SOAP/WSDL/Generator/Visitor/Typelib.pm
Normal file
10
lib/SOAP/WSDL/Generator/Visitor/Typelib.pm
Normal file
@@ -0,0 +1,10 @@
|
||||
package SOAP::WSDL::Generator::Visitor::Typelib;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(SOAP::WSDL::Generator::Visitor
|
||||
SOAP::WSDL::Generator::Template
|
||||
);
|
||||
|
||||
|
||||
1;
|
||||
|
||||
227
lib/SOAP/WSDL/Generator/Visitor/Typemap.pm
Normal file
227
lib/SOAP/WSDL/Generator/Visitor/Typemap.pm
Normal file
@@ -0,0 +1,227 @@
|
||||
package SOAP::WSDL::Generator::Visitor::Typemap;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
use base qw(SOAP::WSDL::Generator::Visitor);
|
||||
|
||||
my %path_of :ATTR(:name<path> :default<[]>);
|
||||
my %typemap_of :ATTR(:name<typemap> :default<()>);
|
||||
my %type_prefix_of :ATTR(:name<type_prefix> :default<()>);
|
||||
my %element_prefix_of :ATTR(:name<element_prefix> :default<()>);
|
||||
|
||||
sub START {
|
||||
my ($self, $ident, $arg_ref) = @_;
|
||||
$type_prefix_of{ $ident } ||= 'MyTypes';
|
||||
$element_prefix_of{ $ident } ||= 'MyElements';
|
||||
}
|
||||
|
||||
sub set_typemap_entry {
|
||||
my ($self, $value) = @_;
|
||||
$typemap_of{ ident $self }->{
|
||||
join( q{/}, @{ $path_of{ ident $self } } )
|
||||
} = $value;
|
||||
}
|
||||
|
||||
sub add_element_path {
|
||||
my ($self, $element) = @_;
|
||||
|
||||
# Swapping out this lines against the ones below generates
|
||||
# a namespace-sensitive typemap.
|
||||
# Well almost: Class names are not constructed in a namespace-sensitive
|
||||
# manner, yet - there should be some facility to allow binding a (perl)
|
||||
# prefix to a namespace...
|
||||
push @{ $path_of{ ident $self } }, $element->get_name();
|
||||
|
||||
# push @{ $path_of{ ident $self } },
|
||||
# "{". $element->get_targetNamespace . "}"
|
||||
# . $element->get_name();
|
||||
}
|
||||
|
||||
sub visit_Definitions {
|
||||
my ( $self, $ident, $definitions ) = ( $_[0], ident $_[0], $_[1] );
|
||||
|
||||
$self->set_definitions( $definitions );
|
||||
|
||||
for ( @{ $definitions->get_service() } ) {
|
||||
$_->_accept($self);
|
||||
}
|
||||
}
|
||||
|
||||
sub visit_Service {
|
||||
my ( $self, $service ) = ( $_[0], $_[1] );
|
||||
|
||||
for ( @{ $service->get_port() } ) { $_->_accept($self); }
|
||||
}
|
||||
|
||||
sub visit_Port {
|
||||
my ( $self, $ident, $port ) = ( $_[0], ident $_[0], $_[1] );
|
||||
|
||||
# This is a false assumption - typemaps may be valid for non-soap
|
||||
# bindings as well.
|
||||
# TODO check and correct
|
||||
return if not $port->first_address();
|
||||
return if not $port->first_address()->isa('SOAP::WSDL::SOAP::Address');
|
||||
|
||||
my $binding = $self->get_definitions()
|
||||
->find_binding( $port->expand( $port->get_binding() ) )
|
||||
or die 'binding ' . $port->get_binding() . ' not found!';
|
||||
|
||||
$binding->_accept($self);
|
||||
}
|
||||
|
||||
sub visit_Binding {
|
||||
my ( $self, $ident, $binding ) = ( $_[0], ident $_[0], $_[1] );
|
||||
|
||||
my $portType = $self->get_definitions()
|
||||
->find_portType( $binding->expand( $binding->get_type ) )
|
||||
or die 'portType not found: ' . $binding->binding_type;
|
||||
|
||||
for my $operation ( @{ $binding->get_operation() } ) {
|
||||
my $name = $operation->get_name();
|
||||
|
||||
# get the equally named operation from the portType
|
||||
my ($op) = grep { $_->get_name eq $name }
|
||||
@{ $portType->get_operation() }
|
||||
or die "operation <$name> not found";
|
||||
|
||||
# visit every input, output and fault message...
|
||||
for ( @{ $op->get_input }, @{ $op->get_output }, @{ $op->get_fault } ) {
|
||||
$_->_accept($self);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub visit_OpMessage {
|
||||
my ( $self, $ident, $operation_message ) = ( $_[0], ident $_[0], $_[1] );
|
||||
return if not( $operation_message->get_message() ); # we're in binding
|
||||
|
||||
# TODO maybe allow more messages && overloading by specifying name
|
||||
|
||||
# find message referenced in operation
|
||||
my $message = $self->get_definitions()->find_message(
|
||||
$operation_message->expand( $operation_message->get_message() ) );
|
||||
|
||||
for my $part ( @{ $message->get_part() } ) {
|
||||
$part->_accept($self);
|
||||
}
|
||||
}
|
||||
|
||||
sub visit_Part {
|
||||
my ( $self, $ident, $part ) = ( $_[0], ident $_[0], $_[1] );
|
||||
|
||||
my $types_ref = $self->get_definitions()->first_types()
|
||||
or warn "Empty part" . $part->get_name();
|
||||
|
||||
# resolve type
|
||||
# If we have a type, this type is to be used in document/literal
|
||||
# as global type. However this is forbidden, at least by WS-I.
|
||||
# We should store the style/encoding somewhere, and regard it.
|
||||
# TODO: auto-generate element for RPC bindings
|
||||
if ( my $type_name = $part->get_type ) {
|
||||
# FIXME support RPC-style calls
|
||||
die "unsupported global type <$type_name> found in part";
|
||||
}
|
||||
|
||||
# TODO factor out iterator or replace by lookup (probably better)
|
||||
if ( my $element_name = $part->get_element() ) {
|
||||
my $element = $types_ref->find_element(
|
||||
$part->expand($element_name) )
|
||||
|| die "no element $element_name found for part " . $part->get_name();
|
||||
$element->_accept($self);
|
||||
return;
|
||||
}
|
||||
|
||||
warn 'neither type nor element - do not know what to do for part '
|
||||
. $part->get_name();
|
||||
return;
|
||||
}
|
||||
|
||||
sub process_referenced_type {
|
||||
my ( $self, $ns, $localname ) = @_;
|
||||
return if not $localname;
|
||||
my $ident = ident $self;
|
||||
|
||||
# get type's class name
|
||||
# Caveat: visits type if it's a referenced type from the
|
||||
# a ? b : c operation.
|
||||
my $typeclass =
|
||||
( $ns eq 'http://www.w3.org/2001/XMLSchema' )
|
||||
? "SOAP::WSDL::XSD::Typelib::Builtin::$localname"
|
||||
: do {
|
||||
my $type =
|
||||
$self->get_definitions()->first_types()->find_type( $ns, $localname );
|
||||
$type->_accept($self);
|
||||
join( q{::}, $type_prefix_of{$ident}, $type->get_name() );
|
||||
};
|
||||
|
||||
$self->set_typemap_entry($typeclass);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub process_atomic_type {
|
||||
my ( $self, $type, $callback ) = @_;
|
||||
return if not $type;
|
||||
|
||||
my $ident = ident $self;
|
||||
$callback->( $self, $type ) if $callback;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub visit_XSD_Element {
|
||||
my ( $self, $ident, $element ) = ( $_[0], ident $_[0], $_[1] );
|
||||
|
||||
# TODO: what about element ref="" ?
|
||||
# when we're hopping from one element to the next one...
|
||||
|
||||
# step down in tree
|
||||
$self->add_element_path( $element );
|
||||
|
||||
# now call all possible variants.
|
||||
# They all just return if no argument is given,
|
||||
# and return $self on success.
|
||||
SWITCH: {
|
||||
if ($element->get_type) {
|
||||
$self->process_referenced_type( $element->expand( $element->get_type() ) )
|
||||
&& last;
|
||||
}
|
||||
# for atomic simple and comples types , and ref elements
|
||||
my $typeclass = join q{::}, $element_prefix_of{$ident}, $element->get_name();
|
||||
|
||||
$self->set_typemap_entry($typeclass);
|
||||
|
||||
# kind of double-dispatch: returns true on success, but does nothing
|
||||
$self->process_atomic_type( $element->first_simpleType() )
|
||||
&& last;
|
||||
|
||||
$self->process_atomic_type( $element->first_complexType()
|
||||
, sub { $_[1]->_accept($_[0]) } )
|
||||
&& last;
|
||||
|
||||
# TODO: add element ref handling
|
||||
};
|
||||
# step up in hierarchy
|
||||
pop @{ $path_of{$ident} };
|
||||
}
|
||||
|
||||
sub visit_XSD_ComplexType {
|
||||
my ($self, $ident, $type) = ($_[0], ident $_[0], $_[1] );
|
||||
my $content_model = $type->get_flavor();
|
||||
# TODO is this allowed ? or should we better die ?
|
||||
return if not $content_model; # empty complexType
|
||||
|
||||
if ( grep { $_ eq $content_model} qw(all sequence) )
|
||||
{
|
||||
# visit child elements
|
||||
for (@{ $type->get_element() }) {
|
||||
$_->_accept( $self );
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
warn "unsupported content model $content_model found in "
|
||||
. "complex type " . $type->get_name()
|
||||
. " - typemap may be incomplete";
|
||||
}
|
||||
|
||||
1;
|
||||
303
lib/SOAP/WSDL/Manual.pod
Normal file
303
lib/SOAP/WSDL/Manual.pod
Normal file
@@ -0,0 +1,303 @@
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Manual - Accessing WSDL based web services
|
||||
|
||||
=head1 Accessing a WSDL-based web service
|
||||
|
||||
=head2 Quick walk-through for the unpatient
|
||||
|
||||
=over
|
||||
|
||||
=item * Create WSDL bindings
|
||||
|
||||
perl wsdl2perl.pl -b base_dir URL
|
||||
|
||||
=item * Look what has been generated
|
||||
|
||||
Check the results of the generator. There should be one
|
||||
MyInterfaces/SERVICE_NAME/PORT_NAME.pm file per port (and one directory per
|
||||
service).
|
||||
|
||||
=item * Write script
|
||||
|
||||
use MyInterface::SERVICE_NAME::PORT_NAME;
|
||||
my $service = MyInterface::SERVICE_NAME::PORT_NAME->new();
|
||||
|
||||
my $result = $service->SERVICE_METHOD();
|
||||
die $result if not $result;
|
||||
|
||||
print $result;
|
||||
|
||||
C<perldoc MyInterface::SERVICE_NAME> should give you some overview about the
|
||||
service's interface structure.
|
||||
|
||||
The results of all calls to your service object's methods (except new) are
|
||||
objects based on SOAP::WSDL's XML schema implementation.
|
||||
|
||||
To access the object's properties use get_NAME / set_NAME getter/setter
|
||||
methods whith NAME corresponding to the XML tag name / the hash structure as
|
||||
showed in the generated pod.
|
||||
|
||||
=item * Run script
|
||||
|
||||
=back
|
||||
|
||||
=head2 Instrumenting web services with interface classes
|
||||
|
||||
SOAP::WSDL (starting from 2.00) instruments WSDL based web services with
|
||||
interface classes. This means that SOAP::WSDL features a code generator
|
||||
which creates one class for every web service you want to access.
|
||||
|
||||
Moreover, the data types from the WSDL definitions are also wrapped into
|
||||
classes and returned to the user as objects.
|
||||
|
||||
To find out which class a particular XML node should be, SOAP::WSDL uses
|
||||
typemaps. For every Web service, there's also a typemap created.
|
||||
|
||||
=head2 Interface class creation
|
||||
|
||||
To create interface classes, follow the steps above from
|
||||
L<Quick walk-through for the unpatient|Quick walk-through for the unpatient>.
|
||||
|
||||
If this works fine for you, skip the next paragraphs. If not, read on.
|
||||
|
||||
The steps to instrument a web service with SOAP::WSDL perl bindings
|
||||
(in detail) are as follows:
|
||||
|
||||
=over
|
||||
|
||||
=item * Gather web service information
|
||||
|
||||
You'll need to know at least a URL pointing to the web service's WSDL
|
||||
definition.
|
||||
|
||||
If you already know more - like which methods the service provides, or how
|
||||
the XML messages look like, that's fine. All these things will help you
|
||||
later.
|
||||
|
||||
=item * Create WSDL bindings
|
||||
|
||||
perl wsdl2perl.pl -b base_dir URL
|
||||
|
||||
This will generate the perl bindings in the directory specified by base_dir.
|
||||
|
||||
For more options, see L<wsdl2perl.pl> - you may want to specify class
|
||||
prefixes for XML type and element classes, type maps and interface classes,
|
||||
and you may even want to add custom typemap elements.
|
||||
|
||||
=item * Check the result
|
||||
|
||||
There should be a bunch of classes for types (in the MyTypes:: namespace by
|
||||
default), elements (in MyElements::), and at least one typemap (in
|
||||
MyTypemaps::) and one ore more interface classes (in MyInterfaces::).
|
||||
|
||||
If you don't already know the details of the web service you're going to
|
||||
instrument, it's now time to read the perldoc of the generated interface
|
||||
classes. It will tell you what methods each service provides, and which
|
||||
parameters they take.
|
||||
|
||||
If the WSDL definition is informative about what these methods do, the
|
||||
included perldoc will be, too - if not, blame the web service author.
|
||||
|
||||
=item * Write a perl script (or module) accessing the web service.
|
||||
|
||||
use MyInterface::SERVICE_NAME;
|
||||
my $service = MyInterface::SERVICE_NAME->new();
|
||||
|
||||
my $result = $service->SERVICE_METHOD();
|
||||
die $result if not $result;
|
||||
print $result;
|
||||
|
||||
The above handling of errors ("die $result if not $result") may look a bit
|
||||
strange - it is due to the nature of
|
||||
L<SOAP::WSDL::SOAP::Typelib::Fault11|SOAP::WSDL::SOAP::Typelib::Fault11>
|
||||
objects SOAP::WSDL uses for signalling failure.
|
||||
|
||||
These objects are false in boolean context, but serialize to their XML
|
||||
structure on stringification.
|
||||
|
||||
You may, of course, access individual fault properties, too. To get a list of
|
||||
fault properties, see L<SOAP::WSDL::SOAP::Typelib::Fault11>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Adding missing information
|
||||
|
||||
Sometimes, WSDL definitions are incomplete. In most of these cases, proper
|
||||
fault definitions are missing. This means that though the specification sais
|
||||
nothing about it, Fault messages include extra elements in the
|
||||
E<lt>detailE<gt> section, or errors are even indicated by non-fault messages.
|
||||
|
||||
There are two steps you need to perform for adding additional information.
|
||||
|
||||
=over
|
||||
|
||||
=item * Provide required type classes
|
||||
|
||||
For each extra data type used in the XML messages, a type class has to be
|
||||
created.
|
||||
|
||||
It is strongly discouraged to use the same namespace for hand-written and
|
||||
generated classes - while generated classes may be many, you probably will
|
||||
only implement a few by hand. These (precious) few classes may get lost in
|
||||
the mass of (cheap) generated ones. Just imagine one of your co-workers (or
|
||||
even yourself) deleting the whole bunch and re-generating everything - oops
|
||||
- almost everything. You got the point.
|
||||
|
||||
For simplicity, you probably just want to use builtin types wherever possible
|
||||
- you are probably not interested in whether a fault detail's error code is
|
||||
presented to you as a simpleType ranging from 1 to 10 (which you have to
|
||||
write) or as a int (which is a builtin type ready to use).
|
||||
|
||||
Using builtin types for simpleType definitions may greatly reduce the number
|
||||
of additional classes you need to implement.
|
||||
|
||||
If the extra type classes you need include E<lt>complexType E<gt> or
|
||||
E<lt>element /E<gt> definitions, see L<SOAP::WSDL::SOAP::Typelib::ComplexType>
|
||||
and L<SOAP::WSDL::SOAP::Typelib::Element> on how to create ComplexType and
|
||||
Element type classes.
|
||||
|
||||
=item * Provide a typemap snippet to wsdl2perl.pl
|
||||
|
||||
SOAP::WSDL uses typemaps for finding out into which class' object a XML node
|
||||
should be transformed.
|
||||
|
||||
Typemaps basically map the path of every XML element inside the Body tag to a
|
||||
perl class.
|
||||
|
||||
Typemap snippets have to look like this (which is actually the default Fault
|
||||
typemap included in every generated one):
|
||||
|
||||
(
|
||||
'Fault' => 'SOAP::WSDL::SOAP::Typelib::Fault11',
|
||||
'Fault/faultcode' => 'SOAP::WSDL::XSD::Typelib::Builtin::anyURI',
|
||||
'Fault/faultactor' => 'SOAP::WSDL::XSD::Typelib::Builtin::anyURI',
|
||||
'Fault/faultstring' => 'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
'Fault/detail' => 'SOAP::WSDL::XSD::Typelib::Builtin::anyType',
|
||||
);
|
||||
|
||||
The lines are hash key - value pairs. The keys are the XPath expressions
|
||||
without occurence numbers (like [1]) relative to the Body element.
|
||||
Namespaces are ignored.
|
||||
|
||||
If you don't know about XPath: They are just the names of the XML tags,
|
||||
starting from the one inside E<lt>BodyE<gt> up to the current one joined by /.
|
||||
|
||||
One line for every XML node is required.
|
||||
|
||||
You may use all builtin, generated or custom type class names as values.
|
||||
|
||||
Use wsdl2perl.pl -mi=FILE to include custom typemap snippets.
|
||||
|
||||
Note that typemap include files for wsdl2perl.pl must evaluate to a valid
|
||||
perl hash - it will be imported via eval (OK, to be honest: via I<do $file>,
|
||||
but that's almost the same...).
|
||||
|
||||
Your extra statements are included last, so they override potential typemap
|
||||
statements with the same keys.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Accessing a web service without a WSDL definition
|
||||
|
||||
Accessing a web service without a WSDL definition is more cumbersome. There
|
||||
are two ways to go:
|
||||
|
||||
=over
|
||||
|
||||
=item * Write a WSDL definition and generate interface
|
||||
|
||||
This is the way to go if you already are experienced in writing WSDL files.
|
||||
If you are not, be warned: Writing a correct WSDL is not an easy task, and
|
||||
writing correct WSDL files with only a text editor is almost impossible.
|
||||
|
||||
You should definitely use a WSDL editor. The WSDL editor should support
|
||||
conformance checks for the WS-I Basic Profile (1.0 is preferred by
|
||||
SOAP::WSDL)
|
||||
|
||||
=item * Write a typemap and class library from scratch
|
||||
|
||||
If the web service is relatively simple, this is probably easier than first
|
||||
writing a WSDL definition. Besides, it can be done in perl, a language you
|
||||
are probably more familiar with than WSDL.
|
||||
|
||||
L<SOAP::WSDL::XSD::Typelib::ComplexType>, L<SOAP::WSDL::XSD::Typelib::SimpleType> and
|
||||
L<SOAP::WSDL::XSD::Typelib::Element> tell you how to create subclasses of XML schema
|
||||
types.
|
||||
|
||||
L<SOAP::WSDL::Parser> will tell you how to create a typemap class.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Troubleshooting
|
||||
|
||||
=head2 Accessing HTTPS webservices
|
||||
|
||||
You need Crypt::SSLeay installed to access HTTPS webservices.
|
||||
|
||||
=head2 Accessing protected web services
|
||||
|
||||
Passing a userndame and password, or a client certificate and key, to the
|
||||
transport layer is highly dependent on the transport backend.
|
||||
|
||||
=head3 Accessing HTTP(S) webservices with basic/digest authentication
|
||||
|
||||
When using SOAP::WSDL::Transport::HTTP (SOAP::Lite not installed), add a
|
||||
method called "get_basic_credentials" to SOAP::WSDL::Transport::HTTP:
|
||||
|
||||
*SOAP::WSDL::Transport::HTTP::get_basic_credentials = sub {
|
||||
return ($user, $password);
|
||||
};
|
||||
|
||||
When using SOAP::Transport::HTTP (SOAP::Lite is installed), do the same to
|
||||
this backend:
|
||||
|
||||
*SOAP::Transport::HTTP::get_basic_credentials = sub {
|
||||
return ($user, $password);
|
||||
};
|
||||
|
||||
=head3 Accessing HTTP(S) webservices protected by NTLM authentication
|
||||
|
||||
Besides passing user credentials as when accessing a web service protected
|
||||
by basic or digest authentication, you also need to enforce connection
|
||||
keep_alive on the transport backens.
|
||||
|
||||
To do so, pass a I<proxy> argument to the new() method of the generated
|
||||
class. This unfortunately means that you have to set the endpoint URL, too:
|
||||
|
||||
my $interface = MyInterfaces::SERVICE_NAME::PORT_NAME->new({
|
||||
proxy => [ $url, keep_alive => 1 ]
|
||||
});
|
||||
|
||||
You may, of course, decide to just hack the generated class. Be advised that
|
||||
subclassing might be a more appropriate solution - re-generating overwrites
|
||||
your changes.
|
||||
|
||||
=head3 Accessing HTTPS webservices protected by certificate authentication
|
||||
|
||||
You need Crypt::SSLeay installed to access HTTPS webservices.
|
||||
|
||||
See L<Crypt::SSLeay> on how to configure client certificate authentication.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<SOAP::WSDL::Manual::Glossary> The meaning of all these words
|
||||
|
||||
L<SOAP::WSDL::Client> Basic client for SOAP::WSDL based interfaces
|
||||
|
||||
L<SOAP::WSDL> an interpreting WSDL based SOAP client
|
||||
|
||||
=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
|
||||
91
lib/SOAP/WSDL/Manual/Glossary.pod
Normal file
91
lib/SOAP/WSDL/Manual/Glossary.pod
Normal file
@@ -0,0 +1,91 @@
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Manual::Glossary - Those acronyms and stuff
|
||||
|
||||
=head1 Glossary
|
||||
|
||||
=head2 web service
|
||||
|
||||
Web services are RPC (Remote Procedure Call) interfaces accessible via
|
||||
some internet protocol, typically via HTTP(S).
|
||||
|
||||
=head2 SOAP
|
||||
|
||||
SOAP is an acronym for Simple Object Access Protocol.
|
||||
SOAP is a W3C recommendation. The latest version of the SOAP
|
||||
specification may be found at L<http://www.w3.org/TR/soap/>.
|
||||
|
||||
SOAP defines a protocoll for message exchange between applications.
|
||||
The most popular usage is to use SOAP for remote procedure calls (RPC).
|
||||
|
||||
While one of the constituting aspects of a web service is its
|
||||
reachability via some internet protocol, you might as well define
|
||||
SOAP services accessible via postcards.
|
||||
|
||||
Despite it's name, SOAP has nothing more to do with objects than
|
||||
cars have with pets - SOAP messages may, but not neccessarily do
|
||||
carry objects, very much like your car may, but does not need to
|
||||
carry your pet.
|
||||
|
||||
=head2 WSDL
|
||||
|
||||
WSDL is an acronym for Web Services Description Language.
|
||||
WSDL is a W3C recommendation. The latest version of the WSDL specification
|
||||
may be found at L<http://www.w3.org/TR/wsdl20/>.
|
||||
|
||||
WSDL defines a XML-based language for describing web service interfaces,
|
||||
including SOAP interfaces.
|
||||
|
||||
=head2 WS-I
|
||||
|
||||
WS-I (Web Services Interoperability Organization) is an open industry
|
||||
organisation chartered to promote Web service interoperability across
|
||||
platforms, operating systems, and programming languages.
|
||||
|
||||
WS-I publishes profiles, which provide implementation guidelines for
|
||||
how related Web services specifications should be used together for
|
||||
best interoperability. To date, WS-I has finalized the Basic Profile,
|
||||
Attachments Profile and Simple SOAP Binding Profile.
|
||||
|
||||
SOAP::WSDL aims at complying to the Basic Profile (but does not
|
||||
implement full support yet).
|
||||
|
||||
=head2 SOAP message styles
|
||||
|
||||
=head3 rpc
|
||||
|
||||
Meant for transporting a RPC message. All contents of the SOAP body are
|
||||
put into a top-level node named equal to the SOAP operation.
|
||||
|
||||
WS-I Basic Profile allows the use of rpc message style.
|
||||
|
||||
SOAP::WSDL does not support rpc message style yet.
|
||||
|
||||
SOAP::Lite supports rpc message style only.
|
||||
|
||||
=head3 document
|
||||
|
||||
Meant for transporting arbitrary content. No additional nodes are inserted
|
||||
between the SOAP body and the actual content.
|
||||
|
||||
WS-I Basic Profile allows the use of document message style.
|
||||
|
||||
=head2 SOAP encoding styles
|
||||
|
||||
=head3 encoded
|
||||
|
||||
=head3 literal
|
||||
|
||||
=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
|
||||
|
||||
1247
lib/SOAP/WSDL/Manual/WS_I.pod
Normal file
1247
lib/SOAP/WSDL/Manual/WS_I.pod
Normal file
File diff suppressed because it is too large
Load Diff
9
lib/SOAP/WSDL/Message.pm
Normal file
9
lib/SOAP/WSDL/Message.pm
Normal file
@@ -0,0 +1,9 @@
|
||||
package SOAP::WSDL::Message;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %part_of :ATTR(:name<part> :default<[]>);
|
||||
|
||||
1;
|
||||
12
lib/SOAP/WSDL/OpMessage.pm
Normal file
12
lib/SOAP/WSDL/OpMessage.pm
Normal file
@@ -0,0 +1,12 @@
|
||||
package SOAP::WSDL::OpMessage;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %body_of :ATTR(:name<body> :default<[]>);
|
||||
my %header_of :ATTR(:name<header> :default<[]>);
|
||||
my %headerfault_of :ATTR(:name<headerfault> :default<[]>);
|
||||
my %message_of :ATTR(:name<message> :default<()>);
|
||||
|
||||
1;
|
||||
16
lib/SOAP/WSDL/Operation.pm
Normal file
16
lib/SOAP/WSDL/Operation.pm
Normal file
@@ -0,0 +1,16 @@
|
||||
package SOAP::WSDL::Operation;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw/SOAP::WSDL::Base/;
|
||||
|
||||
my %operation_of :ATTR(:name<operation> :default<()>);
|
||||
my %input_of :ATTR(:name<input> :default<[]>);
|
||||
my %output_of :ATTR(:name<output> :default<[]>);
|
||||
my %fault_of :ATTR(:name<fault> :default<[]>);
|
||||
my %type_of :ATTR(:name<type> :default<()>);
|
||||
my %style_of :ATTR(:name<style> :default<()>);
|
||||
my %transport_of :ATTR(:name<transport> :default<()>);
|
||||
my %parameterOrder_of :ATTR(:name<parameterOrder> :default<()>);
|
||||
|
||||
1;
|
||||
264
lib/SOAP/WSDL/Parser.pod
Normal file
264
lib/SOAP/WSDL/Parser.pod
Normal file
@@ -0,0 +1,264 @@
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Parser - How SOAP::WSDL parses XML messages
|
||||
|
||||
=head1 Which XML message does SOAP::WSDL parse ?
|
||||
|
||||
Naturally, there are two kinds of XML documents (or messages) SOAP::WSDL has
|
||||
to parse:
|
||||
|
||||
=over
|
||||
|
||||
=item * WSDL definitions
|
||||
|
||||
=item * SOAP messages
|
||||
|
||||
=back
|
||||
|
||||
=head1 Parser implementations
|
||||
|
||||
There are different parser implementations available for SOAP messages and
|
||||
WSDL definitions.
|
||||
|
||||
Historically, SOAP::WSDL used SAX for parsing XML. The SAX handlers were
|
||||
implemented as L<XML::LibXML|XML::LibXML> handlers, which also worked with
|
||||
L<XML::SAX::ParserFactory|XML::SAX::ParserFactory>.
|
||||
|
||||
Support for SAX and L<XML::LibXML|XML::LibXML> in SOAP::WSDL is discontinued
|
||||
for the following reasons:
|
||||
|
||||
=over
|
||||
|
||||
=item * Speed
|
||||
|
||||
L<XML::Parser::Expat|XML::Parser::Expat> is faster than
|
||||
L<XML::LibXML|XML::LibXML> - at least when optimized for speed.
|
||||
|
||||
High parsing speed is one of the key requirements for a SOAP toolkit - if XML
|
||||
serializing and (more important) deserializing are not fast enough, the whole
|
||||
toolkit is unusable.
|
||||
|
||||
=item * Availability
|
||||
|
||||
L<XML::Parser|XML::Parser> is more popular than L<XML::LibXML|XML::LibXML>.
|
||||
|
||||
=item * Stability
|
||||
|
||||
XML::LibXML is based on the libxml2 library. Several versions of
|
||||
libxml2 are known to have specific bugs. As a workaround, there are
|
||||
often several versions of libxml2 installed on one system. This may
|
||||
lead to problems on operating systems which cannot load more than
|
||||
one version of a shared library simultaneously.
|
||||
|
||||
XML::LibXML is also still under development, while XML::Parser has had time
|
||||
to stabilize.
|
||||
|
||||
=item * SOAP::Lite uses XML::Parser
|
||||
|
||||
L<SOAP::Lite|SOAP::Lite> uses L<XML::Parser|XML::Parser> if available.
|
||||
SOAP::WSDL should not require users to install both L<XML::Parser|XML::Parser>
|
||||
and L<XML::LibXML|XML::LibXML>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 WSDL definitions parser
|
||||
|
||||
=over
|
||||
|
||||
=item * SOAP::WSDL::Expat::WSDLParser
|
||||
|
||||
A parser for WSDL definitions based on L<XML::Parser::Expat|XML::Parser::Expat>.
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::WSDLParser->new();
|
||||
my $wsdl = $parser->parse_file( $filename );
|
||||
|
||||
=back
|
||||
|
||||
=head2 SOAP messages parser
|
||||
|
||||
All SOAP message handler use class resolvers for finding out which class
|
||||
a particular XML element should be of, and type libs containing these classes.
|
||||
|
||||
=head3 Creating a class resolver
|
||||
|
||||
The easiest way for creating a class resolver is to run SOAP::WSDL's generator.
|
||||
|
||||
See wsdl2perl.pl
|
||||
|
||||
The class resolver must implement a class method "get_class", which is passed
|
||||
a list ref of the current element's XPath (relative to Body), split by /.
|
||||
|
||||
This method must return a class name appropriate for a XML element.
|
||||
|
||||
A class resolver package might look like this:
|
||||
|
||||
package ClassResolver;
|
||||
|
||||
my %class_list = (
|
||||
'EnqueueMessage' => 'Typelib::TEnqueueMessage',
|
||||
'EnqueueMessage/MMessage' => 'Typelib::TMessage',
|
||||
'EnqueueMessage/MMessage/MRecipientURI' => 'SOAP::WSDL::XSD::Builtin::anyURI',
|
||||
'EnqueueMessage/MMessage/MMessageContent' => 'SOAP::WSDL::XSD::Builtin::string',
|
||||
);
|
||||
|
||||
sub new { return bless {}, 'ClassResolver' };
|
||||
|
||||
sub get_class {
|
||||
my $name = join('/', @{ $_[1] });
|
||||
return ($class_list{ $name }) ? $class_list{ $name }
|
||||
: warn "no class found for $name";
|
||||
};
|
||||
1;
|
||||
|
||||
=head3 Skipping unwanted items
|
||||
|
||||
Sometimes there's unneccessary information transported in SOAP messages.
|
||||
|
||||
To skip XML nodes (including all child nodes), just edit the type map for
|
||||
the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
In the example above, EnqueueMessage/StuffIDontNeed and all child elements
|
||||
are skipped.
|
||||
|
||||
my %class_list = (
|
||||
'EnqueueMessage' => 'Typelib::TEnqueueMessage',
|
||||
'EnqueueMessage/MMessage' => 'Typelib::TMessage',
|
||||
'EnqueueMessage/MMessage/MRecipientURI' => 'SOAP::WSDL::XSD::Builtin::anyURI',
|
||||
'EnqueueMessage/MMessage/MMessageContent' => 'SOAP::WSDL::XSD::Builtin::string',
|
||||
'EnqueueMessage/StuffIDontNeed' => '__SKIP__',
|
||||
'EnqueueMessage/StuffIDontNeed/Foo' => 'SOAP::WSDL::XSD::Builtin::string',
|
||||
'EnqueueMessage/StuffIDontNeed/Bar' => 'SOAP::WSDL::XSD::Builtin::string',
|
||||
);
|
||||
|
||||
Note that only SOAP::WSDL::Expat::MessageParser implements skipping elements
|
||||
at the time of writing.
|
||||
|
||||
=head3 Creating type lib classes
|
||||
|
||||
Every element must have a correspondent one in the type library.
|
||||
|
||||
Builtin types should be resolved as SOAP::WSDL::XSD::Builtin::* classes
|
||||
|
||||
Creating a type lib is easy: Just run SOAP::WSDL's generator - it will
|
||||
create both a typemap and the type lib classes for a WSDL file.
|
||||
|
||||
Sometimes it is nessecary to create type lib classes by hand - not all
|
||||
WSDL definitions are complete.
|
||||
|
||||
For writing your own lib classes, see L<SOAP::WSDL::XSD::Typelib::Element>,
|
||||
L<SOAP::WSDL::XSD::Typelib::ComplexType> and L<SOAP::WSDL::XSD::Typelib::SimpleType>.
|
||||
|
||||
=head3 Parser implementations
|
||||
|
||||
=over
|
||||
|
||||
=item * SOAP::WSDL::Expat::MessageParser
|
||||
|
||||
A L<XML::Parser::Expat|XML::Parser::Expat> based parser. This is the fastest
|
||||
parser for most SOAP messages and the default for SOAP::WSDL::Client.
|
||||
|
||||
=item * SOAP::WSDL::Expat::MessageStreamParser
|
||||
|
||||
A XML::Parser::ExpatNB based parser. Useful for parsing huge HTTP responses,
|
||||
as you don't need to keep everything in memory.
|
||||
|
||||
See L<SOAP::WSDL::Expat::MessageStreamParser|SOAP::WSDL::Expat::MessageStreamParser>
|
||||
for details.
|
||||
|
||||
=back
|
||||
|
||||
=head3 Performance
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser is the fastest way of parsing SOAP messages
|
||||
into object trees and only slightly slower than converting them into hash
|
||||
data structures:
|
||||
|
||||
Parsing a SOAP message with a length of 5962 bytes:
|
||||
SOAP::WSDL::Expat::MessageParser:
|
||||
3 wallclock secs ( 3.28 usr + 0.05 sys = 3.33 CPU) @ 60.08/s (n=200)
|
||||
|
||||
SOAP::WSDL::SAX::MessageHandler (with raw XML::LibXML):
|
||||
5 wallclock secs ( 4.95 usr + 0.00 sys = 4.95 CPU) @ 40.38/s (n=200)
|
||||
|
||||
XML::Simple (XML::Parser):
|
||||
3 wallclock secs ( 2.36 usr + 0.03 sys = 2.39 CPU) @ 83.65/s (n=200)
|
||||
|
||||
XML::Simple (XML::SAX::Expat):
|
||||
7 wallclock secs ( 6.50 usr + 0.03 sys = 6.53 CPU) @ 30.62/s (n=200)
|
||||
|
||||
As the benchmark shows, all SOAP::WSDL parser variants are faster than
|
||||
XML::Simple with XML::SAX::Expat, and SOAP::WSDL::Expat::MessageParser almost
|
||||
reaches the performance of XML::Simple with XML::Parser as backend.
|
||||
|
||||
Parsing SOAP responses in chunks does not increase speed - at least not up
|
||||
to a response size of around 500k:
|
||||
|
||||
Benchmark: timing 5 iterations of SOAP::WSDL::SAX::MessageHandler,
|
||||
SOAP::WSDL::Expat::MessageParser, SOAP::WSDL::Expat::MessageStreamParser...
|
||||
|
||||
SOAP::WSDL::Expat::MessageStreamParser:
|
||||
13 wallclock secs ( 7.39 usr + 0.09 sys = 7.48 CPU) @ 0.67/s (n=5)
|
||||
|
||||
SOAP::WSDL::Expat::MessageParser:
|
||||
10 wallclock secs ( 5.81 usr + 0.06 sys = 5.88 CPU) @ 0.85/s (n=5)
|
||||
|
||||
SOAP::WSDL::SAX::MessageHandler:
|
||||
14 wallclock secs ( 8.78 usr + 0.03 sys = 8.81 CPU) @ 0.57/s (n=5)
|
||||
|
||||
Response size: 344330 bytes
|
||||
|
||||
=head1 OLD SAX HANDLER
|
||||
|
||||
The old SAX handler historically used in SOAP::WSDL are not included in
|
||||
the SOAP::WSDL package any more.
|
||||
|
||||
However, they may be obtained from the "attic" directory in
|
||||
SOAP::WSDL's SVN repository at
|
||||
|
||||
https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/attic
|
||||
|
||||
=over
|
||||
|
||||
=item * SOAP::WSDL::SAX::WSDLHandler
|
||||
|
||||
This is a SAX handler for parsing WSDL files into object trees SOAP::WSDL
|
||||
works with.
|
||||
|
||||
It's built as a native handler for XML::LibXML, but will also work with
|
||||
XML::SAX::ParserFactory.
|
||||
|
||||
To parse a WSDL file, use one of the following variants:
|
||||
|
||||
my $parser = XML::LibXML->new();
|
||||
my $handler = SOAP::WSDL::SAX::WSDLHandler->new();
|
||||
$parser->set_handler( $handler );
|
||||
$parser->parse( $xml );
|
||||
my $data = $handler->get_data();
|
||||
|
||||
|
||||
my $handler = SOAP::WSDL::SAX::WSDLHandler->new({
|
||||
base => 'XML::SAX::Base'
|
||||
});
|
||||
my $parser = XML::SAX::ParserFactor->parser(
|
||||
Handler => $handler
|
||||
);
|
||||
$parser->parse( $xml );
|
||||
my $data = $handler->get_data();
|
||||
|
||||
|
||||
=item * SOAP::WSDL::SAX::MessageHandler
|
||||
|
||||
This is a SAX handler for parsing WSDL files into object trees SOAP::WSDL
|
||||
works with.
|
||||
|
||||
It's built as a native handler for XML::LibXML, but will also work with
|
||||
XML::SAX::ParserFactory.
|
||||
|
||||
Can be used for parsing both streams (chunks) and documents.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=cut
|
||||
44
lib/SOAP/WSDL/Part.pm
Normal file
44
lib/SOAP/WSDL/Part.pm
Normal file
@@ -0,0 +1,44 @@
|
||||
package SOAP::WSDL::Part;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw(croak);
|
||||
use Class::Std::Storable;
|
||||
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %element_of :ATTR(:name<element> :default<()>);
|
||||
my %type_of :ATTR(:name<type> :default<()>);
|
||||
|
||||
sub serialize
|
||||
{
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $data = shift;
|
||||
my $opt = shift;
|
||||
my $typelib = $opt->{ typelib } || die "No typelib";
|
||||
my %ns_map = reverse %{ $opt->{ namespace } };
|
||||
|
||||
my $item_name;
|
||||
if ($item_name = $self->get_type() ) {
|
||||
# resolve type
|
||||
my ($prefix, $localname) = split /:/ , $item_name, 2;
|
||||
my $type = $typelib->find_type( $ns_map{ $prefix }, $localname )
|
||||
or die "type $item_name , $ns_map{ $prefix } not found";
|
||||
|
||||
my $name = $self->get_name();
|
||||
return $type->serialize( $name, $data->{ $name }, $opt );
|
||||
}
|
||||
elsif ( $item_name = $self->get_element() ) {
|
||||
my ($prefix, $localname) = split /:/ , $item_name, 2;
|
||||
my $element = $typelib->find_element(
|
||||
$ns_map{ $prefix },
|
||||
$localname
|
||||
)
|
||||
or die "element $item_name , $ns_map{ $prefix } not found";
|
||||
$opt->{ qualify } = 1;
|
||||
return $element->serialize( undef, $data->{ $element->get_name() }, $opt );
|
||||
}
|
||||
die "Neither type nor element - don't know what to do";
|
||||
}
|
||||
|
||||
1;
|
||||
10
lib/SOAP/WSDL/Port.pm
Normal file
10
lib/SOAP/WSDL/Port.pm
Normal file
@@ -0,0 +1,10 @@
|
||||
package SOAP::WSDL::Port;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %binding_of :ATTR(:name<binding> :default<()>);
|
||||
my %address_of :ATTR(:name<address> :default<()>);
|
||||
|
||||
1;
|
||||
32
lib/SOAP/WSDL/PortType.pm
Normal file
32
lib/SOAP/WSDL/PortType.pm
Normal file
@@ -0,0 +1,32 @@
|
||||
package SOAP::WSDL::PortType;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %operation_of :ATTR(:name<operation> :default<()>);
|
||||
|
||||
my %attributes_of :ATTR();
|
||||
|
||||
%attributes_of = (
|
||||
operation => \%operation_of,
|
||||
);
|
||||
|
||||
# Function factory - we could be writing this method for all %attribute
|
||||
# keys, too, but that's just C&P (eehm, Copy & Paste...)
|
||||
foreach my $method(keys %attributes_of ) {
|
||||
no strict qw/refs/;
|
||||
|
||||
# ... btw, we mean this method here...
|
||||
*{ "find_$method" } = sub {
|
||||
my ($self, @args) = @_;
|
||||
my @found_at = grep {
|
||||
$_->get_targetNamespace() eq $args[0] &&
|
||||
$_->get_name() eq $args[1]
|
||||
}
|
||||
@{ $attributes_of{ $method }->{ ident $self } };
|
||||
return $found_at[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
9
lib/SOAP/WSDL/SOAP/Address.pm
Normal file
9
lib/SOAP/WSDL/SOAP/Address.pm
Normal file
@@ -0,0 +1,9 @@
|
||||
package SOAP::WSDL::SOAP::Address;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
|
||||
my %location :ATTR(:name<location> :default<()>);
|
||||
1;
|
||||
11
lib/SOAP/WSDL/SOAP/Body.pm
Normal file
11
lib/SOAP/WSDL/SOAP/Body.pm
Normal file
@@ -0,0 +1,11 @@
|
||||
package SOAP::WSDL::SOAP::Body;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %use_of :ATTR(:name<use> :default<q{}>);
|
||||
my %namespace_of :ATTR(:name<namespace> :default<q{}>);
|
||||
my %encodingStyle_of :ATTR(:name<encodingStyle> :default<q{}>);
|
||||
my %parts_of :ATTR(:name<parts> :default<q{}>);
|
||||
|
||||
1;
|
||||
12
lib/SOAP/WSDL/SOAP/Header.pm
Normal file
12
lib/SOAP/WSDL/SOAP/Header.pm
Normal file
@@ -0,0 +1,12 @@
|
||||
package SOAP::WSDL::SOAP::Header;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %use_of :ATTR(:name<use> :default<q{}>);
|
||||
my %namespace_of :ATTR(:name<namespace> :default<q{}>);
|
||||
my %encodingStyle_of :ATTR(:name<encodingStyle> :default<q{}>);
|
||||
my %message_of :ATTR(:name<message> :default<()>);
|
||||
my %part_of :ATTR(:name<part> :default<q{}>);
|
||||
|
||||
1;
|
||||
6
lib/SOAP/WSDL/SOAP/HeaderFault.pm
Normal file
6
lib/SOAP/WSDL/SOAP/HeaderFault.pm
Normal file
@@ -0,0 +1,6 @@
|
||||
package SOAP::WSDL::SOAP::HeaderFault;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(SOAP::WSDL::Header);
|
||||
|
||||
1;
|
||||
22
lib/SOAP/WSDL/SOAP/Operation.pm
Normal file
22
lib/SOAP/WSDL/SOAP/Operation.pm
Normal file
@@ -0,0 +1,22 @@
|
||||
package SOAP::WSDL::SOAP::Operation;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %style_of :ATTR(:name<style> :default<()>);
|
||||
my %soapAction_of :ATTR(:name<soapAction> :default<()>);
|
||||
|
||||
sub explain {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $txt = '';
|
||||
$opt->{ indent } ||= '';
|
||||
|
||||
$txt .= $opt->{ indent } . "soapAction: " . $self->soapAction() . "\n"
|
||||
if ( $self->soapAction() );
|
||||
|
||||
return $txt;
|
||||
}
|
||||
|
||||
1;
|
||||
100
lib/SOAP/WSDL/SOAP/Typelib/Fault11.pm
Normal file
100
lib/SOAP/WSDL/SOAP/Typelib/Fault11.pm
Normal file
@@ -0,0 +1,100 @@
|
||||
package SOAP::WSDL::SOAP::Typelib::Fault11;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use Data::Dumper;
|
||||
|
||||
use SOAP::WSDL::XSD::Typelib::ComplexType;
|
||||
use SOAP::WSDL::XSD::Typelib::Element;
|
||||
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
SOAP::WSDL::XSD::Typelib::ComplexType
|
||||
);
|
||||
|
||||
my %faultcode_of :ATTR(:get<faultcode>);
|
||||
my %faultstring_of :ATTR(:get<faultstring>);
|
||||
my %faultactor_of :ATTR(:get<faultactor>);
|
||||
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 detail) ],
|
||||
{
|
||||
faultcode => \%faultcode_of,
|
||||
faultstring => \%faultstring_of,
|
||||
faultactor => \%faultactor_of,
|
||||
detail => \%detail_of,
|
||||
},
|
||||
{
|
||||
faultcode => 'SOAP::WSDL::XSD::Typelib::Builtin::QName',
|
||||
faultstring => 'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
faultactor => 'SOAP::WSDL::XSD::Typelib::Builtin::anyURI',
|
||||
detail => 'SOAP::WSDL::XSD::Typelib::Builtin::anyType',
|
||||
}
|
||||
);
|
||||
|
||||
sub get_xmlns { return 'http://schemas.xmlsoap.org/soap/envelope/' };
|
||||
|
||||
__PACKAGE__->__set_name('Fault');
|
||||
__PACKAGE__->__set_nillable();
|
||||
__PACKAGE__->__set_minOccurs();
|
||||
__PACKAGE__->__set_maxOccurs();
|
||||
__PACKAGE__->__set_ref('');
|
||||
|
||||
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
|
||||
71
lib/SOAP/WSDL/Serializer/SOAP11.pm
Normal file
71
lib/SOAP/WSDL/Serializer/SOAP11.pm
Normal file
@@ -0,0 +1,71 @@
|
||||
#!/usr/bin/perl -w
|
||||
package SOAP::WSDL::Serializer::SOAP11;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
our $VERSION='2.00_13';
|
||||
|
||||
my $SOAP_NS = 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
my $XML_INSTANCE_NS = 'http://www.w3.org/2001/XMLSchema-instance';
|
||||
|
||||
sub serialize {
|
||||
my ($self, $args_of_ref) = @_;
|
||||
|
||||
my $opt = $args_of_ref->{ options };
|
||||
|
||||
if (not $opt->{ namespace }->{ $SOAP_NS })
|
||||
{
|
||||
$opt->{ namespace }->{ $SOAP_NS } = 'SOAP-ENV';
|
||||
}
|
||||
|
||||
if (not $opt->{ namespace }->{ $XML_INSTANCE_NS })
|
||||
{
|
||||
$opt->{ namespace }->{ $XML_INSTANCE_NS } = 'xsi';
|
||||
}
|
||||
|
||||
my $soap_prefix = $opt->{ namespace }->{ $SOAP_NS };
|
||||
|
||||
# envelope start with namespaces
|
||||
my $xml = "<$soap_prefix\:Envelope ";
|
||||
|
||||
while (my ($uri, $prefix) = each %{ $opt->{ namespace } })
|
||||
{
|
||||
$xml .= "\n\t" if ($opt->{'readable'});
|
||||
$xml .= "xmlns:$prefix=\"$uri\" ";
|
||||
}
|
||||
|
||||
# TODO insert encoding
|
||||
$xml.='>';
|
||||
$xml .= $self->serialize_header($args_of_ref->{ method }, $args_of_ref->{ header }, $opt);
|
||||
$xml .= "\n" if ($opt->{ readable });
|
||||
$xml .= $self->serialize_body($args_of_ref->{ method }, $args_of_ref->{ body }, $opt);
|
||||
$xml .= "\n" if ($opt->{ readable });
|
||||
$xml .= '</' . $soap_prefix .':Envelope>';
|
||||
$xml .= "\n" if ($opt->{ readable });
|
||||
return $xml;
|
||||
}
|
||||
|
||||
sub serialize_header {
|
||||
my ($self, $name, $data, $opt) = @_;
|
||||
|
||||
# header is optional. Leave out if there's no header data
|
||||
return q{} if not $data;
|
||||
return join ( ($opt->{ readable }) ? "\n" : q{},
|
||||
"<$opt->{ namespace }->{ $SOAP_NS }\:Header>",
|
||||
"$data",
|
||||
"</$opt->{ namespace }->{ $SOAP_NS }\:Header>",
|
||||
);
|
||||
}
|
||||
|
||||
sub serialize_body {
|
||||
my ($self, $name, $data, $opt) = @_;
|
||||
|
||||
# Body is NOT optional. Serialize to empty body
|
||||
# if we have no data.
|
||||
return join ( ($opt->{ readable }) ? "\n" : q{},
|
||||
"<$opt->{ namespace }->{ $SOAP_NS }\:Body>",
|
||||
defined $data ? "$data" : (),
|
||||
"</$opt->{ namespace }->{ $SOAP_NS }\:Body>",
|
||||
);
|
||||
}
|
||||
9
lib/SOAP/WSDL/Service.pm
Normal file
9
lib/SOAP/WSDL/Service.pm
Normal file
@@ -0,0 +1,9 @@
|
||||
package SOAP::WSDL::Service;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %port_of :ATTR(:name<port> :default<()>);
|
||||
|
||||
1;
|
||||
96
lib/SOAP/WSDL/Transport/HTTP.pm
Normal file
96
lib/SOAP/WSDL/Transport/HTTP.pm
Normal file
@@ -0,0 +1,96 @@
|
||||
package SOAP::WSDL::Transport::HTTP;
|
||||
use strict;
|
||||
use base qw(LWP::UserAgent);
|
||||
|
||||
# create methods normally inherited from SOAP::Client
|
||||
SUBFACTORY: {
|
||||
no strict qw(refs);
|
||||
foreach my $method ( qw(code message status is_success) ) {
|
||||
*{ $method } = sub {
|
||||
my $self = shift;
|
||||
return $self->{ $method } if not @_;
|
||||
return $self->{ $method } = shift;
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub send_receive {
|
||||
my ($self, %parameters) = @_;
|
||||
my ($envelope, $soap_action, $endpoint, $encoding, $content_type) =
|
||||
@parameters{qw(envelope action endpoint encoding content_type)};
|
||||
|
||||
$encoding = defined($encoding)
|
||||
? 'utf8'
|
||||
: lc($encoding);
|
||||
|
||||
# what's this all about?
|
||||
# unfortunately combination of LWP and Perl 5.6.1 and later has bug
|
||||
# in sending multibyte characters. LWP uses length() to calculate
|
||||
# content-length header and starting 5.6.1 length() calculates chars
|
||||
# instead of bytes. 'use bytes' in THIS file doesn't work, because
|
||||
# it's lexically scoped. Unfortunately, content-length we calculate
|
||||
# here doesn't work either, because LWP overwrites it with
|
||||
# content-length it calculates (which is wrong) AND uses length()
|
||||
# during syswrite/sysread, so we are in a bad shape anyway.
|
||||
#
|
||||
# what to do? we calculate proper content-length (using
|
||||
# bytelength() function from SOAP::Utils) and then drop utf8 mark
|
||||
# from string (doing pack with 'C0A*' modifier) if length and
|
||||
# bytelength are not the same
|
||||
|
||||
# use bytes is lexically scoped
|
||||
my $bytelength = do { use bytes; length $envelope };
|
||||
$envelope = pack('C0A*', $envelope)
|
||||
if length($envelope) != $bytelength;
|
||||
|
||||
my $request = HTTP::Request->new( 'POST',
|
||||
$endpoint,
|
||||
[ 'Content-Type', "$content_type; charset=$encoding",
|
||||
'Content-Length', $bytelength,
|
||||
'SOAPAction', $soap_action,
|
||||
],
|
||||
$envelope );
|
||||
|
||||
my $response = $self->request( $request );
|
||||
|
||||
$self->code( $response->code);
|
||||
$self->message( $response->message);
|
||||
$self->is_success($response->is_success);
|
||||
$self->status($response->status_line);
|
||||
|
||||
return $response->content();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Transport::HTTP - Fallback http(s) transport class
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Provides a thin transport class used by SOAP::WSDL::Transport when
|
||||
SOAP::Lite is not available.
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 288 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: HTTP.pm 288 2007-09-29 19:34:20Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Transport/HTTP.pm $
|
||||
|
||||
=cut
|
||||
|
||||
129
lib/SOAP/WSDL/Transport/Test.pm
Normal file
129
lib/SOAP/WSDL/Transport/Test.pm
Normal file
@@ -0,0 +1,129 @@
|
||||
package SOAP::WSDL::Transport::Test;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::Factory::Transport;
|
||||
|
||||
our $VERSION = '2.00_14';
|
||||
|
||||
SOAP::WSDL::Factory::Transport->register( http => __PACKAGE__ );
|
||||
SOAP::WSDL::Factory::Transport->register( https => __PACKAGE__ );
|
||||
|
||||
my %code_of :ATTR(:name<code> :default<()>);
|
||||
my %status_of :ATTR(:name<status> :default<()>);
|
||||
my %message_of :ATTR(:name<message> :default<()>);
|
||||
my %is_success_of :ATTR(:name<is_success> :default<()>);
|
||||
my %base_dir_of :ATTR(:name<base_dir> :init_arg<base_dir> :default<.>);
|
||||
|
||||
# create methods normally inherited from SOAP::Client
|
||||
SUBFACTORY: {
|
||||
no strict qw(refs);
|
||||
foreach my $method ( qw(code message status is_success) ) {
|
||||
*{ $method } = *{ "get_$method" };
|
||||
}
|
||||
}
|
||||
|
||||
sub send_receive {
|
||||
my ($self, %parameters) = @_;
|
||||
my ($envelope, $soap_action, $endpoint, $encoding, $content_type) =
|
||||
@parameters{qw(envelope action endpoint encoding content_type)};
|
||||
|
||||
my $filename = $soap_action;
|
||||
$filename =~s{ \A(:?'|") }{}xms;
|
||||
$filename =~s{ (:?'|")\z }{}xms;
|
||||
$filename =~s{ \A [^:]+ : (:? /{2})? }{}xms;
|
||||
|
||||
$filename = join '/', $base_dir_of{ ident $self }, "$filename.xml";
|
||||
|
||||
if (not -r $filename) {
|
||||
warn "cannot access $filename";
|
||||
$self->set_code( 500 );
|
||||
$self->set_message( "Failed" );
|
||||
$self->set_is_success(0);
|
||||
$self->set_status("500 Failed");
|
||||
return;
|
||||
}
|
||||
|
||||
open my $fh, '<', $filename or die "cannot open $filename: $!";
|
||||
binmode $fh;
|
||||
my $response = <$fh>;
|
||||
close $fh or die "cannot close $filename: $!";
|
||||
|
||||
$self->set_code( 200 );
|
||||
$self->set_message( "OK" );
|
||||
$self->set_is_success(1);
|
||||
$self->set_status("200 OK");
|
||||
return $response;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Transport::Test - Test transport class for SOAP::WSDL
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SOAP::WSDL::Client;
|
||||
use SOAP::WSDL::Transport::Test;
|
||||
|
||||
my $soap = SOAP::WSDL::Client->new()
|
||||
$soap->get_transport->set_base_dir('.');
|
||||
$soap->call('method', \%body, \%header);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SOAP::WSDL::Transport::Test is a file-based test transport backend for
|
||||
SOAP::WSDL.
|
||||
|
||||
When SOAP::WSDL::Transport::Test is used as transport backend, the reponse is
|
||||
read from a XML file and the request message is discarded. This is particularly
|
||||
useful for testing SOAP::WSDL plugins.
|
||||
|
||||
=head2 Filename resolution
|
||||
|
||||
SOAP::WSDL::Transport makes up the response XML file name from the SOAPAction
|
||||
of the request. The following filename is used:
|
||||
|
||||
base_dir / soap_action .xml
|
||||
|
||||
The protocol scheme (e.g. http:) and two heading slashes (//) are stripped from
|
||||
the soap_action.
|
||||
|
||||
base_dir defaults to '.'
|
||||
|
||||
Examples:
|
||||
|
||||
SOAPAction: http://somewhere.over.the.rainbow/webservice/webservice.asmx
|
||||
Filename: ./somewhere.over.the.rainbow/webservice/webservice.asmx.xml
|
||||
|
||||
SOAPAction: uri:MyWickedService/test
|
||||
Filename: ./MyWickedService/test.xml
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 set_base_dir
|
||||
|
||||
Sets the base directory SOAP::WSDL::Transport::Test should look for response
|
||||
files.
|
||||
|
||||
=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>
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 218 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: HTTP.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/Transport/HTTP.pm $
|
||||
|
||||
=cut
|
||||
180
lib/SOAP/WSDL/TypeLookup.pm
Normal file
180
lib/SOAP/WSDL/TypeLookup.pm
Normal file
@@ -0,0 +1,180 @@
|
||||
package SOAP::WSDL::TypeLookup;
|
||||
|
||||
my %TYPES = (
|
||||
# wsdl:
|
||||
'http://schemas.xmlsoap.org/wsdl/' => {
|
||||
binding => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Binding',
|
||||
},
|
||||
definitions => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Definitions',
|
||||
},
|
||||
portType => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::PortType',
|
||||
},
|
||||
message => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Message',
|
||||
},
|
||||
part => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Part',
|
||||
},
|
||||
service => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Service',
|
||||
},
|
||||
port => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Port',
|
||||
},
|
||||
operation => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Operation',
|
||||
},
|
||||
input => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::OpMessage',
|
||||
},
|
||||
output => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::OpMessage',
|
||||
},
|
||||
fault => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::OpMessage',
|
||||
},
|
||||
types => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::Types',
|
||||
},
|
||||
documentation => {
|
||||
type => 'CONTENT',
|
||||
method => 'set_documentation',
|
||||
}
|
||||
},
|
||||
# soap:
|
||||
'http://schemas.xmlsoap.org/wsdl/soap/' => {
|
||||
operation => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::SOAP::Operation',
|
||||
},
|
||||
binding => {
|
||||
type => 'PARENT',
|
||||
},
|
||||
body => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::SOAP::Body',
|
||||
},
|
||||
header => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::SOAP::Header',
|
||||
},
|
||||
address => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::SOAP::Address',
|
||||
}
|
||||
},
|
||||
'http://www.w3.org/2001/XMLSchema' => {
|
||||
schema => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::XSD::Schema',
|
||||
},
|
||||
attribute => {
|
||||
type => 'SKIP' # not implemented yet
|
||||
},
|
||||
attributeGroup => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
key => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
keyref => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
unique => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
notation => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
annotation => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
appinfo => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
description => {
|
||||
type => 'SKIP', # not implemented yet
|
||||
},
|
||||
element => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::XSD::Element',
|
||||
},
|
||||
simpleType => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::XSD::SimpleType',
|
||||
},
|
||||
complexType => {
|
||||
type => 'CLASS',
|
||||
class => 'SOAP::WSDL::XSD::ComplexType',
|
||||
},
|
||||
simpleContent => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'simpleContent'
|
||||
},
|
||||
complexContent => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'complexContent'
|
||||
},
|
||||
restriction => {
|
||||
type => 'METHOD',
|
||||
method => 'set_restriction',
|
||||
},
|
||||
list => {
|
||||
type => 'METHOD',
|
||||
method => 'set_list',
|
||||
},
|
||||
union => {
|
||||
type => 'METHOD',
|
||||
method => 'set_union',
|
||||
},
|
||||
enumeration => {
|
||||
type => 'SKIP',
|
||||
# method => 'push_enumeration',
|
||||
},
|
||||
group => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'group',
|
||||
},
|
||||
all => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'all',
|
||||
},
|
||||
choice => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'choice',
|
||||
},
|
||||
sequence => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'sequence',
|
||||
},
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
sub lookup {
|
||||
my $self = shift;
|
||||
my $namespace = shift || 'http://schemas.xmlsoap.org/wsdl/';
|
||||
my $name = shift;
|
||||
return $TYPES{ $namespace }->{ $name };
|
||||
}
|
||||
37
lib/SOAP/WSDL/Types.pm
Normal file
37
lib/SOAP/WSDL/Types.pm
Normal file
@@ -0,0 +1,37 @@
|
||||
package SOAP::WSDL::Types;
|
||||
use strict;
|
||||
use warnings;
|
||||
use SOAP::WSDL::XSD::Schema::Builtin;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
|
||||
my %schema_of :ATTR(:name<schema> :default<[]>);
|
||||
|
||||
sub START {
|
||||
my ($self, $ident, $args_of) = @_;
|
||||
$self->push_schema( SOAP::WSDL::XSD::Schema::Builtin->new() );
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub find_type {
|
||||
my ($self, $ns, $name) = @_;
|
||||
($ns, $name) = @{ $ns } if ref $ns; # allow passing list refs
|
||||
foreach my $schema (@{ $schema_of{ ident $self } }) {
|
||||
my $type = $schema->find_type($ns, $name);
|
||||
return $type if $type;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub find_element {
|
||||
my ($self, $ns, $name) = @_;
|
||||
($ns, $name) = @{ $ns } if ref $ns; # allow passing list refs
|
||||
foreach my $schema (@{ $schema_of{ ident $self } }) {
|
||||
my $type = $schema->find_element($ns, $name);
|
||||
return $type if $type;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
36
lib/SOAP/WSDL/XSD/Builtin.pm
Normal file
36
lib/SOAP/WSDL/XSD/Builtin.pm
Normal file
@@ -0,0 +1,36 @@
|
||||
package SOAP::WSDL::XSD::Builtin;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
use Data::Dumper;
|
||||
|
||||
sub serialize {
|
||||
my ($self, $name, $value, $opt) = @_;
|
||||
my $xml;
|
||||
$opt->{ indent } ||= "";
|
||||
$opt->{ attributes } ||= [];
|
||||
|
||||
$xml .= $opt->{ indent } if ($opt->{ readable });
|
||||
$xml .= '<' . join ' ', $name, @{ $opt->{ attributes } };
|
||||
if ( $opt->{ autotype }) {
|
||||
my $ns = $self->get_targetNamespace();
|
||||
my $prefix = $opt->{ namespace }->{ $ns }
|
||||
|| die 'No prefix found for namespace '. $ns;
|
||||
$xml .= ' type="' . $prefix . ':'
|
||||
. $self->get_name() . '"' if ($self->get_name() );
|
||||
}
|
||||
|
||||
if (defined $value) {
|
||||
$xml .= '>';
|
||||
$xml .= "$value";
|
||||
$xml .= '</' . $name . '>' ;
|
||||
}
|
||||
else {
|
||||
$xml .= '/>';
|
||||
}
|
||||
$xml .= "\n" if ($opt->{ readable });
|
||||
return $xml;
|
||||
}
|
||||
|
||||
1;
|
||||
131
lib/SOAP/WSDL/XSD/ComplexType.pm
Normal file
131
lib/SOAP/WSDL/XSD/ComplexType.pm
Normal file
@@ -0,0 +1,131 @@
|
||||
package SOAP::WSDL::XSD::ComplexType;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use Class::Std::Storable;
|
||||
use Scalar::Util qw(blessed);
|
||||
use base qw/SOAP::WSDL::Base/;
|
||||
use Data::Dumper;
|
||||
|
||||
my %annotation_of :ATTR(:name<annotation> :default<()>);
|
||||
my %element_of :ATTR(:name<element> :default<()>);
|
||||
my %flavor_of :ATTR(:name<flavor> :default<()>);
|
||||
my %base_of :ATTR(:name<base> :default<()>);
|
||||
my %itemType_of :ATTR(:name<itemType> :default<()>);
|
||||
my %enumeration_of :ATTR(:name<enumeration> :default<()>);
|
||||
my %abstract_of :ATTR(:name<abstract> :default<()>);
|
||||
my %mixed_of :ATTR(:name<mixed> :default<()>); # default is false
|
||||
|
||||
# is set to simpleContent/complexContent
|
||||
my %content_Model_of :ATTR(:name<contentModel> :default<()>);
|
||||
|
||||
sub get_variety; *get_variety = \&get_flavor;
|
||||
|
||||
sub find_element {
|
||||
my ($self, @args) = @_;
|
||||
my @found_at = grep {
|
||||
$_->get_targetNamespace() eq $args[0] &&
|
||||
$_->get_name() eq $args[1]
|
||||
}
|
||||
@{ $element_of{ ident $self } };
|
||||
return $found_at[0];
|
||||
}
|
||||
|
||||
sub push_element {
|
||||
my $self = shift;
|
||||
my $element = shift;
|
||||
if ($flavor_of{ ident $self } eq 'all')
|
||||
{
|
||||
$element->set_minOccurs(0) if not defined ($element->get_minOccurs);
|
||||
$element->set_maxOccurs(1) if not defined ($element->get_maxOccurs);
|
||||
}
|
||||
elsif ($flavor_of{ ident $self } eq 'sequence')
|
||||
{
|
||||
$element->set_minOccurs(1) if not defined ($element->get_minOccurs);
|
||||
$element->set_maxOccurs(1) if not defined ($element->get_maxOccurs);
|
||||
}
|
||||
push @{ $element_of{ ident $self } }, $element;
|
||||
}
|
||||
|
||||
sub set_restriction {
|
||||
my $self = shift;
|
||||
my $element = shift;
|
||||
$flavor_of{ ident $self } = 'restriction';
|
||||
$base_of{ ident $self } = $element->{ Value };
|
||||
}
|
||||
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
$self->SUPER::init( @args );
|
||||
}
|
||||
|
||||
sub serialize {
|
||||
my ($self, $name, $value, $opt) = @_;
|
||||
|
||||
$opt->{ indent } ||= q{};
|
||||
$opt->{ attributes } ||= [];
|
||||
my $flavor = $self->get_flavor();
|
||||
my $xml = ($opt->{ readable }) ? $opt->{ indent } : q{}; # add indentation
|
||||
|
||||
|
||||
if ( $opt->{ qualify } ) {
|
||||
$opt->{ attributes } = [ ' xmlns="' . $self->get_targetNamespace .'"' ];
|
||||
delete $opt->{ qualify };
|
||||
}
|
||||
|
||||
|
||||
$xml .= join q{ } , "<$name" , @{ $opt->{ attributes } };
|
||||
delete $opt->{ attributes }; # don't propagate...
|
||||
|
||||
if ( $opt->{ autotype }) {
|
||||
my $ns = $self->get_targetNamespace();
|
||||
my $prefix = $opt->{ namespace }->{ $ns }
|
||||
|| die 'No prefix found for namespace '. $ns;
|
||||
$xml .= join q{}, " type=\"$prefix:", $self->get_name(), '" '
|
||||
if ($self->get_name() );
|
||||
}
|
||||
$xml .= '>';
|
||||
$xml .= "\n" if ( $opt->{ readable } ); # add linebreak
|
||||
if ( ($flavor eq "sequence") or ($flavor eq "all") )
|
||||
{
|
||||
$opt->{ indent } .= "\t";
|
||||
for my $element (@{ $self->get_element() }) {
|
||||
# might be list - listify
|
||||
$value = [ $value ] if not ref $value eq 'ARRAY';
|
||||
|
||||
for my $single_value (@{ $value }) {
|
||||
my $element_value;
|
||||
if (blessed $single_value) {
|
||||
my $method = 'get_' . $element->get_name();
|
||||
$element_value = $single_value->$method();
|
||||
}
|
||||
else {
|
||||
$element_value = $single_value->{ $element->get_name() };
|
||||
}
|
||||
$element_value = [ $element_value ]
|
||||
if not ref $element_value eq 'ARRAY';
|
||||
|
||||
$xml .= join q{}
|
||||
, map { $element->serialize( undef, $_, $opt ) }
|
||||
@{ $element_value };
|
||||
}
|
||||
}
|
||||
$opt->{ indent } =~s/\t$//;
|
||||
}
|
||||
else {
|
||||
die "sorry, we just handle all and sequence types yet...";
|
||||
}
|
||||
$xml .= $opt->{ indent } if ( $opt->{ readable } ); # add indentation
|
||||
$xml .= '</' . $name . '>';
|
||||
$xml .= "\n" if ($opt->{ readable } ); # add linebreak
|
||||
return $xml;
|
||||
}
|
||||
|
||||
|
||||
sub _check_value {
|
||||
my $self = shift;
|
||||
}
|
||||
1;
|
||||
|
||||
114
lib/SOAP/WSDL/XSD/Element.pm
Normal file
114
lib/SOAP/WSDL/XSD/Element.pm
Normal file
@@ -0,0 +1,114 @@
|
||||
package SOAP::WSDL::XSD::Element;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
use Data::Dumper;
|
||||
|
||||
my %annotation_of :ATTR(:name<annotation> :default<()>);
|
||||
my %simpleType_of :ATTR(:name<simpleType> :default<()>);
|
||||
my %complexType_of :ATTR(:name<complexType> :default<()>);
|
||||
my %facet_of :ATTR(:name<facet> :default<()>);
|
||||
my %type_of :ATTR(:name<type> :default<()>);
|
||||
my %abstract_of :ATTR(:name<abstract> :default<()>);
|
||||
my %block_of :ATTR(:name<block> :default<()>);
|
||||
my %default_of :ATTR(:name<default> :default<()>);
|
||||
my %final_of :ATTR(:name<final> :default<()>);
|
||||
my %fixed_of :ATTR(:name<fixed> :default<()>);
|
||||
my %form_of :ATTR(:name<form> :default<()>);
|
||||
my %maxOccurs_of :ATTR(:name<maxOccurs> :default<()>);
|
||||
my %minOccurs_of :ATTR(:name<minOccurs> :default<()>);
|
||||
my %nillable_of :ATTR(:name<nillable> :default<()>);
|
||||
my %ref_of :ATTR(:name<ref> :default<()>);
|
||||
my %substitutionGroup_of :ATTR(:name<substitutionGroup> :default<()>);
|
||||
|
||||
sub first_type {
|
||||
my $result_ref = $complexType_of{ ident shift };
|
||||
return if not $result_ref;
|
||||
return $result_ref if (not ref $result_ref eq 'ARRAY');
|
||||
return $result_ref->[0];
|
||||
}
|
||||
|
||||
sub first_simpleType {
|
||||
my $result_ref = $simpleType_of{ ident shift };
|
||||
return if not $result_ref;
|
||||
return $result_ref if (not ref $result_ref eq 'ARRAY');
|
||||
return $result_ref->[0];
|
||||
}
|
||||
|
||||
sub first_complexType {
|
||||
my $result_ref = $complexType_of{ ident shift };
|
||||
return if not $result_ref;
|
||||
return $result_ref if (not ref $result_ref eq 'ARRAY');
|
||||
return $result_ref->[0];
|
||||
}
|
||||
|
||||
# serialize type instead...
|
||||
sub serialize {
|
||||
my ($self, $name, $value, $opt) = @_;
|
||||
my $type;
|
||||
my $typelib = $opt->{ typelib };
|
||||
my %ns_map = reverse %{ $opt->{ namespace } };
|
||||
my $ident = ident $self;
|
||||
|
||||
# abstract elements may only be serialized via ref - and then we have a
|
||||
# name...
|
||||
die "cannot serialize abstract element" if $abstract_of{ $ident }
|
||||
and not $name;
|
||||
|
||||
# TODO: implement final and substitutionGroup - maybe never implement
|
||||
# substitutionGroup ?
|
||||
|
||||
$name ||= $self->get_name();
|
||||
|
||||
if ( $opt->{ qualify } ) {
|
||||
$opt->{ attributes } = [ ' xmlns="' . $self->get_targetNamespace .'"' ];
|
||||
}
|
||||
|
||||
|
||||
# set default and fixed - fixed overrides everything,
|
||||
# default only empty (undefined) values
|
||||
if (not defined $value) {
|
||||
$value = $default_of{ ident $self } if $default_of{ ident $self };
|
||||
}
|
||||
$value = $fixed_of{ ident $self } if $fixed_of{ ident $self };
|
||||
|
||||
# TODO check nillable and serialize empty data correctly
|
||||
|
||||
# return if minOccurs is 0 and we have no value
|
||||
if (defined $minOccurs_of{ ident $self }
|
||||
and $minOccurs_of{ ident $self } == 0) {
|
||||
return q{} if not defined $value;
|
||||
}
|
||||
|
||||
# handle direct simpleType and complexType here
|
||||
if ($type = $self->first_simpleType() ) { # simpleType
|
||||
return $type->serialize( $name, $value, $opt );
|
||||
}
|
||||
elsif ($type = $self->first_complexType() ) { # complexType
|
||||
return $type->serialize( $name, $value, $opt );
|
||||
}
|
||||
elsif (my $ref_name = $ref_of{ $ident }) { # ref
|
||||
my ($prefix, $localname) = split /:/ , $ref_name;
|
||||
my $ns = $ns_map{ $prefix };
|
||||
$type = $typelib->find_element( $ns, $localname );
|
||||
die "no element for ref $prefix:$localname" if (not $type);
|
||||
return $type->serialize( $name, $value, $opt );
|
||||
}
|
||||
|
||||
# lookup type
|
||||
my ($prefix, $localname) = split /:/ , $self->get_type();
|
||||
my $ns = $ns_map{ $prefix };
|
||||
$type = $typelib->find_type(
|
||||
$ns, $localname
|
||||
);
|
||||
|
||||
# safety check
|
||||
die "no type for $prefix:$localname $ns_map{$prefix}" if (not $type);
|
||||
|
||||
return $type->serialize( $name, $value, $opt );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
73
lib/SOAP/WSDL/XSD/Schema.pm
Normal file
73
lib/SOAP/WSDL/XSD/Schema.pm
Normal file
@@ -0,0 +1,73 @@
|
||||
package SOAP::WSDL::XSD::Schema;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
# child elements
|
||||
my %type_of :ATTR(:name<type> :default<[]>);
|
||||
my %element_of :ATTR(:name<element> :default<[]>);
|
||||
my %group_of :ATTR(:name<group> :default<[]>);
|
||||
|
||||
# attributes
|
||||
my %attributeFormDefault_of :ATTR(:name<attributeFormDefault> :default<()>);
|
||||
my %blockDefault_of :ATTR(:name<blockDefault> :default<()>);
|
||||
my %elementFormDefault_of :ATTR(:name<elementFormDefault> :default<()>);
|
||||
my %finalDefault_of :ATTR(:name<finalDefault> :default<()>);
|
||||
my %version_of :ATTR(:name<version> :default<()>);
|
||||
|
||||
# id
|
||||
# name
|
||||
# targetNamespace inherited from Base
|
||||
# xmlns
|
||||
|
||||
#
|
||||
# attributeFormDefault = (qualified | unqualified) : unqualified
|
||||
# blockDefault = (#all | List of (extension | restriction | substitution)) : ''
|
||||
# elementFormDefault = (qualified | unqualified) : unqualified
|
||||
# finalDefault = (#all | List of (extension | restriction | list | union)) : ''
|
||||
# id = ID
|
||||
# targetNamespace = anyURI
|
||||
# version = token
|
||||
# xml:lang = language
|
||||
#
|
||||
#
|
||||
# alias type with all variants
|
||||
# AUTOMETHOD is WAY too slow..
|
||||
{
|
||||
no strict qw/refs/;
|
||||
for my $name (qw(simpleType complexType) ) {
|
||||
*{ "set_$name" } = \&set_type;
|
||||
*{ "get_$name" } = \&get_type;
|
||||
*{ "push_$name" } = \&push_type;
|
||||
*{ "find_$name" } = \&find_type;
|
||||
}
|
||||
}
|
||||
|
||||
sub push_type {
|
||||
# use $_[n] for performance -
|
||||
# we're called on each and every type inside WSDL
|
||||
push @{ $type_of{ ident $_[0]} }, $_[1];
|
||||
}
|
||||
|
||||
sub find_element {
|
||||
my ($self, @args) = @_;
|
||||
my @found_at = grep {
|
||||
$_->get_targetNamespace() eq $args[0] &&
|
||||
$_->get_name() eq $args[1]
|
||||
}
|
||||
@{ $element_of{ ident $self } };
|
||||
return $found_at[0];
|
||||
}
|
||||
|
||||
sub find_type {
|
||||
my ($self, @args) = @_;
|
||||
my @found_at = grep {
|
||||
$_->get_targetNamespace() eq $args[0] &&
|
||||
$_->get_name() eq $args[1]
|
||||
}
|
||||
@{ $type_of{ ident $self } };
|
||||
return $found_at[0];
|
||||
}
|
||||
|
||||
1;
|
||||
62
lib/SOAP/WSDL/XSD/Schema/Builtin.pm
Normal file
62
lib/SOAP/WSDL/XSD/Schema/Builtin.pm
Normal file
@@ -0,0 +1,62 @@
|
||||
package SOAP::WSDL::XSD::Schema::Builtin;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::XSD::Schema;
|
||||
use SOAP::WSDL::XSD::Builtin;
|
||||
use base qw(SOAP::WSDL::XSD::Schema);
|
||||
|
||||
# all builtin types - add validation (e.g. content restrictions) later...
|
||||
my %BUILTINS = (
|
||||
'string' => {},
|
||||
'boolean' => {},
|
||||
'decimal' => {},
|
||||
'dateTime' => {},
|
||||
'float' => {},
|
||||
'double' => {},
|
||||
'duration' => {},
|
||||
'time' => {},
|
||||
'date' => {},
|
||||
'gYearMonth' => {},
|
||||
'gYear' => {},
|
||||
'gMonthDay' => {},
|
||||
'gDay' => {},
|
||||
'gMonth' => {},
|
||||
'hexBinary' => {},
|
||||
'base64Binary' => {},
|
||||
'anyURI' => {},
|
||||
'QName' => {},
|
||||
'NOTATION' => {},
|
||||
'integer' => {},
|
||||
'nonPositiveInteger' => {},
|
||||
'nonNegativeInteger' => {},
|
||||
'positiveInteger' => {},
|
||||
'negativeInteger' => {},
|
||||
'long' => {},
|
||||
'int' => {},
|
||||
'unsignedInt' => {},
|
||||
'short' => {},
|
||||
'unsignedShort' => {},
|
||||
'byte' => {},
|
||||
'unsignedByte' => {},
|
||||
'normalizedString' => {},
|
||||
'token' => {},
|
||||
'NMTOKEN' => {},
|
||||
);
|
||||
|
||||
sub START {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
|
||||
while (my ($name, $value) = each %BUILTINS )
|
||||
{
|
||||
$self->push_type( SOAP::WSDL::XSD::Builtin->new({
|
||||
name => $name,
|
||||
targetNamespace => 'http://www.w3.org/2001/XMLSchema',
|
||||
} )
|
||||
);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
117
lib/SOAP/WSDL/XSD/SimpleType.pm
Normal file
117
lib/SOAP/WSDL/XSD/SimpleType.pm
Normal file
@@ -0,0 +1,117 @@
|
||||
package SOAP::WSDL::XSD::SimpleType;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %annotation_of :ATTR(:name<annotation> :default<()>);
|
||||
my %base_of :ATTR(:name<base> :default<()>);
|
||||
my %itemType_of :ATTR(:name<itemType> :default<()>);
|
||||
my %enumeration_of :ATTR(:name<enumeration> :default<()>);
|
||||
# is set to simpleContent/complexContent
|
||||
# my %content_model_of :ATTR(:name<contentModel> :default<()>);
|
||||
|
||||
# TODO rename flavor to content_model to be consistent with the XML Schema
|
||||
# specs - though flavor is the cooler name..
|
||||
# set to restriction|list|union|enumeration
|
||||
my %flavor_of :ATTR(:name<flavor> :default<()>);
|
||||
|
||||
# for simpleType containing atomic simple types
|
||||
my %type_of :ATTR(:name<type> :default<()>);
|
||||
|
||||
sub get_simpleType; *get_simpleType = \&get_type;
|
||||
sub set_simpleType; *set_simpleType = \&set_type;
|
||||
|
||||
sub get_variety; *get_variety = \&get_flavor;
|
||||
|
||||
sub set_restriction {
|
||||
my $self = shift;
|
||||
my @attributes = @_;
|
||||
$self->set_flavor( 'restriction' );
|
||||
for (@attributes) {
|
||||
next if (not $_->{ LocalName } eq 'base');
|
||||
$self->set_base( $_->{ Value } );
|
||||
}
|
||||
}
|
||||
|
||||
sub set_list {
|
||||
my $self = shift;
|
||||
my @attributes = @_;
|
||||
$self->set_flavor( 'list' );
|
||||
for (@attributes) {
|
||||
next if (not $_->{ LocalName } eq 'itemType');
|
||||
$self->set_itemType( $_->{ Value } );
|
||||
}
|
||||
}
|
||||
|
||||
sub set_union {
|
||||
my $self = shift;
|
||||
my @attributes = @_;
|
||||
$self->set_flavor( 'union' );
|
||||
for (@attributes) {
|
||||
next if (not $_->{ LocalName } eq 'memberTypes');
|
||||
$self->set_base( [ split /\s/, $_->{ Value } ] );
|
||||
}
|
||||
}
|
||||
|
||||
sub push_enumeration {
|
||||
my $self = shift;
|
||||
my @attr = @_;
|
||||
my @attributes = @_;
|
||||
$self->set_flavor( 'enumeration' );
|
||||
for (@attributes) {
|
||||
next if (not $_->{ LocalName } eq 'value');
|
||||
push @{ $enumeration_of{ ident $self } }, $_->{ 'Value' };
|
||||
}
|
||||
}
|
||||
|
||||
sub serialize {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $value = shift;
|
||||
my $opt = shift;
|
||||
my $ident = ident $self;
|
||||
|
||||
$opt->{ attributes } ||= [];
|
||||
$opt->{ indent } ||= q{};
|
||||
|
||||
$self->_check_value( $value );
|
||||
|
||||
return $self->_serialize_single($name, $value , $opt)
|
||||
if ( $flavor_of{ $ident } eq 'restriction'
|
||||
or $flavor_of{ $ident } eq 'union'
|
||||
or $flavor_of{ $ident } eq 'enumeration');
|
||||
|
||||
if ($flavor_of{ $ident } eq 'list' )
|
||||
{
|
||||
$value ||= [];
|
||||
$value = [ $value ] if ( ref( $value) ne 'ARRAY' );
|
||||
return $self->_serialize_single($name, join( q{ }, @{ $value } ), $opt);
|
||||
}
|
||||
}
|
||||
|
||||
sub _serialize_single {
|
||||
my ($self, $name, $value, $opt) = @_;
|
||||
my $xml = '';
|
||||
$xml .= $opt->{ indent } if ($opt->{ readable }); # add indentation
|
||||
$xml .= '<' . join ' ', $name, @{ $opt->{ attributes } };
|
||||
if ( $opt->{ autotype }) {
|
||||
my $ns = $self->get_targetNamespace();
|
||||
my $prefix = $opt->{ namespace }->{ $ns }
|
||||
|| die 'No prefix found for namespace '. $ns;
|
||||
$xml .= ' type="' . $prefix . ':' . $self->get_name() .'"';
|
||||
}
|
||||
|
||||
# nillabel ?
|
||||
return $xml .'/>' if not defined $value;
|
||||
|
||||
$xml .= join q{}, '>' , $value , '</' , $name , '>';
|
||||
$xml .= "\n" if ($opt->{ readable });
|
||||
return $xml;
|
||||
}
|
||||
|
||||
sub _check_value {
|
||||
my $self = shift;
|
||||
}
|
||||
|
||||
1;
|
||||
369
lib/SOAP/WSDL/XSD/Typelib/Builtin.pm
Normal file
369
lib/SOAP/WSDL/XSD/Typelib/Builtin.pm
Normal file
@@ -0,0 +1,369 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::anyType;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::anyURI;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::base64Binary;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::boolean;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::byte;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::date;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::dateTime;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::decimal;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::double;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::duration;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::ENTITY;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::float;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::gDay;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::gMonth;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::gMonthDay;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::gYear;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::gYearMonth;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::hexBinary;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::ID;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::IDREF;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::IDREFS;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::int;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::integer;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::language;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::list;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::long;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::Name;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::NCName;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::negativeInteger;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::nonNegativeInteger;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::nonPositiveInteger;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::normalizedString;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::NOTATION;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::positiveInteger;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::QName;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::short;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::string;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::time;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::token;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::unsignedByte;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::unsignedInt;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::unsignedLong;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::unsignedShort;
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::Builtin - Built-in XML Schema datatypes
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module implements all builtin Types from the XML schema specification.
|
||||
|
||||
Objects of a class may be filled with values and serialize correctly.
|
||||
|
||||
These basic type classes are most useful when used as element or simpleType
|
||||
base classes.
|
||||
|
||||
The datatypes classes themselves are split up into
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::* modules.
|
||||
|
||||
Using SOAP::WSDL::XSD::Typelib::Builtin uses all of the builtin datatype
|
||||
classes.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
my $bool = SOAP::WSDL::XSD::Typelib::Builtin::bool->new({ value => 0} );
|
||||
print $bool; # prints "true"
|
||||
|
||||
# implements <simpleType name="MySimpleType">
|
||||
# <list itemType="xsd:string" />
|
||||
# </simpleType>
|
||||
package MySimpleType;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use SOAP::WSDL::XSD::Typelib::SimpleType;
|
||||
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::SimpleType
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::list
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::string
|
||||
);
|
||||
1;
|
||||
|
||||
# somewhere else
|
||||
my $list = MySimpleType->new({ value => [ 'You', 'shall', 'overcome' ] });
|
||||
print $list; # prints "You shall overcome"
|
||||
|
||||
=head1 CLASS HIERARCHY
|
||||
|
||||
This is the inheritance graph for builtin types.
|
||||
|
||||
Types with [] marker describe types derived via the item in [] in the XML
|
||||
Schema specs.
|
||||
|
||||
Derivation is implemented via multiple inheritance with the derivation method
|
||||
as first item in the base class list.
|
||||
|
||||
anyType
|
||||
- anySimpleType
|
||||
- duration
|
||||
- dateTime
|
||||
- date
|
||||
- time
|
||||
- gYearMonth
|
||||
- gYear
|
||||
- gMonthDay
|
||||
- gDay
|
||||
- gMonth
|
||||
- boolean
|
||||
- base64Binary
|
||||
- hexBinary
|
||||
- float
|
||||
- decimal
|
||||
- integer
|
||||
- nonPositiveInteger
|
||||
- negativeInteger
|
||||
- nonNegativeInteger
|
||||
- positiveInteger
|
||||
- unsignedLong
|
||||
- unsignedInt
|
||||
- unsignedShort
|
||||
- unsignedByte
|
||||
- long
|
||||
- int
|
||||
- short
|
||||
- byte
|
||||
- double
|
||||
- anyURI
|
||||
- string
|
||||
- normalizedString
|
||||
- language
|
||||
- Name
|
||||
- NCName
|
||||
- ID
|
||||
- IDREF
|
||||
- IDREFS [list]
|
||||
- ENTITY
|
||||
- NMTOKEN
|
||||
- NMTOKENS [list]
|
||||
|
||||
=head1 OVERLOADED OPERATORS
|
||||
|
||||
Overloading is implemented via Class::Std's trait mechanism.
|
||||
|
||||
The following behaviours apply:
|
||||
|
||||
=over
|
||||
|
||||
=item * string context
|
||||
|
||||
All classes use the C<serialize> method for stringification.
|
||||
|
||||
=item * bool context
|
||||
|
||||
All classes derived from anySimpleType return their value in bool context
|
||||
|
||||
=item * numeric context
|
||||
|
||||
The boolean class returns 0 or 1 in numeric context.
|
||||
|
||||
decimal, float and double (and derived classes) return their value in
|
||||
numeric context.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Subclasses
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::anyType
|
||||
|
||||
Base class for all types
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType
|
||||
|
||||
Base class for all simple types
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::anyURI
|
||||
|
||||
Type representing URIs
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::boolean
|
||||
|
||||
Represents boolean data.
|
||||
|
||||
Serializes to "true" or "false".
|
||||
|
||||
Everything true in perl and not "false" is deserialized as true.
|
||||
|
||||
Returns true/false in boolean context.
|
||||
|
||||
Returns 1 / 0 in numeric context.
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::byte
|
||||
|
||||
byte integer objects.
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::date
|
||||
|
||||
date values are automatically converted into XML date strings during setting:
|
||||
|
||||
YYYY-MM-DD+zz:zz
|
||||
|
||||
The time zone is set to the local time zone if not included.
|
||||
|
||||
All input variants supported by Date::Parse are supported. You may even pass
|
||||
in dateTime strings - the time part will be ignored. Note that
|
||||
set_value is around 100 times slower when setting non-XML-time strings
|
||||
|
||||
When setting dates before the beginning of the epoch (negative UNIX timestamp),
|
||||
you should use the XML date string format for setting dates. The behaviour of
|
||||
Date::Parse for dates before the epoch is system dependent.
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::dateTime
|
||||
|
||||
dateTime values are automatically converted into XML dateTime strings during setting:
|
||||
|
||||
YYYY-MM-DDThh:mm:ss.nnnnnnn+zz:zz
|
||||
|
||||
The fraction of seconds (nnnnnnn) part is optional. Fractions of seconds may
|
||||
be given with arbitrary precision
|
||||
|
||||
The fraction of seconds part is excluded in converted values, as it would always be 0.
|
||||
|
||||
All input variants supported by Date::Parse are supported. Note that
|
||||
set_value is around 100 times slower when setting non-XML-time strings
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::decimal
|
||||
|
||||
decimal is the base of all non-float numbers
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::double
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::duration
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::ENTITY
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::float
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::gDay
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::gMonth
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::gMonthDay
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::gYear
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::gYearMonth
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::hexBinary
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::ID
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::IDREF
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::IDREFS
|
||||
|
||||
List of SOAP::WSDL::XSD::Typelib::Builtin::IDREF objects.
|
||||
|
||||
Derived by SOAP::WSDL::XSD::Typelib::Builtin::list.
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::int
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::integer
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::language
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::list
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::long
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::Name
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::NCName
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::negativeInteger
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::nonNegativeInteger
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::nonPositiveInteger
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::normalizedString
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::NOTATION
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::positiveInteger
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::QName
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::short
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::string
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::time
|
||||
|
||||
time values are automatically converted into XML time strings during setting:
|
||||
|
||||
hh:mm:ss.nnnnnnn+zz:zz
|
||||
hh:mm:ss+zz:zz
|
||||
|
||||
The time zone is set to the local time zone if not included. The optional
|
||||
nanoseconds part is not included in converted values, as it would always be 0.
|
||||
|
||||
All input variants supported by Date::Parse are supported. You may even pass
|
||||
in dateTime strings - the date part will be ignored. Note that
|
||||
set_value is around 100 times slower when setting non-XML-time strings
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::token
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::unsignedByte
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::unsignedInt
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::unsignedLong
|
||||
|
||||
=head2 SOAP::WSDL::XSD::Typelib::Builtin::unsignedShort
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
=over
|
||||
|
||||
=item * set_value
|
||||
|
||||
In contrast to Class::Std-generated mutators (setters), set_value does
|
||||
not return the last value.
|
||||
|
||||
This is for speed reasons: SOAP::WSDL never needs to know the last value
|
||||
when calling set_calue, but calls it over and over again...
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
=over
|
||||
|
||||
=item * Thread safety
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::Builtin uses Class::Std::Storable which uses
|
||||
Class::Std. Class::Std is not thread safe, so
|
||||
SOAP::WSDL::XSD::Typelib::Builtin is neither.
|
||||
|
||||
=item * XML Schema facets
|
||||
|
||||
No facets are implemented yet.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace whitespace by @ in e-mail address.
|
||||
|
||||
Martin Kutter E<gt>martin.kutter fen-net.deE<lt>
|
||||
|
||||
=head1 Licenxe
|
||||
|
||||
Copyright 2004-2007 Martin Kutter.
|
||||
|
||||
This library is free software, you may distribute/modify it under the
|
||||
same terms as perl itself
|
||||
|
||||
=cut
|
||||
25
lib/SOAP/WSDL/XSD/Typelib/Builtin/ENTITY.pm
Normal file
25
lib/SOAP/WSDL/XSD/Typelib/Builtin/ENTITY.pm
Normal file
@@ -0,0 +1,25 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::ENTITY;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::NCName);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
};
|
||||
|
||||
1;
|
||||
7
lib/SOAP/WSDL/XSD/Typelib/Builtin/ID.pm
Normal file
7
lib/SOAP/WSDL/XSD/Typelib/Builtin/ID.pm
Normal file
@@ -0,0 +1,7 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::ID;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::NCName);
|
||||
|
||||
1;
|
||||
7
lib/SOAP/WSDL/XSD/Typelib/Builtin/IDREF.pm
Normal file
7
lib/SOAP/WSDL/XSD/Typelib/Builtin/IDREF.pm
Normal file
@@ -0,0 +1,7 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::IDREF;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::ID);
|
||||
|
||||
1;
|
||||
9
lib/SOAP/WSDL/XSD/Typelib/Builtin/IDREFS.pm
Normal file
9
lib/SOAP/WSDL/XSD/Typelib/Builtin/IDREFS.pm
Normal file
@@ -0,0 +1,9 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::IDREFS;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::list
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::IDREF);
|
||||
|
||||
1;
|
||||
25
lib/SOAP/WSDL/XSD/Typelib/Builtin/NCName.pm
Normal file
25
lib/SOAP/WSDL/XSD/Typelib/Builtin/NCName.pm
Normal file
@@ -0,0 +1,25 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::NCName;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::Name);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
26
lib/SOAP/WSDL/XSD/Typelib/Builtin/NMTOKEN.pm
Normal file
26
lib/SOAP/WSDL/XSD/Typelib/Builtin/NMTOKEN.pm
Normal file
@@ -0,0 +1,26 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::NMTOKEN;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::token);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
26
lib/SOAP/WSDL/XSD/Typelib/Builtin/NMTOKENS.pm
Normal file
26
lib/SOAP/WSDL/XSD/Typelib/Builtin/NMTOKENS.pm
Normal file
@@ -0,0 +1,26 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::NMTOKENS;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::list
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::NMTOKEN);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
33
lib/SOAP/WSDL/XSD/Typelib/Builtin/NOTATION.pm
Normal file
33
lib/SOAP/WSDL/XSD/Typelib/Builtin/NOTATION.pm
Normal file
@@ -0,0 +1,33 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::NOTATION;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %length_of :ATTR(:name<length> :default<()>);
|
||||
my %minLength_of :ATTR(:name<minLength> :default<()>);
|
||||
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<()>);
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
25
lib/SOAP/WSDL/XSD/Typelib/Builtin/Name.pm
Normal file
25
lib/SOAP/WSDL/XSD/Typelib/Builtin/Name.pm
Normal file
@@ -0,0 +1,25 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::Name;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::token);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
};
|
||||
|
||||
1;
|
||||
34
lib/SOAP/WSDL/XSD/Typelib/Builtin/QName.pm
Normal file
34
lib/SOAP/WSDL/XSD/Typelib/Builtin/QName.pm
Normal file
@@ -0,0 +1,34 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::QName;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
my %length_of :ATTR(:name<length> :default<()>);
|
||||
my %minLength_of :ATTR(:name<minLength> :default<()>);
|
||||
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<()>);
|
||||
|
||||
1;
|
||||
|
||||
50
lib/SOAP/WSDL/XSD/Typelib/Builtin/anySimpleType.pm
Normal file
50
lib/SOAP/WSDL/XSD/Typelib/Builtin/anySimpleType.pm
Normal file
@@ -0,0 +1,50 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anyType);
|
||||
}
|
||||
|
||||
my %value_of :ATTR(:get<value> :init_arg<value> :default<()>);
|
||||
|
||||
## use $_[n] for speed - we get called zillions of times...
|
||||
# and we don't need to return the last value...
|
||||
sub set_value { $value_of{ ident $_[0] } = $_[1] }
|
||||
|
||||
# use $_[n] for speed.
|
||||
# This is less readable, but notably faster.
|
||||
#
|
||||
# use postfix-if for speed. This is slightly faster, as it saves
|
||||
# perl from creating a pad (variable context).
|
||||
#
|
||||
# The methods below may get called zillions of times, so
|
||||
# every little statement matters...
|
||||
|
||||
sub serialize {
|
||||
no warnings qw(uninitialized);
|
||||
my $ident = ident $_[0];
|
||||
$_[1]->{ nil } = 1 if not defined $value_of{ $ident };
|
||||
return join q{}
|
||||
, $_[0]->start_tag($_[1], $value_of{ $ident })
|
||||
, $value_of{ $ident }
|
||||
, $_[0]->end_tag($_[1]);
|
||||
}
|
||||
|
||||
# TODO disallow serializing !
|
||||
sub as_bool :BOOLIFY {
|
||||
return $value_of { ident $_[0] };
|
||||
}
|
||||
|
||||
sub _get_handlers {
|
||||
my $parser = $_[1];
|
||||
return {
|
||||
Char => $parser->characters(),
|
||||
}
|
||||
}
|
||||
|
||||
Class::Std::initialize(); # make :BOOLIFY overloading serializable
|
||||
|
||||
|
||||
1;
|
||||
33
lib/SOAP/WSDL/XSD/Typelib/Builtin/anyType.pm
Normal file
33
lib/SOAP/WSDL/XSD/Typelib/Builtin/anyType.pm
Normal file
@@ -0,0 +1,33 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::anyType;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
my %xmlns_of :ATTR(:get<xmlns> :init_arg<xmlns> :default<()>);
|
||||
|
||||
sub set_xmlns { $xmlns_of{ ident $_[0] } = $_[1] };
|
||||
|
||||
# use $_[1] for performance
|
||||
sub start_tag {
|
||||
my $opt = $_[1] ||= {};
|
||||
return '<' . $opt->{name} . ' >' if $opt->{ name };
|
||||
return q{}
|
||||
}
|
||||
|
||||
# use $_[1] for performance
|
||||
sub end_tag {
|
||||
return $_[1] && defined $_[1]->{ name }
|
||||
? "</$_[1]->{name} >"
|
||||
: q{};
|
||||
};
|
||||
|
||||
sub serialize { q{} };
|
||||
|
||||
sub serialize_qualified :STRINGIFY {
|
||||
return $_[0]->serialize( { qualified => 1 } );
|
||||
}
|
||||
|
||||
Class::Std::initialize(); # make :STRINGIFY overloading serializable
|
||||
|
||||
1;
|
||||
|
||||
33
lib/SOAP/WSDL/XSD/Typelib/Builtin/anyURI.pm
Normal file
33
lib/SOAP/WSDL/XSD/Typelib/Builtin/anyURI.pm
Normal file
@@ -0,0 +1,33 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::anyURI;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
my %length_of :ATTR(:name<length> :default<()>);
|
||||
my %minLength_of :ATTR(:name<minLength> :default<()>);
|
||||
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<()>);
|
||||
|
||||
|
||||
1;
|
||||
35
lib/SOAP/WSDL/XSD/Typelib/Builtin/base64Binary.pm
Normal file
35
lib/SOAP/WSDL/XSD/Typelib/Builtin/base64Binary.pm
Normal file
@@ -0,0 +1,35 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::base64Binary;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
my %length_of :ATTR(:name<length> :default<()>);
|
||||
my %minLength_of :ATTR(:name<minLength> :default<()>);
|
||||
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<()>);
|
||||
|
||||
1;
|
||||
|
||||
60
lib/SOAP/WSDL/XSD/Typelib/Builtin/boolean.pm
Normal file
60
lib/SOAP/WSDL/XSD/Typelib/Builtin/boolean.pm
Normal file
@@ -0,0 +1,60 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::boolean;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
my %pattern_of :ATTR(:name<pattern> :default<()>);
|
||||
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
|
||||
my %value_of :ATTR(:get<value> :init_attr<value> :default<()>);
|
||||
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
# use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$value_of{ ident $self } = $_[0]->{ value }
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
sub serialize {
|
||||
my ($self, $opt) = @_;
|
||||
my $ident = ident $self;
|
||||
$opt ||= {};
|
||||
return $self->start_tag({ %$opt, nil => 1})
|
||||
if not defined $value_of{ $ident };
|
||||
return join q{}
|
||||
, $self->start_tag($opt)
|
||||
, $value_of{ $ident } ? 'true' : 'false'
|
||||
, $self->end_tag($opt);
|
||||
}
|
||||
|
||||
sub as_num :NUMERIFY :BOOLIFY {
|
||||
return $_[0]->get_value();
|
||||
}
|
||||
|
||||
sub set_value {
|
||||
my ($self, $value) = @_;
|
||||
$value_of{ ident $self } = defined $value
|
||||
? ($value ne 'false' or ($value))
|
||||
? 1 : 0
|
||||
: 0;
|
||||
}
|
||||
|
||||
|
||||
|
||||
Class::Std::initialize(); # make :BOOLIFY overloading serializable
|
||||
|
||||
1;
|
||||
26
lib/SOAP/WSDL/XSD/Typelib/Builtin/byte.pm
Normal file
26
lib/SOAP/WSDL/XSD/Typelib/Builtin/byte.pm
Normal file
@@ -0,0 +1,26 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::byte;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::short);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
79
lib/SOAP/WSDL/XSD/Typelib/Builtin/date.pm
Normal file
79
lib/SOAP/WSDL/XSD/Typelib/Builtin/date.pm
Normal file
@@ -0,0 +1,79 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::date;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Date::Parse;
|
||||
use Date::Format;
|
||||
|
||||
my %pattern_of :ATTR(:name<pattern> :default<()>);
|
||||
my %enumeration_of :ATTR(:name<enumeration> :default<()>);
|
||||
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
|
||||
my %maxInclusive_of :ATTR(:name<maxInclusive> :default<()>);
|
||||
my %maxExclusive_of :ATTR(:name<maxExclusive> :default<()>);
|
||||
my %minInclusive_of :ATTR(:name<minInclusive> :default<()>);
|
||||
my %minExclusive_of :ATTR(:name<minExclusive> :default<()>);
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
sub set_value {
|
||||
# use set_value from base class if we have a XML-DateTime format
|
||||
#2037-12-31+01:00
|
||||
if (
|
||||
$_[1] =~ m{ ^\d{4} \- \d{2} \- \d{2}
|
||||
(:? [\+\-] \d{2} \: \d{2} )$
|
||||
}xms
|
||||
) {
|
||||
$_[0]->SUPER::set_value($_[1])
|
||||
}
|
||||
# converting a date is hard work: It needs a timezone, because
|
||||
# 2007-12-30+12:00 and 2007-12-31-12:00 mean the same day - just in
|
||||
# different locations.
|
||||
# strftime actually prints out the correct date, but always prints the
|
||||
# local timezone with %z.
|
||||
# So, if our timezone is not 0, we strftime it without timezone and
|
||||
# append it by hand by the following formula:
|
||||
# The timezone hours are the int (timesone seconds / 3600)
|
||||
# The timezone minutes (if someone ever specifies something like that)
|
||||
# are int( (seconds % 3600) / 60 )
|
||||
# say, int( (seconds modulo 3600) / 60 )
|
||||
#
|
||||
# If we have no timezone (meaning the timezone is
|
||||
else {
|
||||
# strptime sets empty values to undef - and strftime doesn't like that...
|
||||
my @time_from = strptime($_[1]);
|
||||
my $time_zone_seconds = $time_from[6];
|
||||
@time_from = map { (! defined $_) ? 0 : $_ } @time_from;
|
||||
# use Data::Dumper;
|
||||
# warn Dumper \@time_from, sprintf('%+03d%02d', $time_from[6] / 3600, $time_from[6] % 60 );
|
||||
my $time_str = defined $time_zone_seconds
|
||||
? strftime( '%Y-%m-%d', @time_from )
|
||||
. sprintf('%+03d%02d', int($time_from[6] / 3600), int ( ($time_from[6] % 3600) / 60 ) )
|
||||
: do {
|
||||
strftime( '%Y-%m-%d%z', @time_from );
|
||||
};
|
||||
substr $time_str, -2, 0, ':';
|
||||
$_[0]->SUPER::set_value($time_str);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
56
lib/SOAP/WSDL/XSD/Typelib/Builtin/dateTime.pm
Normal file
56
lib/SOAP/WSDL/XSD/Typelib/Builtin/dateTime.pm
Normal file
@@ -0,0 +1,56 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::dateTime;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
use Date::Parse;
|
||||
use Date::Format;
|
||||
|
||||
my %pattern_of :ATTR(:name<pattern> :default<()>);
|
||||
my %enumeration_of :ATTR(:name<enumeration> :default<()>);
|
||||
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
|
||||
my %maxInclusive_of :ATTR(:name<maxInclusive> :default<()>);
|
||||
my %maxExclusive_of :ATTR(:name<maxExclusive> :default<()>);
|
||||
my %minInclusive_of :ATTR(:name<minInclusive> :default<()>);
|
||||
my %minExclusive_of :ATTR(:name<minExclusive> :default<()>);
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
sub set_value {
|
||||
# use set_value from base class if we have a XML-DateTime format
|
||||
#2037-12-31T00:00:00.0000000+01:00
|
||||
return $_[0]->SUPER::set_value($_[1]) if (
|
||||
$_[1] =~ m{ ^\d{4} \- \d{2} \- \d{2}
|
||||
T \d{2} \: \d{2} \: \d{2} (:? \. \d{1,7} )?
|
||||
[\+\-] \d{2} \: \d{2} $
|
||||
}xms
|
||||
);
|
||||
|
||||
# strptime sets empty values to undef - and strftime doesn't like that...
|
||||
my @time_from = map { ! defined $_ ? 0 : $_ } strptime($_[1]);
|
||||
undef $time_from[-1];
|
||||
|
||||
my $time_str = strftime( '%Y-%m-%dT%H:%M:%S%z', @time_from );
|
||||
substr $time_str, -2, 0, ':';
|
||||
$_[0]->SUPER::set_value($time_str);
|
||||
}
|
||||
|
||||
1;
|
||||
42
lib/SOAP/WSDL/XSD/Typelib/Builtin/decimal.pm
Normal file
42
lib/SOAP/WSDL/XSD/Typelib/Builtin/decimal.pm
Normal file
@@ -0,0 +1,42 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::decimal;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %totalDigits_of :ATTR(:name<totalDigits> :default<()>);
|
||||
my %fractionDigits_of :ATTR(:name<fractionDigits> :default<()>);
|
||||
my %pattern_of :ATTR(:name<pattern> :default<()>);
|
||||
my %enumeration_of :ATTR(:name<enumeration> :default<()>);
|
||||
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
|
||||
my %maxInclusive_of :ATTR(:name<maxInclusive> :default<()>);
|
||||
my %maxExclusive_of :ATTR(:name<maxExclusive> :default<()>);
|
||||
my %minInclusive_of :ATTR(:name<minInclusive> :default<()>);
|
||||
my %minExclusive_of :ATTR(:name<minExclusive> :default<()>);
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
sub as_num :NUMERIFY :BOOLIFY {
|
||||
return $_[0]->get_value();
|
||||
}
|
||||
|
||||
Class::Std::initialize(); # make :NUMERIFY :BOOLIFY overloading serializable
|
||||
|
||||
1;
|
||||
31
lib/SOAP/WSDL/XSD/Typelib/Builtin/double.pm
Normal file
31
lib/SOAP/WSDL/XSD/Typelib/Builtin/double.pm
Normal file
@@ -0,0 +1,31 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::double;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Speed up. Class::Std::new is slow - and we don't need it's functionality...
|
||||
BEGIN {
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
|
||||
|
||||
no warnings qw(redefine);
|
||||
no strict qw(refs);
|
||||
|
||||
# Yes, I know it's ugly - but this is the fastest constructor to write
|
||||
# for Class::Std-Style inside out objects..
|
||||
*{ __PACKAGE__ . '::new' } = sub {
|
||||
my $self = bless \do { my $foo } , shift;
|
||||
if (@_) {
|
||||
$self->set_value( $_[0]->{ value } )
|
||||
if exists $_[0]->{ value }
|
||||
}
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
sub as_num :NUMERIFY {
|
||||
return $_[0]->get_value();
|
||||
}
|
||||
|
||||
Class::Std::initialize(); # make :NUMERIFY overloading serializable
|
||||
|
||||
1;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user