import SOAP-WSDL 1.24 from CPAN
git-cpan-module: SOAP-WSDL git-cpan-version: 1.24 git-cpan-authorid: MKUTTER git-cpan-file: authors/id/M/MK/MKUTTER/SOAP-WSDL-1.24.tar.gz
This commit is contained in:
Martin Kutter
committed by
Michael G. Schwern
Michael G. Schwern
parent
7ba2f93e44
commit
9e85f63aa0
+1406
-542
File diff suppressed because it is too large
Load Diff
@@ -1,173 +0,0 @@
|
||||
package SOAP::WSDL::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use Class::Std::Storable;
|
||||
use List::Util qw(first);
|
||||
|
||||
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] };
|
||||
|
||||
# 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...
|
||||
# croak "no set accessor found for push_$subname"
|
||||
# if not ($self->can( $setter ));
|
||||
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) {
|
||||
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];
|
||||
};
|
||||
}
|
||||
croak "$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 } ) if ( $method );
|
||||
}
|
||||
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 toClass {
|
||||
my $self = shift;
|
||||
warn 'toClass is deprecated and will be removed before reaching 2.01 - '
|
||||
. 'use to_class instead (' . caller() . ')';
|
||||
$self->to_class(@_);
|
||||
}
|
||||
|
||||
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;
|
||||
@@ -1,115 +0,0 @@
|
||||
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<()>);
|
||||
|
||||
|
||||
sub explain {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $name = $self->get_name();
|
||||
|
||||
die 'required atribute wsdl missing' if not $opt->{ wsdl };
|
||||
|
||||
my $portType = $opt->{ wsdl }->find_portType(
|
||||
$opt->{ wsdl }->_expand( $self->get_type() )
|
||||
) or die 'portType not found: ' . $self->get_type();
|
||||
|
||||
my $txt = <<"EOT";
|
||||
|
||||
=head2 SOAP Operations
|
||||
|
||||
B<Note:>
|
||||
|
||||
Input, output and fault messages are stated as perl hash refs.
|
||||
|
||||
These are only for informational purposes - the actual implementation
|
||||
normally uses object trees, not hash refs, though the input messages
|
||||
may be passed to the respective methods as hash refs and will be
|
||||
converted to object trees automatically.
|
||||
|
||||
EOT
|
||||
|
||||
foreach my $operation (@{ $self->get_operation() }) {
|
||||
|
||||
my $operation_name = $operation->get_name();
|
||||
my $operation_style = $operation->get_style() || q{};
|
||||
|
||||
my $port_operation = first { $_->get_name eq $operation_name }
|
||||
@{ $portType->get_operation() }
|
||||
or die "operation not found:" . $operation->get_name();
|
||||
|
||||
# TODO rename lexical $input to "message"
|
||||
my $input_message = do {
|
||||
my $input = $port_operation->first_input();
|
||||
$input ? $input->explain($opt) : q{};
|
||||
};
|
||||
my $output_message = do {
|
||||
my $input = $port_operation->first_output();
|
||||
$input ? $input->explain($opt) : q{};
|
||||
};
|
||||
my $fault_message = do {
|
||||
my $input = $port_operation->first_fault();
|
||||
$input ? $input->explain($opt) : q{};
|
||||
};
|
||||
|
||||
$txt .= <<"EOT";
|
||||
|
||||
=head3 $operation_name
|
||||
|
||||
B<Input Message:>
|
||||
|
||||
$input_message
|
||||
|
||||
B<Output Message:>
|
||||
|
||||
$output_message
|
||||
|
||||
B<Fault:>
|
||||
|
||||
$fault_message
|
||||
|
||||
EOT
|
||||
}
|
||||
|
||||
return $txt;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
my ($self, $opt) = @_;
|
||||
my $name = $self->get_name();
|
||||
|
||||
my $portType = $opt->{ wsdl }->find_portType(
|
||||
$opt->{ wsdl }->_expand( $self->get_type )
|
||||
) or die 'portType not found: ' . $self->get_type;
|
||||
|
||||
my $txt = q{};
|
||||
foreach my $operation (@{ $self->get_operation() })
|
||||
{
|
||||
my $operation_name = $operation->get_name();
|
||||
my $operation_style = $operation->get_style() || q{};
|
||||
|
||||
my ($port_operation) = grep { $_->get_name eq $operation_name }
|
||||
@{ $portType->get_operation() }
|
||||
or die "operation not found:" . $operation->get_name();
|
||||
|
||||
no strict qw(refs);
|
||||
$txt .= join q{},
|
||||
map {
|
||||
my $message = $port_operation->$_;
|
||||
$message
|
||||
? $message->to_typemap($opt)
|
||||
: q{}
|
||||
} qw(first_input first_output first_fault);
|
||||
}
|
||||
return $txt;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,384 +0,0 @@
|
||||
package SOAP::WSDL::Client;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
use Class::Std::Storable;
|
||||
use LWP::UserAgent;
|
||||
use HTTP::Request;
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use SOAP::WSDL::Factory::Deserializer;
|
||||
use SOAP::WSDL::Factory::Serializer;
|
||||
use SOAP::WSDL::Factory::Transport;
|
||||
use SOAP::WSDL::Expat::MessageParser;
|
||||
|
||||
our $VERSION = '2.00_14';
|
||||
|
||||
# Package global for speed and memory savings.
|
||||
# But should be factored out into serializer/deserializer...
|
||||
my $PARSER;
|
||||
|
||||
my %class_resolver_of :ATTR(:name<class_resolver> :default<()>);
|
||||
my %no_dispatch_of :ATTR(:name<no_dispatch> :default<()>);
|
||||
my %outputxml_of :ATTR(:name<outputxml> :default<()>);
|
||||
my %transport_of :ATTR(:name<transport> :default<()>);
|
||||
my %endpoint_of :ATTR(:name<endpoint> :default<()>);
|
||||
|
||||
my %soap_version_of :ATTR(:get<soap_version> :init_attr<soap_version> :default<'1.1'>);
|
||||
|
||||
my %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<()>);
|
||||
|
||||
# TODO remove when preparing 2.01
|
||||
sub outputtree { warn 'outputtree is deprecated and'
|
||||
. 'will be removed before reaching v2.01 !' }
|
||||
|
||||
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;
|
||||
|
||||
=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.
|
||||
|
||||
=head3 Debugging / Tracing
|
||||
|
||||
While SOAP::Lite features a global tracing facility, SOAP::WSDL::Client
|
||||
allows to switch tracing on/of on a per-object base.
|
||||
|
||||
See L<set_trace|set_trace> on how to enable tracing.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
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
|
||||
|
||||
@@ -1,101 +0,0 @@
|
||||
package SOAP::WSDL::Client::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'SOAP::WSDL::Client';
|
||||
|
||||
sub __create_new {
|
||||
my ($package, %args_of) = @_;
|
||||
|
||||
no strict qw(refs);
|
||||
|
||||
*{ "$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: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Base.pm 214 2007-09-10 15:54:52Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Client/Base.pm $
|
||||
|
||||
=cut
|
||||
@@ -1,525 +0,0 @@
|
||||
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) = @_;
|
||||
return first {
|
||||
$_->get_targetNamespace() eq $args[0]
|
||||
&& $_->get_name() eq $args[1]
|
||||
}
|
||||
@{ $attributes_of{ $method }->{ ident $self } };
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub explain {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
$opt->{ wsdl } ||= $self;
|
||||
$opt->{ namespace } ||= $self->get_xmlns() || {};
|
||||
my $txt = '';
|
||||
|
||||
for my $service (@{ $self->get_service() }) {
|
||||
$txt .= $service->explain( $opt ) . "\n";
|
||||
}
|
||||
return $txt;
|
||||
}
|
||||
|
||||
sub _expand {
|
||||
my ($self, $prefix, $localname) = ($_[0], split /:/, $_[1]);
|
||||
my %ns_map = reverse %{ $self->get_xmlns() };
|
||||
return ($ns_map{ $prefix }, $localname);
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
$opt->{ prefix } ||= q{};
|
||||
$opt->{ wsdl } ||= $self;
|
||||
$opt->{ type_prefix } ||= $opt->{ prefix };
|
||||
$opt->{ element_prefix } ||= $opt->{ prefix };
|
||||
return join "\n",
|
||||
map { $_->to_typemap( $opt ) } @{ $service_of{ ident $self } };
|
||||
}
|
||||
|
||||
sub create {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
|
||||
my $base_path = $opt->{ base_path }
|
||||
or croak "missing or empty argument base_path";
|
||||
$opt->{ prefix } ||= q{};
|
||||
$opt->{ type_prefix } ||= $opt->{ prefix };
|
||||
$opt->{ element_prefix } ||= $opt->{ prefix };
|
||||
$opt->{ typemap_prefix } or die 'Required argument typemap_prefix missing';
|
||||
|
||||
mkpath $base_path;
|
||||
|
||||
for my $service (@{ $service_of{ ident $self } }) {
|
||||
warn "creating typemap $opt->{ typemap_prefix }". $service->get_name() . "\n";
|
||||
$self->_create_typemap({ %{ $opt }, service => $service });
|
||||
$self->_create_interface({ %{ $opt }, service => $service });
|
||||
}
|
||||
|
||||
my @schema = @{ $self->first_types()->get_schema() };
|
||||
for my $type (map { @{ $_->get_type() } , @{ $_->get_element() } } @schema[1..$#schema] ) {
|
||||
warn 'creating class for '. $type->get_name() . "\n";
|
||||
$type->to_class( { %$opt, wsdl => $self } );
|
||||
}
|
||||
}
|
||||
|
||||
sub _create_interface {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $service_name = $opt->{ service }->get_name();
|
||||
$service_name =~s{\.}{\:\:}xmsg;
|
||||
# TODO: iterate over ports.
|
||||
# - ignore non-SOAP ports
|
||||
# - generate interface for all SOAP ports...
|
||||
my $binding = $self->find_binding( $self->_expand( $opt->{ service }->first_port()->get_binding() ) );
|
||||
my $porttype = $self->find_portType( $self->_expand( $binding->get_type() ) );
|
||||
|
||||
my $port_operation_ref = $porttype->get_operation();
|
||||
my $operation_ref = $binding->get_operation();
|
||||
|
||||
# make up operations map - name => [ part types / elements class names ]
|
||||
#
|
||||
my %operations = ();
|
||||
for my $operation ( @{ $operation_ref } ) {
|
||||
my $operation_name = $operation->get_name();
|
||||
my $soap_operation = $operation->first_operation();
|
||||
|
||||
$operations{ $operation_name }->{ style } = $soap_operation
|
||||
? $soap_operation->get_style()
|
||||
: undef;
|
||||
|
||||
$operations{ $operation_name }->{ soap_action } = $soap_operation
|
||||
? $soap_operation->get_soapAction()
|
||||
: undef;
|
||||
|
||||
my $port_op = first { $_->get_name() eq $operation_name } @{ $port_operation_ref };
|
||||
|
||||
$operations{ $operation_name }->{ documentation } = $port_op->get_documentation();
|
||||
|
||||
my %msg_from = (
|
||||
'input' => ($port_op->first_input() ) ? $port_op->first_input()->get_message() : undef,
|
||||
'output' => ($port_op->first_output()) ? $port_op->first_output()->get_message(): undef,
|
||||
'fault' => ($port_op->first_fault()) ? $port_op->first_fault()->get_message() : undef,
|
||||
);
|
||||
|
||||
for my $msg (keys %msg_from) {
|
||||
next if not $msg_from{ $msg };
|
||||
for my $part (@{ $self->find_message( $self->_expand( $msg_from{$msg} ) )->get_part }) {
|
||||
my $name;
|
||||
if (my $element_name = $part->get_element() ) {
|
||||
$name = $element_name;
|
||||
push @{ $operations{ $operation_name }->{$msg}->{ types } },
|
||||
$self->first_types()->find_element( $self->_expand( $element_name ) )
|
||||
->explain({ wsdl => $self , anonymous => 1 });
|
||||
|
||||
}
|
||||
elsif (my $type_name = $part->get_element() ) {
|
||||
push @{ $operations{ $operation_name }->{$msg}->{ types } },
|
||||
$self->first_types()->find_type( $self->_expand( $element_name ) )
|
||||
->explain({ wsdl => $self });
|
||||
$name = $type_name;
|
||||
}
|
||||
my ($prefix, $localname) = split m{:}xms , $name;
|
||||
push @{ $operations{ $operation_name }->{$msg}->{ class } },
|
||||
"$opt->{ element_prefix }$localname";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $template = <<'EOT';
|
||||
package [% interface_prefix %][% service.get_name.replace('\.', '::') %];
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use [% typemap_prefix %][% service.get_name %];
|
||||
use base 'SOAP::WSDL::Client::Base';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $arg_ref = shift || {};
|
||||
my $self = $class->SUPER::new({
|
||||
class_resolver => '[% typemap_prefix %][% service.get_name.replace('\.', '::') %]',
|
||||
proxy => '[% service.first_port.get_location %]',
|
||||
%{ $arg_ref }
|
||||
});
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
__PACKAGE__->__create_methods(
|
||||
[% FOREACH name = operations.keys -%]
|
||||
[% name %] => {
|
||||
parts => [ [% FOREACH class = operations.$name.input.class %]'[% class %]', [% END %]],
|
||||
soap_action => '[% operations.$name.soap_action %]',
|
||||
style => '[% operations.$name.style %]',
|
||||
# use => '', # use not implemented yet
|
||||
},
|
||||
[% END %]
|
||||
);
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
[% MACRO pod BLOCK %]=pod[% END %]
|
||||
[% MACRO cut BLOCK %]=pod[% END %]
|
||||
[% MACRO head1 BLOCK %]=head1[% END %]
|
||||
[% MACRO head2 BLOCK %]=head2[% END %]
|
||||
[% pod %]
|
||||
|
||||
[% head1 %] NAME
|
||||
|
||||
[% interface_prefix %][% service.get_name %] - SOAP interface to [% service.get_name %] at
|
||||
[% service.first_port.get_location %]
|
||||
|
||||
[% head1 %] SYNOPSIS
|
||||
|
||||
my $interface = [% interface_prefix %][% service.get_name %]->new();
|
||||
my $[% operations.keys.1 %] = $interface->[% operations.keys.1 %]();
|
||||
|
||||
|
||||
[% head1 %] METHODS
|
||||
[% FOREACH name=operations.keys;
|
||||
operation=operations.$name;
|
||||
%]
|
||||
[% head2 %] [% name %]
|
||||
|
||||
[% operation.documentation %]
|
||||
|
||||
SYNOPSIS:
|
||||
|
||||
$service->[% name %]({
|
||||
[% FOREACH type = operation.input.types; type; END %] });
|
||||
|
||||
[% END %]
|
||||
|
||||
[% cut %]
|
||||
|
||||
EOT
|
||||
|
||||
require Template;
|
||||
my $file_name = "$opt->{ base_path }/$opt->{ interface_prefix }/$service_name.pm";
|
||||
$file_name =~s{::}{/}gms;
|
||||
my $path = dirname $file_name;
|
||||
my $name = basename $file_name;
|
||||
my $tt = Template->new(
|
||||
OUTPUT_PATH => $path,
|
||||
);
|
||||
$tt->process(\$template,
|
||||
{ %{ $opt }, operations => \%operations, binding => $binding, wsdl => $self },
|
||||
$name,
|
||||
binmode => ':utf8'
|
||||
)
|
||||
or die $tt->error();
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _create_typemap {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $service_name = $opt->{ service }->get_name();
|
||||
$service_name =~s{\.}{\:\:}xmsg;
|
||||
my $file_name = "$opt->{ base_path }/$opt->{ typemap_prefix }/$service_name.pm";
|
||||
$file_name =~s{::}{/}gms;
|
||||
my $path = dirname $file_name;
|
||||
my $name = basename $file_name;
|
||||
|
||||
my $typemap = $opt->{ service }->to_typemap( { %{ $opt }, wsdl => $self } );
|
||||
|
||||
my $template = <<'EOT';
|
||||
package [% typemap_prefix %][% service.get_name.replace('\.', '::') %];
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %typemap = (
|
||||
# SOAP 1.1 fault 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',
|
||||
|
||||
# generated typemap
|
||||
[% typemap %]
|
||||
[% custom_types %]
|
||||
);
|
||||
|
||||
sub get_class {
|
||||
my $name = join '/', @{ $_[1] };
|
||||
exists $typemap{ $name } or die "Cannot resolve $name via " . __PACKAGE__;
|
||||
return $typemap{ $name };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
EOT
|
||||
|
||||
require Template;
|
||||
my $tt = Template->new(
|
||||
OUTPUT_PATH => $path,
|
||||
);
|
||||
$tt->process(\$template,
|
||||
{ %{ $opt }, typemap => $typemap },
|
||||
$name,
|
||||
binmode => ':utf8',
|
||||
)
|
||||
or die $tt->error();
|
||||
|
||||
}
|
||||
|
||||
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).
|
||||
|
||||
=head2 explain
|
||||
|
||||
Returns a POD string describing how to call the methods of the service(s)
|
||||
described in the WSDL.
|
||||
|
||||
=head2 to_typemap
|
||||
|
||||
Creates a typemap for use with a generated type class library.
|
||||
|
||||
Options:
|
||||
|
||||
NAME DESCRIPTION
|
||||
-------------------------------------------------------------------------
|
||||
prefix Prefix to use for all classes
|
||||
type_prefix Prefix to use for all (Complex/Simple)Type classes
|
||||
element_prefix Prefix to use for all Element classes (with atomic types)
|
||||
|
||||
As some webservices tend to use globally unique type definitions, but
|
||||
locally unique elements with atomic types, type and element classes may
|
||||
be separated by specifying type_prefix and element_prefix instead of
|
||||
prefix.
|
||||
|
||||
The typemap is plain text which can be used as snipped for building a
|
||||
SOAP::WSDL class_resolver perl class.
|
||||
|
||||
Try something like this for creating typemap classes:
|
||||
|
||||
my $parser = XML::LibXML->new();
|
||||
my $handler = SOAP::WSDL::SAX::WSDLHandler->new()
|
||||
$parser->set_handler( $handler );
|
||||
|
||||
$parser->parse_url('file:///path/to/wsdl');
|
||||
|
||||
my $wsdl = $handler->get_data();
|
||||
my $typemap = $wsdl->to_typemap();
|
||||
|
||||
print <<"EOT"
|
||||
package MyTypemap;
|
||||
my \%typemap = (
|
||||
$typemap
|
||||
);
|
||||
sub get_class { return \$typemap{\$_[1] } };
|
||||
1;
|
||||
"EOT"
|
||||
|
||||
=head2 create_interface
|
||||
|
||||
Creates a typemap class, classes for all types and elements, and interface
|
||||
classes for every service.
|
||||
|
||||
See L<CODE GENERATOR|CODE GENERATOR> below.
|
||||
|
||||
Options:
|
||||
|
||||
Name Description
|
||||
----------------------------------------------------------------------------
|
||||
prefix Prefix to use for types and elements. Should end with '::'.
|
||||
element_prefix Prefix to use for element packages. Should end with '::'.
|
||||
Must be specified if prefix is not given.
|
||||
type_prefix Prefix to use for type packages. Should end with '::'.
|
||||
Must be specified if prefix is not given.
|
||||
typemap_prefix Prefix to use for type packages. Should end with '::'.
|
||||
Mandatory.
|
||||
custom_types A perl source code snippet defining custom types for the
|
||||
class resolver (typemap).
|
||||
Must look like this:
|
||||
q{
|
||||
'path/to/my/element' => 'My::Element',
|
||||
'path/to/my/element/prop' => 'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
'path/to/my/element/prop2' => 'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
};
|
||||
|
||||
=head2 _expand
|
||||
|
||||
Expands a qualified name into a list consisting of namespace URI and
|
||||
localname by using the definition's xmlns table.
|
||||
|
||||
Used internally by SOAP::WSDL::* classes.
|
||||
|
||||
=head1 CODE GENERATOR
|
||||
|
||||
TODO: move somewhere else - maybe SOAP::WSDL::Client ?
|
||||
|
||||
SOAP::WSDL::Definitions features a code generation facility for generating
|
||||
perl classes (packages) from a WSDL definition.
|
||||
|
||||
The following classes are generated:
|
||||
|
||||
=over
|
||||
|
||||
=item * Typemaps
|
||||
|
||||
A typemap class is created for every service.
|
||||
|
||||
Typemaps are basically lookup classes. They allow the
|
||||
SOAP::WSDL::SAX::MessageHandler to find out which class a XML element
|
||||
in a SOAP message shoud be processed as.
|
||||
|
||||
Typemaps are passed to SOAP::WSDL::Client via the class_resolver
|
||||
method.
|
||||
|
||||
=item * Interfaces
|
||||
|
||||
TODO: Implement Interface generation
|
||||
|
||||
Interface classes are just convenience shortcuts for accessing web
|
||||
service methods. They define a method for every web service method,
|
||||
dispatching the request to SOAP::WSDL::Client.
|
||||
|
||||
=item * Type and Element classes
|
||||
|
||||
For every top-level E<lt>elementE<gt>, E<lt>complexTypeE<gt> and
|
||||
E<lt>simpleTypeE<gt> definition in the WSDL's schema, a perl class is
|
||||
created.
|
||||
|
||||
Classes for E<lt>complexTypeE<gt> and E<lt>simpleTypeE<gt> definitions
|
||||
are prefixed by the C<type_prefix> argument passed to
|
||||
L<create_interface|create_interface>, classes for E<lt>elementE<gt>
|
||||
definitions are prefixed by the C<element_prefix> passed to
|
||||
L<create_interface|create_interface>. If the specific prefixes are not
|
||||
specified, the C<prefix> argument is used instead.
|
||||
|
||||
If your web service is part of a bigger framework which defines types
|
||||
globally, you probably do well always using the same C<type_prefix>:
|
||||
This reduces the number of classes generated (provided types
|
||||
are re-used by more than one service).
|
||||
|
||||
You probably should use different element prefixes, though -
|
||||
E<lt>elementE<gt> definitions tend to be unique in the defining WSDL
|
||||
only, especially when using document/literal style/encoding.
|
||||
|
||||
If not, you probably want to specify just C<prefix> (and use a
|
||||
different one for every web service).
|
||||
|
||||
=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>
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,49 +0,0 @@
|
||||
package SOAP::WSDL::Deserializer::SOAP11;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::SOAP::Typelib::Fault11;
|
||||
|
||||
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;
|
||||
@@ -1,124 +0,0 @@
|
||||
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
|
||||
@@ -1,226 +0,0 @@
|
||||
#!/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) = @_;
|
||||
|
||||
delete $self->{ data }; # remove potential old results
|
||||
|
||||
my $characters;
|
||||
my $current = undef;
|
||||
my $ignore = [ 'Envelope', 'Body' ]; # top level elements to ignore
|
||||
my $list = []; # node list
|
||||
my $path = []; # current path
|
||||
my $skip = 0; # skip elements
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_localname, $_element, $_method,
|
||||
$_class, $_parser, %_attrs) = ();
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
($_parser, $_element, %_attrs) = @_;
|
||||
($_prefix, $_localname) = split m{:}xms , $_element;
|
||||
|
||||
$_localname ||= $_element; # for non-prefixed elements
|
||||
|
||||
# ignore top level elements
|
||||
if (@{ $ignore } && $_localname eq $ignore->[0]) {
|
||||
CHECK_ENVELOPE: {
|
||||
last CHECK_ENVELOPE if $_localname ne 'Envelope';
|
||||
last CHECK_ENVELOPE if exists $_attrs{ 'xmlns' }
|
||||
&& $_attrs{ 'xmlns' } eq 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
last CHECK_ENVELOPE if $_attrs{ "xmlns:$_prefix"}
|
||||
eq 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
die "Bad namespace for SOAP envelope: " . $parser->recognized_string();
|
||||
}
|
||||
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 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({ %_attrs }); # set new current object
|
||||
|
||||
# remember top level element
|
||||
exists $self->{ data }
|
||||
or ($self->{ data } = $current);
|
||||
},
|
||||
|
||||
Char => sub {
|
||||
return if $skip;
|
||||
$characters .= $_[1];
|
||||
},
|
||||
|
||||
End => 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 );
|
||||
}
|
||||
# currently doesn't work, as anyType does not implement value -
|
||||
# maybe change ?
|
||||
# $current->set_value( $characters ) if ($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...
|
||||
}
|
||||
);
|
||||
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 };
|
||||
}
|
||||
|
||||
# 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 $
|
||||
|
||||
@@ -1,75 +0,0 @@
|
||||
#!/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 (Mo, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageStreamParser.pm $
|
||||
|
||||
@@ -1,213 +0,0 @@
|
||||
#!/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 (Mo, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageSubParser.pm $
|
||||
|
||||
|
||||
@@ -1,219 +0,0 @@
|
||||
#!/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 (Mo, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/SubParser.pm $
|
||||
|
||||
|
||||
@@ -1,175 +0,0 @@
|
||||
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)
|
||||
);
|
||||
}
|
||||
},
|
||||
|
||||
Char => sub { $characters .= $_[1] },
|
||||
|
||||
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 $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;
|
||||
|
||||
@@ -1,152 +0,0 @@
|
||||
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
|
||||
@@ -1,144 +0,0 @@
|
||||
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: 225 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Serializer.pm 225 2007-09-10 19:04:57Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Serializer.pm $
|
||||
|
||||
=cut
|
||||
@@ -1,240 +0,0 @@
|
||||
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: 225 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: Transport.pm 225 2007-09-10 19:04:57Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Factory/Transport.pm $
|
||||
|
||||
=cut
|
||||
@@ -1,222 +0,0 @@
|
||||
=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
|
||||
MyInterface/SERVICE_NAME.pm file per service.
|
||||
|
||||
=item * Write script
|
||||
|
||||
use MyInterface::SERVICE_NAME;
|
||||
my $service = MyInterface::SERVICE_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.
|
||||
|
||||
=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 interface class (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.
|
||||
|
||||
=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 faults 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
|
||||
expression relative to the Body element.
|
||||
|
||||
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.
|
||||
|
||||
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
|
||||
|
||||
=head1 Troubleshooting
|
||||
|
||||
|
||||
=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
|
||||
@@ -1,91 +0,0 @@
|
||||
=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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,9 +0,0 @@
|
||||
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;
|
||||
@@ -1,64 +0,0 @@
|
||||
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 %message_of :ATTR(:name<message> :default<()>);
|
||||
my %use_of :ATTR(:name<use> :default<()>);
|
||||
my %namespace :ATTR(:name<namespace> :default<()>);
|
||||
my %encodingStyle_of :ATTR(:name<encodingStyle> :default<()>);
|
||||
|
||||
sub explain
|
||||
{
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $name = shift;
|
||||
my $txt = '';
|
||||
|
||||
my %ns_map = reverse %{ $opt->{ wsdl }->get_xmlns() };
|
||||
|
||||
if ( $self->get_message() ) {
|
||||
|
||||
my ($prefix, $localname) = split /:/ , $self->get_message();
|
||||
|
||||
# TODO allow more messages && overloading by specifying name
|
||||
my $message = $opt->{ wsdl }->get_message(
|
||||
$ns_map{ $prefix }, $localname
|
||||
);
|
||||
|
||||
for my $part(@{ $message->[0]->get_part() }) {
|
||||
$txt .= $part->explain($opt);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if ($self->use())
|
||||
{
|
||||
$txt .= " $name use: " . $self->use(). "\n";
|
||||
}
|
||||
}
|
||||
return $txt;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
|
||||
my ($self, $opt) = @_;
|
||||
my $txt = q{};
|
||||
return q{} if not ( $self->get_message() ); # we're in binding
|
||||
my %ns_map = reverse %{ $opt->{ wsdl }->get_xmlns() };
|
||||
my ($prefix, $localname) = split /:/ , $self->get_message();
|
||||
|
||||
# TODO allow more messages && overloading by specifying name
|
||||
my $message = $opt->{ wsdl }->find_message(
|
||||
$ns_map{ $prefix }, $localname
|
||||
);
|
||||
|
||||
for my $part(@{ $message->get_part() }) {
|
||||
$txt .= $part->to_typemap($opt);
|
||||
}
|
||||
return $txt;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,21 +0,0 @@
|
||||
package SOAP::WSDL::Operation;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw/SOAP::WSDL::Base/;
|
||||
|
||||
# this class may be used for both soap::operation and wsdl::operation.
|
||||
# which one it is depends on context...
|
||||
|
||||
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;
|
||||
|
||||
|
||||
@@ -1,244 +0,0 @@
|
||||
=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>.
|
||||
|
||||
The use of SAX and L<XML::LibXML|XML::LibXML> in SOAP::WSDL is
|
||||
deprecated 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.
|
||||
|
||||
=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.
|
||||
|
||||
=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 );
|
||||
|
||||
=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();
|
||||
|
||||
=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.
|
||||
|
||||
=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.
|
||||
|
||||
See L<SOAP::WSDL::SAX::MessageHandler> 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
|
||||
|
||||
=cut
|
||||
@@ -1,89 +0,0 @@
|
||||
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";
|
||||
}
|
||||
|
||||
sub explain {
|
||||
my ($self, $opt, $name ) = @_;
|
||||
my $typelib = $opt->{ wsdl }->first_types() || die "No typelib";
|
||||
my $element = $self->get_type() || $self->get_element();
|
||||
|
||||
# resolve type
|
||||
my $type = $typelib->find_type( $opt->{ wsdl }->_expand( $element ) )
|
||||
|| $typelib->find_element( $opt->{ wsdl }->_expand( $element ) );
|
||||
|
||||
if (not $type)
|
||||
{
|
||||
warn "no type/element $element found for part " . $self->get_name();
|
||||
return q{};
|
||||
}
|
||||
return " {\n" . $type->explain( $opt, $self->get_name() ) . " }\n";
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
my ($self, $opt, $name ) = @_;
|
||||
my $txt = q{};
|
||||
my $wsdl = $opt->{ wsdl };
|
||||
my $typelib = $opt->{ wsdl }->first_types()
|
||||
|| die "No typelib";
|
||||
|
||||
# resolve type
|
||||
my $type;
|
||||
if (my $type_name = $self->get_type()) {
|
||||
$type = $typelib->find_type( $wsdl->_expand( $type_name ) )
|
||||
|| croak "no type/element $type_name found for part " . $self->get_name();
|
||||
$txt .= "q{} => " . $type->get_name() . "\n";
|
||||
}
|
||||
elsif ( my $element_name = $self->get_element() ) {
|
||||
$type = $typelib->find_element( $wsdl->_expand( $element_name ) )
|
||||
|| croak "no type/element $element_name found for part " . $self->get_name();
|
||||
}
|
||||
else {
|
||||
warn 'neither type nor element - do not know what to do for part '
|
||||
. $self->get_name();
|
||||
return q{};
|
||||
}
|
||||
$opt->{ path } = [];
|
||||
$txt .= $type->to_typemap( $opt, $self->get_name() );
|
||||
return $txt;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,43 +0,0 @@
|
||||
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 %location_of :ATTR(:name<location> :default<()>);
|
||||
|
||||
sub explain {
|
||||
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
$opt->{ wsdl } || die 'required attribute wsdl missing';
|
||||
|
||||
my $binding = $opt->{ wsdl }->find_binding(
|
||||
$opt->{ wsdl }->_expand( $self->get_binding() )
|
||||
) or die 'binding ' . $self->get_binding() . ' not found !';
|
||||
|
||||
|
||||
my $txt = "=head2 Service information:\n\n"
|
||||
. " Port name: " . $self->get_name() . "\n"
|
||||
. " Binding: " . $self->get_binding() ."\n"
|
||||
. " Location: " . $self->get_location() ."\n"
|
||||
. $binding->explain($opt);
|
||||
|
||||
return $txt;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
|
||||
# skip non-SOAP ports (could be http, email or whatever...)
|
||||
return q{} if not $location_of{ ident $self };
|
||||
|
||||
my $binding = $opt->{ wsdl }->find_binding(
|
||||
$opt->{wsdl}->_expand( $binding_of{ ident $self } )
|
||||
) or die 'binding ' . $binding_of{ ident $self } .' not found!';
|
||||
|
||||
return $binding->to_typemap($opt);
|
||||
}
|
||||
1;
|
||||
@@ -1,32 +0,0 @@
|
||||
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;
|
||||
@@ -1,281 +0,0 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::SAX::MessageHandler;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Scalar::Util qw(blessed);
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
|
||||
my %characters_of :ATTR(:default<()>);
|
||||
my %class_resolver_of :ATTR(:default<()> :name<class_resolver>);
|
||||
my %current_of :ATTR(:default<()>);
|
||||
my %ignore_of :ATTR(:default<()>);
|
||||
my %list_of :ATTR(:default<()>);
|
||||
my %namespace_of :ATTR(:default<()>);
|
||||
my %path_of :ATTR(:default<()>);
|
||||
my %data_of :ATTR(:default<()>);
|
||||
|
||||
{
|
||||
# we have to implement our own new - we need a blessed Hash ref as $self
|
||||
# for being able to inherit from XML::SAX::Base...
|
||||
no warnings qw(redefine);
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {}; # $class->SUPER::new(@_);
|
||||
my $args = shift || {};
|
||||
|
||||
die "arguments to new must be single hash ref"
|
||||
if @_ or ! ref $args eq 'HASH';
|
||||
|
||||
# nasty, but for those who want to use XML::SAX::Base or similar
|
||||
# as parser factory
|
||||
if ($args->{base}) {
|
||||
# yup, naughty string eval
|
||||
eval "use base qw($args->{base})"; ## no critic qw(ProhibitStringyEval)
|
||||
}
|
||||
else {
|
||||
# create all those SAX methods...
|
||||
# ...we ignore em all...
|
||||
no strict qw(refs);
|
||||
foreach my $method ( qw(
|
||||
processing_instruction
|
||||
ignorable_whitespace
|
||||
set_document_locator
|
||||
start_prefix_mapping
|
||||
end_prefix_mapping
|
||||
skipped_entity
|
||||
start_cdata
|
||||
end_cdata
|
||||
comment
|
||||
entity_reference
|
||||
notation_decl
|
||||
unparsed_entity_decl
|
||||
element_decl
|
||||
attlist_decl
|
||||
doctype_decl
|
||||
xml_decl
|
||||
entity_decl
|
||||
attribute_decl
|
||||
internal_entity_decl
|
||||
external_entity_decl
|
||||
resolve_entity
|
||||
start_dtd
|
||||
end_dtd
|
||||
start_entity
|
||||
end_entity
|
||||
warning
|
||||
) ) {
|
||||
*{ "$method" } = sub {};
|
||||
}
|
||||
}
|
||||
|
||||
$class_resolver_of{ ident $self } = $args->{ class_resolver }
|
||||
if $args->{ class_resolver };
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
}
|
||||
|
||||
sub class_resolver {
|
||||
my $self = shift;
|
||||
$class_resolver_of{ ident $self } = shift;
|
||||
}
|
||||
|
||||
sub start_document {
|
||||
my $ident = ident $_[0];
|
||||
$list_of{ $ident } = [];
|
||||
$current_of{ $ident } = '__STOP__'; # use as marker
|
||||
$namespace_of{ $ident } = {};
|
||||
$ignore_of{ $ident } = [ qw(Envelope Body) ]; # SOAP elements
|
||||
$path_of{ $ident } = [];
|
||||
$data_of{ $ident } = undef;
|
||||
}
|
||||
|
||||
sub start_element {
|
||||
# use $_[n] for performance
|
||||
my ($ident, $element) = (ident $_[0], $_[1]);
|
||||
|
||||
# ignore top level elements
|
||||
if (@{ $ignore_of{ $ident } }
|
||||
&& $element->{ LocalName } eq $ignore_of{ $ident }->[0]) {
|
||||
shift @{ $ignore_of{ $ident } };
|
||||
return;
|
||||
}
|
||||
|
||||
# empty characters
|
||||
$characters_of{ $ident } = q{};
|
||||
|
||||
push @{ $path_of{ $ident } }, $element->{ LocalName }; # step down...
|
||||
push @{ $list_of{ $ident } }, $current_of{ $ident }; # remember current
|
||||
|
||||
# resolve class of this element
|
||||
my $class = $class_resolver_of{ $ident }->get_class( $path_of{ $ident } )
|
||||
or die "Cannot resolve class for "
|
||||
. join('/', @{ $path_of{ $ident } })
|
||||
. " via "
|
||||
. $class_resolver_of{ $ident };
|
||||
|
||||
# Check whether we have a primitive - we implement them as classes
|
||||
# TODO replace with UNIVERSAL->isa()
|
||||
# match is a bit faster if the string does not match, but WAY slower
|
||||
# if $class matches...
|
||||
# if (not $class=~m{^SOAP::WSDL::XSD::Typelib::Builtin}xms) {
|
||||
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
|
||||
no strict qw(refs);
|
||||
*{ "$class\::new" }{ CODE }
|
||||
or eval "require $class" ## no critic qw(ProhibitStringyEval)
|
||||
or die $@;
|
||||
}
|
||||
# create object
|
||||
# set current object
|
||||
$current_of{ $ident } = $class->new({
|
||||
map { $_->{ Name } => $_->{ Value } }
|
||||
values %{ $element->{ Attributes } }
|
||||
});
|
||||
|
||||
# remember top level element
|
||||
defined $data_of{ $ident }
|
||||
or ($data_of{ $ident } = $current_of{ $ident });
|
||||
}
|
||||
|
||||
sub characters {
|
||||
$characters_of{ ident $_[0] } .= $_[1]->{ Data };
|
||||
}
|
||||
|
||||
sub end_element {
|
||||
# $_[n] used for performance
|
||||
my ($ident, $element) = (ident $_[0], $_[1]);
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
return if not ref $list_of{ $ident }->[-1];
|
||||
|
||||
if ( $current_of{ $ident }
|
||||
->isa('SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType') ) {
|
||||
$current_of{ $ident }->set_value( $characters_of{ $ident } );
|
||||
}
|
||||
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
my $method = "add_$element->{ LocalName }";
|
||||
|
||||
$list_of{ $ident }->[-1]->$method( $current_of{ $ident } );
|
||||
|
||||
# step up in path
|
||||
pop @{ $path_of{ $ident } };
|
||||
|
||||
# step up in object hierarchy...
|
||||
$current_of{ $ident } = pop @{ $list_of{ $ident } };
|
||||
}
|
||||
|
||||
sub end_document {
|
||||
my $self = shift;
|
||||
my $ident = ident $self;
|
||||
|
||||
# destroy all remains except data_of
|
||||
$list_of{ $ident } = ();
|
||||
$namespace_of{ $ident } = ();
|
||||
$ignore_of{ $ident } = ();
|
||||
$path_of{ $ident } = ();
|
||||
$characters_of{ $ident } = ();
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
my $self = shift;
|
||||
return $data_of{ ident $self };
|
||||
}
|
||||
|
||||
sub fatal_error {
|
||||
my $self = shift;
|
||||
die "Fatal error parsing document: " , @_;
|
||||
}
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
die "Error parsing document: " , @_;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::SAX::MessageHandler - Convert SOAP messages to custom object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# this is the direct variant, recommended for performance
|
||||
use SOAP::WSDL::SAX::MessageHandler;
|
||||
use XML::LibXML;
|
||||
|
||||
my $filter = SOAP::WSDL::SAX::MessageHandler->new( {
|
||||
class_resolver => FakeResolver->new()
|
||||
), "Object creation");
|
||||
my $parser = XML::LibXML->new();
|
||||
$parser->set_handler( $filter );
|
||||
|
||||
$parser->parse_string( $soap_message );
|
||||
|
||||
my $object_tree = $filter->get_data();
|
||||
|
||||
|
||||
# This is the XML::ParserFactory variant - for those who want other
|
||||
# parsers than XML::Simple....
|
||||
use SOAP::WSDL::SAX::MessageHandler;
|
||||
use XML::SAX::ParserFactory;
|
||||
|
||||
my $filter = SOAP::WSDL::SAX::MessageHandler->new( {
|
||||
class_resolver => FakeResolver->new(),
|
||||
base => 'XML::SAX::Base',
|
||||
), "Object creation");
|
||||
my $parser = XML::SAX::ParserFactor->parser(
|
||||
Handler => $handler
|
||||
);
|
||||
$parser->parse_string( $soap_message );
|
||||
|
||||
my $object_tree = $filter->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
SAX handler for parsing SOAP messages.
|
||||
|
||||
See L<SOAP::WSDL::Parser> for details.
|
||||
|
||||
=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 (Mo, 10 Sep 2007) $
|
||||
$LastChangedRevision: 214 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/SAX/MessageHandler.pm $
|
||||
|
||||
@@ -1,178 +0,0 @@
|
||||
package SOAP::WSDL::SAX::WSDLHandler;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::TypeLookup;
|
||||
|
||||
my %tree_of :ATTR(:name<tree> :default<{}>);
|
||||
my %order_of :ATTR(:name<order> :default<[]>);
|
||||
my %targetNamespace_of :ATTR(:name<targetNamespace> :default<()>);
|
||||
my %current_of :ATTR(:name<current> :default<()>);
|
||||
my %characters_of :ATTR();
|
||||
|
||||
{
|
||||
# we have to implement our own new - we need a blessed Hash ref as $self
|
||||
# for being able to inherit from XML::SAX::Base...
|
||||
no warnings qw(redefine);
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {}; # $class->SUPER::new(@_);
|
||||
my $args = shift || {};
|
||||
|
||||
die "arguments to new must be single hash ref"
|
||||
if @_ or ! ref $args eq 'HASH';
|
||||
|
||||
# nasty, but for those who want to use XML::SAX::Base or similar
|
||||
# as parser factory
|
||||
if ($args->{base}) {
|
||||
# yup, naughty string eval
|
||||
eval "use base qw($args->{base})"; ## no critic qw(ProhibitStringyEval)
|
||||
}
|
||||
else {
|
||||
# create all those SAX methods...
|
||||
# ...we ignore em all...
|
||||
no strict qw(refs);
|
||||
foreach my $method ( qw(
|
||||
processing_instruction
|
||||
ignorable_whitespace
|
||||
set_document_locator
|
||||
start_prefix_mapping
|
||||
end_prefix_mapping
|
||||
skipped_entity
|
||||
start_cdata
|
||||
end_cdata
|
||||
comment
|
||||
entity_reference
|
||||
notation_decl
|
||||
unparsed_entity_decl
|
||||
element_decl
|
||||
attlist_decl
|
||||
doctype_decl
|
||||
xml_decl
|
||||
entity_decl
|
||||
attribute_decl
|
||||
internal_entity_decl
|
||||
external_entity_decl
|
||||
resolve_entity
|
||||
start_dtd
|
||||
end_dtd
|
||||
start_entity
|
||||
end_entity
|
||||
warning
|
||||
error
|
||||
) ) {
|
||||
*{ "$method" } = sub {};
|
||||
}
|
||||
}
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
};
|
||||
|
||||
sub start_document {
|
||||
my $ident = ident $_[0];
|
||||
$tree_of{ $ident } = {};
|
||||
$order_of{ $ident } = [];
|
||||
$targetNamespace_of{ $ident } = undef;
|
||||
$current_of{ $ident } = undef;
|
||||
}
|
||||
|
||||
sub start_element {
|
||||
my ($self, $element) = @_;
|
||||
my $ident = ident $self;
|
||||
|
||||
my $action = SOAP::WSDL::TypeLookup->lookup(
|
||||
$element->{ NamespaceURI },
|
||||
$element->{ LocalName }
|
||||
);
|
||||
|
||||
$characters_of{ $ident } = q{};
|
||||
return if not $action;
|
||||
|
||||
if ($action->{ type } eq 'CLASS') {
|
||||
eval "require $action->{ class }";
|
||||
croak $@, $tree_of{ $ident } if ($@);
|
||||
|
||||
my $class = $action->{ class };
|
||||
my $obj = $class->new({ parent => $current_of{ $ident } })->init(
|
||||
values %{ $element->{ Attributes } }
|
||||
);
|
||||
|
||||
# set element in parent
|
||||
if ($current_of{ $ident }) {
|
||||
# inherit namespace, but don't override
|
||||
$obj->set_targetNamespace(
|
||||
$current_of{ $ident }->get_targetNamespace() )
|
||||
if not $obj->get_targetNamespace();
|
||||
|
||||
# push on name list
|
||||
my $method = "push_$element->{ LocalName }";
|
||||
no strict qw(refs);
|
||||
$current_of{ $ident }->$method( $obj );
|
||||
|
||||
# remember element for stepping back
|
||||
push @{ $order_of{ $ident } }, $current_of{ $ident };
|
||||
}
|
||||
else {
|
||||
$tree_of{ $ident } = $obj;
|
||||
}
|
||||
# set new element (step down)
|
||||
$current_of{ $ident } = $obj;
|
||||
}
|
||||
elsif ($action->{ type } eq 'PARENT') {
|
||||
$current_of{ $ident }->init( values %{ $element->{ Attributes } } );
|
||||
}
|
||||
elsif ($action->{ type } eq 'METHOD') {
|
||||
my $method = $action->{ method } || $element->{ LocalName };
|
||||
|
||||
no strict qw(refs);
|
||||
# call method with
|
||||
# - default value ($action->{ value } if defined,
|
||||
# dereferencing lists
|
||||
# - the values of the elements Attributes hash
|
||||
$current_of{ $ident }->$method( defined $action->{ value }
|
||||
? ref $action->{ value }
|
||||
? @{ $action->{ value } }
|
||||
: ($action->{ value })
|
||||
: values %{ $element->{ Attributes } } );
|
||||
}
|
||||
}
|
||||
|
||||
sub characters {
|
||||
$characters_of{ ident $_[0] } .= $_[1]->{ Data };
|
||||
}
|
||||
|
||||
sub end_element {
|
||||
my ($self, $element) = @_;
|
||||
my $ident = ident $self;
|
||||
|
||||
my $action = SOAP::WSDL::TypeLookup->lookup(
|
||||
$element->{ NamespaceURI },
|
||||
$element->{ LocalName }
|
||||
) || {};
|
||||
|
||||
return if not ($action->{ type });
|
||||
if ( $action->{ type } eq 'CLASS' ) {
|
||||
$current_of{ $ident } = pop @{ $order_of{ $ident } };
|
||||
}
|
||||
elsif ($action->{ type } eq 'CONTENT' ) {
|
||||
my $method = $action->{ method };
|
||||
no strict qw(refs);
|
||||
# strip of leading and trailing whitespace
|
||||
$characters_of{ $ident } =~s{ ^ \s+ (.+) \s+ $ }{$1}xms;
|
||||
# replace multi whitespace by one
|
||||
$characters_of{ $ident } =~s{ \s+ }{ }xmsg;
|
||||
$current_of{ $ident }->$method( $characters_of{ $ident } );
|
||||
}
|
||||
}
|
||||
|
||||
sub fatal_error {
|
||||
die @_;
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
my $self = shift;
|
||||
return $tree_of{ ident $self };
|
||||
}
|
||||
1;
|
||||
@@ -1,100 +0,0 @@
|
||||
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
|
||||
@@ -1,71 +0,0 @@
|
||||
#!/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>",
|
||||
);
|
||||
}
|
||||
@@ -1,32 +0,0 @@
|
||||
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<()>);
|
||||
|
||||
sub explain {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $txt ="=head1 Service " . $self->get_name() . "\n\n";
|
||||
foreach my $port (@{ $self->get_port() } )
|
||||
{
|
||||
$txt .= $port->explain( $opt );
|
||||
}
|
||||
return $txt;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
return join "\n",
|
||||
map { $_->to_typemap( $opt ) } @{ $port_of{ ident $self } };
|
||||
}
|
||||
|
||||
# TODO implement to_class as class generator for a (complete) interface
|
||||
sub to_class {
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
@@ -1,23 +0,0 @@
|
||||
package SOAP::WSDL::SoapOperation;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
my %input_of :ATTR(:name<input> :default<()>);
|
||||
my %output_of :ATTR(:name<output> :default<()>);
|
||||
my %fault_of :ATTR(:name<fault> :default<()>);
|
||||
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;
|
||||
@@ -1,101 +0,0 @@
|
||||
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);
|
||||
|
||||
# TODO check whether we need this with current LWP::UserAgent - we're
|
||||
# not here to fix LWP::UserAgent bugs...
|
||||
#
|
||||
# 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;
|
||||
|
||||
# END TODO
|
||||
|
||||
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: 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
|
||||
|
||||
@@ -1,129 +0,0 @@
|
||||
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
|
||||
@@ -1,174 +0,0 @@
|
||||
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::SoapOperation',
|
||||
},
|
||||
binding => {
|
||||
type => 'PARENT',
|
||||
},
|
||||
body => {
|
||||
type => 'PARENT',
|
||||
},
|
||||
address => {
|
||||
type => 'PARENT',
|
||||
}
|
||||
},
|
||||
'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_contentModel',
|
||||
value => 'simpleContent'
|
||||
},
|
||||
complexContent => {
|
||||
type => 'METHOD',
|
||||
method => 'set_contentModel',
|
||||
value => 'complexContent'
|
||||
},
|
||||
restriction => {
|
||||
type => 'METHOD',
|
||||
method => 'set_restriction',
|
||||
},
|
||||
list => {
|
||||
type => 'METHOD',
|
||||
method => 'set_list',
|
||||
},
|
||||
union => {
|
||||
type => 'METHOD',
|
||||
method => 'set_union',
|
||||
},
|
||||
enumeration => {
|
||||
type => 'METHOD',
|
||||
method => 'push_enumeration',
|
||||
},
|
||||
group => {
|
||||
type => 'METHOD',
|
||||
method => 'set_flavor',
|
||||
value => 'all',
|
||||
},
|
||||
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 };
|
||||
}
|
||||
@@ -1,37 +0,0 @@
|
||||
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) = @_;
|
||||
|
||||
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) = @_;
|
||||
|
||||
foreach my $schema (@{ $schema_of{ ident $self } }) {
|
||||
my $type = $schema->find_element($ns, $name);
|
||||
return $type if $type;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,46 +0,0 @@
|
||||
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;
|
||||
}
|
||||
|
||||
sub explain {
|
||||
my ($self, $opt, $name ) = @_;
|
||||
$opt->{ indent } = q{} if not defined $opt->{ indent };
|
||||
return "$opt->{ indent }'$name' => \$someValue,\n"
|
||||
}
|
||||
|
||||
sub toClass {
|
||||
warn "# builtin";
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,325 +0,0 @@
|
||||
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 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 explain {
|
||||
my ($self, $opt, $name ) = @_;
|
||||
my $flavor = $self->get_flavor();
|
||||
|
||||
$name ||= q{};
|
||||
|
||||
return q{} if not $flavor; # empty complexType
|
||||
$opt->{ indent } ||= q{ };
|
||||
my $xml = q{};
|
||||
$xml .= "$opt->{indent}\'$name'=> {\n" if $name;
|
||||
|
||||
if ( ($flavor eq "sequence") or ($flavor eq "all") ) {
|
||||
$opt->{ indent } .= " ";
|
||||
for my $element (@{ $self->get_element() }) {
|
||||
$xml .= $element->explain( $opt )
|
||||
}
|
||||
$opt->{ indent } =~s/\s{2}$//; # step back
|
||||
}
|
||||
elsif ($flavor eq "complexContent")
|
||||
{
|
||||
|
||||
}
|
||||
elsif ($flavor eq "simpleContent")
|
||||
{
|
||||
warn "found unsupported complexType definition $flavor";
|
||||
}
|
||||
else
|
||||
{
|
||||
warn "found unsupported complexType definition $flavor";
|
||||
}
|
||||
|
||||
|
||||
# if we're called inside a element...
|
||||
$xml .= "$opt->{indent}},\n" if $name;
|
||||
|
||||
return $xml;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
my ($self, $opt, $name ) = @_;
|
||||
my $flavor = $self->get_flavor();
|
||||
my $txt;
|
||||
return q{} if not $flavor; # empty complexType
|
||||
|
||||
my %nsmap = reverse %{ $opt->{ wsdl }->get_xmlns() };
|
||||
|
||||
if ( ($flavor eq "sequence") or ($flavor eq "all") )
|
||||
{
|
||||
for my $element (@{ $self->get_element() }) {
|
||||
$txt .= $element->to_typemap( $opt );
|
||||
}
|
||||
}
|
||||
return $txt;
|
||||
}
|
||||
|
||||
sub to_class {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
|
||||
my $template = <<'EOT';
|
||||
package [% type_prefix %][% self.get_name %];
|
||||
use strict;
|
||||
|
||||
use SOAP::WSDL::XSD::Typelib::ComplexType;
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::ComplexType
|
||||
);
|
||||
|
||||
[% FOREACH element=self.get_element -%]
|
||||
my %[% element.get_name %]_of :ATTR(:get<[% element.get_name %]>);
|
||||
[% END %]
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
[ qw([% FOREACH element=self.get_element -%]
|
||||
[% element.get_name %]
|
||||
[% END %]) ],
|
||||
{
|
||||
[% FOREACH element=self.get_element %][% element.get_name %] => \%[% element.get_name %]_of,
|
||||
[% END %]
|
||||
},
|
||||
{
|
||||
[%-
|
||||
FOREACH element=self.get_element;
|
||||
IF (element.get_type); # element type="..."
|
||||
split_name = element.get_type.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' -%]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[%- END;
|
||||
ELSIF (element.get_ref); # element ref="..."
|
||||
split_name = element.get_ref.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1; %]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[% ELSIF (simpleType = element.first_simpleType);
|
||||
base = simpleType.get_base();
|
||||
%]
|
||||
# basic simple type handling: we treat atomic simple types
|
||||
# in complexType elements as their base types
|
||||
# - and we only treat <restriction base="..."> yet.
|
||||
# our base here is [% base %]
|
||||
[%
|
||||
split_name = base.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' -%]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[%- END;
|
||||
END;
|
||||
END %]
|
||||
}
|
||||
);
|
||||
|
||||
sub get_xmlns { '[% self.get_targetNamespace %]' }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
[% MACRO pod BLOCK %]=pod[% END %]
|
||||
[% MACRO cut BLOCK %]=cut[% END %]
|
||||
[% MACRO head1 BLOCK %]=head1[% END %]
|
||||
[% MACRO head2 BLOCK %]=head2[% END %]
|
||||
|
||||
[% pod %]
|
||||
|
||||
[% head1 %] NAME
|
||||
|
||||
[% type_prefix %][% self.get_name %]
|
||||
|
||||
[% head1 %] SYNOPSIS
|
||||
|
||||
[% head1 %] DESCRIPTION
|
||||
|
||||
Type class for the XML type [% self.get_name %].
|
||||
|
||||
[% head1 %] PROPERTIES
|
||||
|
||||
The following properties may be accessed using get_PROPERTY / set_PROPERTY
|
||||
methods:
|
||||
|
||||
[%- FOREACH element = self.get_element %]
|
||||
[% element.get_name -%]
|
||||
[% END %]
|
||||
|
||||
[% head1 %] Object structure
|
||||
|
||||
[% FOREACH element=self.get_element;
|
||||
IF (element.get_type);
|
||||
split_name = element.get_type.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' -%]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[%- END;
|
||||
ELSIF (element.get_ref); # element ref="..."
|
||||
split_name = element.get_ref.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1; %]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[% ELSIF (simpleType = element.first_simpleType);
|
||||
base = simpleType.get_base();
|
||||
split_name = base.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' -%]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[%- END;
|
||||
END;
|
||||
END %]
|
||||
|
||||
Structure as perl hash:
|
||||
|
||||
The object structure is displayed as hash below though this is not correct.
|
||||
Complex hash elements actually are objects of their corresponding classes
|
||||
(look for classes of the same name in your typleib).
|
||||
new() will accept a hash structure like this, but transform it to a object
|
||||
tree.
|
||||
|
||||
[% structure %]
|
||||
|
||||
[% cut %]
|
||||
|
||||
EOT
|
||||
|
||||
$self->SUPER::to_class($opt, $template);
|
||||
}
|
||||
|
||||
sub _check_value {
|
||||
my $self = shift;
|
||||
}
|
||||
1;
|
||||
|
||||
@@ -1,402 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Element;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
use Data::Dumper;
|
||||
|
||||
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 );
|
||||
}
|
||||
|
||||
sub explain {
|
||||
my ($self, $opt, $name) = @_;
|
||||
my $type;
|
||||
my $text = q{};
|
||||
|
||||
# if we have a simple / complexType, explain right here
|
||||
if ($type = $self->first_simpleType() )
|
||||
{
|
||||
if ($opt->{ anonymous }) {
|
||||
delete $opt->{ anonymous };
|
||||
return $type->explain( $opt, undef );
|
||||
}
|
||||
return $type->explain( $opt, $self->get_name() );
|
||||
}
|
||||
elsif ($type = $self->first_complexType() )
|
||||
{
|
||||
if ($opt->{ anonymous }) {
|
||||
delete $opt->{ anonymous };
|
||||
return $type->explain( $opt, undef );
|
||||
}
|
||||
return $type->explain( $opt, $self->get_name() );
|
||||
}
|
||||
elsif (my $element_name = $self->get_ref() ) {
|
||||
my $element = $opt->{ wsdl }->first_types()->find_element(
|
||||
$opt->{ wsdl }->_expand( $element_name )
|
||||
);
|
||||
return $element->explain( $opt, $self->get_name() );
|
||||
}
|
||||
|
||||
# return if it's not a derived type - we don't handle
|
||||
# other stuff yet.
|
||||
return $text if (not $self->get_type() );
|
||||
|
||||
# if we have a derived type, fetch type and explain
|
||||
my ($prefix, $localname) = split /:/ , $self->get_type();
|
||||
my %ns_map = reverse %{ $opt->{ wsdl }->get_xmlns };
|
||||
|
||||
$type = $opt->{ wsdl }->first_types()->find_type(
|
||||
$ns_map{ $prefix }, $localname
|
||||
);
|
||||
|
||||
use Data::Dumper;
|
||||
die "no type for $prefix:$localname ($ns_map{ $prefix })"
|
||||
. Dumper $opt->{ wsdl }->first_types()->first_schema()->_DUMP
|
||||
if (not $type);
|
||||
|
||||
if ($opt->{ anonymous }) {
|
||||
delete $opt->{ anonymous };
|
||||
return $text .= $type->explain( $opt, undef );
|
||||
}
|
||||
return $text .= $type->explain( $opt, $name || $self->get_name() );
|
||||
return 'ERROR: '. $@;
|
||||
}
|
||||
|
||||
sub to_typemap {
|
||||
|
||||
my ($self, $opt) = @_;
|
||||
my $txt = q{};
|
||||
|
||||
my %nsmap = reverse %{ $opt->{ wsdl }->get_xmlns() };
|
||||
my $type;
|
||||
|
||||
push @{ $opt->{path} }, $self->get_name();
|
||||
|
||||
if ( my $typename = $self->get_type() ) {
|
||||
my ($prefix, $localname) = split /:/, $self->get_type();
|
||||
my $ns = $nsmap{ $prefix };
|
||||
my $typeclass;
|
||||
|
||||
# builtin type
|
||||
if ( $nsmap{ $prefix } eq 'http://www.w3.org/2001/XMLSchema') {
|
||||
$typeclass = "SOAP::WSDL::XSD::Typelib::Builtin::$localname";
|
||||
}
|
||||
else
|
||||
{
|
||||
$type = $opt->{ wsdl }->first_types()->find_type( $ns, $localname );
|
||||
|
||||
# referenced types need type_prefix (may be globally unique)
|
||||
$typeclass = $opt->{ type_prefix } . $type->get_name();
|
||||
$txt .= $type->to_typemap($opt);
|
||||
}
|
||||
$txt .= q{'} . join( q{/}, @{ $opt->{path} } ) . "' => '$typeclass',\n";
|
||||
}
|
||||
|
||||
# atomic types need element prefix
|
||||
elsif ($type = $self->first_simpleType() ) {
|
||||
# atomic types need element prefix (may be locally unique)
|
||||
# TODO fix simpletype Typemap
|
||||
my $typeclass = $opt->{ element_prefix } . $self->get_name();
|
||||
$txt .= q{'} . join( q{/}, @{ $opt->{path} } ) . "' => '$typeclass',\n";
|
||||
|
||||
my $flavor = $type->get_flavor();
|
||||
if ( $flavor eq 'sequence' ) {
|
||||
$txt .= "# atomic simple type (sequence)\n";
|
||||
$txt .= $type->to_typemap($opt). "\n";
|
||||
$txt .= "# end atomic simple type (sequence)\n";
|
||||
}
|
||||
elsif ( $flavor eq 'all' ) {
|
||||
$txt .= "# atomic simple type (all)\n";
|
||||
$txt .= $type->to_typemap($opt). "\n";
|
||||
$txt .= "# end atomic simple type (all)\n";
|
||||
}
|
||||
|
||||
}
|
||||
elsif ($type = $self->first_complexType() ) {
|
||||
my $typeclass = $opt->{ element_prefix } . $self->get_name();
|
||||
$txt .= q{'} . join( q{/}, @{ $opt->{path} } ) . "' => '$typeclass',\n";
|
||||
my $flavor = $type->get_flavor()
|
||||
|| 'UNKNOWN';
|
||||
if ( $flavor eq 'sequence' ) {
|
||||
$txt .= "# atomic complex type (sequence)\n";
|
||||
$txt .= $type->to_typemap($opt). "\n";;
|
||||
$txt .= "# end atomic complex type (sequence)\n";
|
||||
}
|
||||
elsif ( $flavor eq 'all' ) {
|
||||
$txt .= "# atomic complex type (all)\n";
|
||||
$txt .= $type->to_typemap($opt). "\n";
|
||||
$txt .= "# end atomic complex type (all)\n";
|
||||
}
|
||||
else {
|
||||
warn "flavor $flavor in element " . $self->get_name() . "\n";
|
||||
}
|
||||
}
|
||||
pop @{ $opt->{ path } };
|
||||
|
||||
return $txt;
|
||||
}
|
||||
|
||||
|
||||
sub to_class {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
|
||||
my $template = <<'EOT';
|
||||
package [% element_prefix %][% self.get_name %];
|
||||
use strict;
|
||||
|
||||
use SOAP::WSDL::XSD::Typelib::Element;
|
||||
|
||||
[% IF (type = self.first_simpleType) %]
|
||||
# <element name="[% self.get_name %]"><simpleType> definition
|
||||
use SOAP::WSDL::XSD::Typelib::SimpleType;
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType
|
||||
[% type.flavor_class %]
|
||||
[% type.base_class($type_prefix) %]
|
||||
);
|
||||
[% ELSIF (ref_name = self.get_ref);
|
||||
split_name = ref_name.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
ref_class = element_prefix _ localname;
|
||||
%]
|
||||
# <element name="[% self.get_name %]" ref="[% ref_name %]"> definition
|
||||
# use [% ref_class %];
|
||||
use base qw(
|
||||
[% ref_class %]
|
||||
);
|
||||
[% ELSIF (type = self.first_complexType) %]
|
||||
# atomic complexType
|
||||
# <element name="[% self.get_name %]"><complexType> definition
|
||||
use SOAP::WSDL::XSD::Typelib::ComplexType;
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
SOAP::WSDL::XSD::Typelib::ComplexType
|
||||
);
|
||||
|
||||
[% FOREACH element = type.get_element %]
|
||||
my %[% element.get_name %]_of :ATTR(:get<[% element.get_name %]>);
|
||||
[% END %]
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
[ qw([% FOREACH element = type.get_element %]
|
||||
[% element.get_name %]
|
||||
[% END %]) ],
|
||||
{
|
||||
[% FOREACH element = type.get_element %] [% element.get_name %] => \%[% element.get_name %]_of,
|
||||
[% END %]
|
||||
},
|
||||
{
|
||||
[% FOREACH element = type.get_element;
|
||||
split_name = element.get_type.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' %]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE %]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[% END %]
|
||||
[% END %]
|
||||
}
|
||||
);
|
||||
[%# END complexType %]
|
||||
[% ELSIF (type = self.get_type) %]
|
||||
#
|
||||
# <element name="[% self.get_name %]" type="[% self.get_type %]"/> definition
|
||||
#
|
||||
[% split_name = self.get_type.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
|
||||
IF (nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema');
|
||||
base_class = 'SOAP::WSDL::XSD::Typelib::Builtin::' _ localname ;
|
||||
ELSE;
|
||||
base_class = type_prefix _ localname;
|
||||
-%]
|
||||
|
||||
use [% base_class %];
|
||||
[% END %]
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
[% base_class %]
|
||||
);
|
||||
[% END %]
|
||||
|
||||
sub get_xmlns { '[% self.get_targetNamespace %]' }
|
||||
|
||||
__PACKAGE__->__set_name('[% self.get_name %]');
|
||||
__PACKAGE__->__set_nillable([% self.get_nillable %]);
|
||||
__PACKAGE__->__set_minOccurs([% self.get_minOccurs %]);
|
||||
__PACKAGE__->__set_maxOccurs([% self.get_maxOccurs %]);
|
||||
__PACKAGE__->__set_ref('[% self.get_ref %]');
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
[% MACRO pod BLOCK %]=pod[% END %]
|
||||
[% MACRO cut BLOCK %]=cut[% END %]
|
||||
[% MACRO head1 BLOCK %]=head1[% END %]
|
||||
[% MACRO head2 BLOCK %]=head2[% END %]
|
||||
|
||||
[% pod %]
|
||||
|
||||
[% head1 %] NAME
|
||||
|
||||
[% element_prefix %][% self.get_name %]
|
||||
|
||||
[% head1 %] SYNOPSIS
|
||||
|
||||
[% head1 %] DESCRIPTION
|
||||
|
||||
Type class for the XML element [% self.get_name %].
|
||||
|
||||
[% head1 %] PROPERTIES
|
||||
|
||||
The following properties may be accessed using get_PROPERTY / set_PROPERTY
|
||||
methods:
|
||||
|
||||
[%- IF (type = self.first_complexType);
|
||||
FOREACH element = type.get_element %]
|
||||
[% element.get_name -%]
|
||||
[% END;
|
||||
END %]
|
||||
|
||||
[% head1 %] Object structure
|
||||
|
||||
[%- IF (type = self.first_complexType);
|
||||
FOREACH element = type.get_element;
|
||||
split_name = element.get_type.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
IF nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema' %]
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE %]
|
||||
[% element.get_name %] => '[% type_prefix %]::[% localname %]',
|
||||
[% END;
|
||||
END;
|
||||
END %]
|
||||
|
||||
Structure as perl hash:
|
||||
|
||||
The object structure is displayed as hash below though this is not correct.
|
||||
Complex hash elements actually are objects of their corresponding classes
|
||||
(look for classes of the same name in your typleib).
|
||||
new() will accept a hash structure like this, but transform it to a object
|
||||
tree.
|
||||
|
||||
[% structure %]
|
||||
|
||||
[% cut %]
|
||||
|
||||
EOT
|
||||
|
||||
$self->SUPER::to_class($opt, $template);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
@@ -1,73 +0,0 @@
|
||||
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;
|
||||
@@ -1,64 +0,0 @@
|
||||
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' => {},
|
||||
'non-positive-integer' => {},
|
||||
'non-negative-integer' => {},
|
||||
'positiveInteger' => {},
|
||||
'negativeInteger' => {},
|
||||
'long' => {},
|
||||
'int' => {},
|
||||
'unsignedInt' => {},
|
||||
'short' => {},
|
||||
'unsignedShort' => {},
|
||||
'byte' => {},
|
||||
'unsignedByte' => {},
|
||||
'normalizedString' => {},
|
||||
'token' => {},
|
||||
'NMTOKEN' => {},
|
||||
);
|
||||
|
||||
# TODO place into appropriate schema and push on schema definitions list
|
||||
# in types
|
||||
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;
|
||||
@@ -1,153 +0,0 @@
|
||||
package SOAP::WSDL::XSD::SimpleType;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
use base qw(SOAP::WSDL::Base);
|
||||
|
||||
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<()>);
|
||||
|
||||
# set to restriction|list|union|enumeration
|
||||
my %flavor_of :ATTR(:name<flavor> :default<()>);
|
||||
|
||||
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 'type');
|
||||
$self->set_base( $_->{ 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 explain {
|
||||
my ($self, $opt, $name ) = @_;
|
||||
$opt->{ indent } = q{} if not defined $opt->{ indent };
|
||||
return "$opt->{ indent }'$name' => \$someValue,\n"
|
||||
}
|
||||
|
||||
sub _check_value {
|
||||
my $self = shift;
|
||||
}
|
||||
|
||||
# TODO: implement to_class based on template...
|
||||
|
||||
sub to_class {
|
||||
my $self = shift;
|
||||
my $opt = shift;
|
||||
my $class_prefix = $opt->{ type_prefix };
|
||||
my $name = $opt->{name} || $self->get_name();
|
||||
my $flavor = $self->get_flavor() eq 'list'
|
||||
? 'SOAP::WSDL::XSD::Typelib::Builtin::list'
|
||||
: $self->get_flavor() eq 'restriction'
|
||||
? 'SOAP::WSDL::XSD::Typelib::SimpleType::restriction'
|
||||
: q{};
|
||||
my $base = $self->get_base();
|
||||
my $targetNamespace = $self->get_targetNamespace;
|
||||
my ($prefix, $localname) = split /:/, $base;
|
||||
my %ns_map = reverse %{ $opt->{ wsdl }->get_xmlns() };
|
||||
$base = ($ns_map{ $prefix} eq 'http://www.w3.org/2001/XMLSchema')
|
||||
? "SOAP::WSDL::XSD::Typelib::Builtin::$localname"
|
||||
: "$opt->{prefix}::$localname";
|
||||
|
||||
my $code =<<"EOT";
|
||||
package $class_prefix::$name;
|
||||
use strict;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use SOAP::WSDL::XSD::Typelib::SimpleType;
|
||||
use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType
|
||||
$flavor
|
||||
$base
|
||||
);
|
||||
|
||||
1;
|
||||
|
||||
sub get_xmlns { '$targetNamespace' }
|
||||
|
||||
EOT
|
||||
|
||||
return $code;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,369 +0,0 @@
|
||||
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
|
||||
@@ -1,25 +0,0 @@
|
||||
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;
|
||||
@@ -1,7 +0,0 @@
|
||||
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;
|
||||
@@ -1,7 +0,0 @@
|
||||
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;
|
||||
@@ -1,9 +0,0 @@
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
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;
|
||||
@@ -1,26 +0,0 @@
|
||||
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;
|
||||
|
||||
@@ -1,26 +0,0 @@
|
||||
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;
|
||||
@@ -1,33 +0,0 @@
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
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;
|
||||
@@ -1,34 +0,0 @@
|
||||
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;
|
||||
|
||||
@@ -1,50 +0,0 @@
|
||||
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;
|
||||
@@ -1,33 +0,0 @@
|
||||
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;
|
||||
|
||||
@@ -1,33 +0,0 @@
|
||||
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;
|
||||
@@ -1,35 +0,0 @@
|
||||
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;
|
||||
|
||||
@@ -1,60 +0,0 @@
|
||||
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;
|
||||
@@ -1,26 +0,0 @@
|
||||
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;
|
||||
@@ -1,79 +0,0 @@
|
||||
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;
|
||||
|
||||
@@ -1,56 +0,0 @@
|
||||
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;
|
||||
@@ -1,42 +0,0 @@
|
||||
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;
|
||||
@@ -1,31 +0,0 @@
|
||||
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;
|
||||
@@ -1,34 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::duration;
|
||||
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 %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<()>);
|
||||
|
||||
|
||||
1;
|
||||
@@ -1,41 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::float;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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 {
|
||||
return $_[0]->get_value();
|
||||
}
|
||||
|
||||
Class::Std::initialize(); # make :NUMERIFY overloading serializable
|
||||
|
||||
1;
|
||||
|
||||
@@ -1,34 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::gDay;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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;
|
||||
};
|
||||
|
||||
};
|
||||
|
||||
1;
|
||||
@@ -1,34 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::gMonth;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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;
|
||||
};
|
||||
|
||||
};
|
||||
|
||||
1;
|
||||
@@ -1,34 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::gMonthDay;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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;
|
||||
};
|
||||
|
||||
};
|
||||
|
||||
1;
|
||||
@@ -1,34 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::gYear;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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;
|
||||
};
|
||||
|
||||
};
|
||||
|
||||
1;
|
||||
@@ -1,33 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::gYearMonth;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
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;
|
||||
};
|
||||
|
||||
};
|
||||
|
||||
1;
|
||||
@@ -1,32 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::hexBinary;
|
||||
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;
|
||||
@@ -1,26 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::int;
|
||||
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::long);
|
||||
|
||||
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;
|
||||
@@ -1,33 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::integer;
|
||||
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::decimal);
|
||||
|
||||
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;
|
||||
@@ -1,26 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::language;
|
||||
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;
|
||||
@@ -1,41 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::list;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Class::Std::Storable;
|
||||
|
||||
sub serialize {
|
||||
my ($self, $opt) = @_;
|
||||
my $value = $self->get_value();
|
||||
return $self->start_tag({ %$opt, nil => 1 }) if not defined $value;
|
||||
$value = [ $value ] if not ref $value;
|
||||
return join q{}, $self->start_tag($opt, $value)
|
||||
, join( q{ }, @{ $value } )
|
||||
, $self->end_tag($opt, $value);
|
||||
}
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::list - list derivation base class
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
To derive from some class by list, just inherit from list.
|
||||
|
||||
Make sure SOAP::WSDL::XSD::Typelib::Builtin::list is before the type
|
||||
to derive from in the @ISA list.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
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
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::long;
|
||||
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::integer);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::negativeInteger;
|
||||
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::nonPositiveInteger);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::nonNegativeInteger;
|
||||
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::integer);
|
||||
|
||||
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;
|
||||
@@ -1,26 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::nonPositiveInteger;
|
||||
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::integer);
|
||||
|
||||
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;
|
||||
@@ -1,26 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::normalizedString;
|
||||
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::string);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::positiveInteger;
|
||||
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::nonNegativeInteger);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::short;
|
||||
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::int);
|
||||
|
||||
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;
|
||||
@@ -1,60 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::string;
|
||||
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<()>);
|
||||
|
||||
|
||||
|
||||
my %char2entity = (
|
||||
q{&} => q{&},
|
||||
q{<} => q{<},
|
||||
q{>} => q{>},
|
||||
q{"} => q{&qout;},
|
||||
q{'} => q{'},
|
||||
);
|
||||
|
||||
sub serialize {
|
||||
my ($self, $opt) = @_;
|
||||
my $ident = ident $self;
|
||||
$opt ||= {};
|
||||
my $value = $self->get_value();
|
||||
return $self->start_tag({ %$opt, nil => 1})
|
||||
if not defined $value;
|
||||
|
||||
# HTML::Entities does the same - and more, thus it's around 1/3 slower...
|
||||
$value =~ s{([&<>"'])}{$char2entity{$1}}xgmso;
|
||||
|
||||
return join q{}, $self->start_tag($opt, $value)
|
||||
#, encode_entities( $value, q{&<>"'} )
|
||||
, $value
|
||||
, $self->end_tag($opt);
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,61 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::time;
|
||||
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-Time format
|
||||
# 00:00:00.0000000+01:00
|
||||
if (
|
||||
$_[1] =~ m{ ^ \d{2} \: \d{2} \: \d{2} (:? \. \d{1,7} )?
|
||||
[\+\-] \d{2} \: \d{2} $
|
||||
}xms
|
||||
) {
|
||||
$_[0]->SUPER::set_value($_[1])
|
||||
}
|
||||
# use a combination of strptime and strftime for converting the date
|
||||
# Unfortunately, strftime outputs the time zone as [+-]0000, whereas XML
|
||||
# whants it as [+-]00:00
|
||||
# We leave out the optional nanoseconds part, as it would always be empty.
|
||||
else {
|
||||
# strptime sets empty values to undef - and strftime doesn't like that...
|
||||
# we even need to set it to 1 to prevent a "Day '0' out of range 1..31" warning...
|
||||
my @time_from = map { ! defined $_ ? 1 : $_ } strptime($_[1]);
|
||||
my $time_str = strftime( '%H:%M:%S%z', @time_from );
|
||||
substr $time_str, -2, 0, ':';
|
||||
$_[0]->SUPER::set_value($time_str);
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
@@ -1,24 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::token;
|
||||
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::normalizedString);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::unsignedByte;
|
||||
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::unsignedShort);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::unsignedInt;
|
||||
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::unsignedLong);
|
||||
|
||||
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;
|
||||
@@ -1,24 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::unsignedLong;
|
||||
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::nonNegativeInteger);
|
||||
|
||||
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;
|
||||
@@ -1,25 +0,0 @@
|
||||
package SOAP::WSDL::XSD::Typelib::Builtin::unsignedShort;
|
||||
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::unsignedInt);
|
||||
|
||||
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;
|
||||
@@ -1,349 +0,0 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::XSD::Typelib::ComplexType;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use Scalar::Util qw(blessed refaddr);
|
||||
use Data::Dumper;
|
||||
use Class::Std::Storable;
|
||||
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anyType);
|
||||
|
||||
my %ELEMENTS_FROM;
|
||||
my %ATTRIBUTES_OF;
|
||||
my %CLASSES_OF;
|
||||
|
||||
# STORABLE_ methods for supporting Class::Std::Storable.
|
||||
# We could also handle them via AUTOMETHOD,
|
||||
# but AUTOMETHOD should always croak...
|
||||
sub STORABLE_freeze_pre {
|
||||
}
|
||||
|
||||
sub STORABLE_freeze_post {
|
||||
}
|
||||
|
||||
sub STORABLE_thaw_pre {
|
||||
}
|
||||
|
||||
sub STORABLE_thaw_post {
|
||||
}
|
||||
|
||||
# for error reporting. Eases working with data objects...
|
||||
sub AUTOMETHOD {
|
||||
my ($self, $ident, @args_from) = @_;
|
||||
|
||||
my $class = ref $self || $self;
|
||||
confess "Can't locate object method \"$_\" via package \"$class\". \n"
|
||||
. "Valid methods are: "
|
||||
. join(', ', map { ("get_$_" , "set_$_") } keys %{ $ATTRIBUTES_OF{ $class } })
|
||||
. "\n"
|
||||
}
|
||||
|
||||
# we store per-class elements.
|
||||
# call as __PACKAGE__->_factory
|
||||
sub _factory {
|
||||
my $class = shift;
|
||||
$ELEMENTS_FROM{ $class } = shift;
|
||||
$ATTRIBUTES_OF{ $class } = shift;
|
||||
$CLASSES_OF{ $class } = shift;
|
||||
|
||||
no strict qw(refs);
|
||||
no warnings qw(redefine);
|
||||
while (my ($name, $attribute_ref) = each %{ $ATTRIBUTES_OF{ $class } } )
|
||||
{
|
||||
my $type = $CLASSES_OF{ $class }->{ $name }
|
||||
or die "No class given for $name";
|
||||
|
||||
# require all types here
|
||||
$type->isa('UNIVERSAL')
|
||||
or eval "require $type"
|
||||
or croak $@;
|
||||
|
||||
# check now, so we don't need to do it later...
|
||||
my $is_list = $type->isa('SOAP::WSDL::XSD::Typelib::Builtin::list');
|
||||
|
||||
*{ "$class\::set_$name" } = sub {
|
||||
# my ($self, $value) = @_;
|
||||
|
||||
# The structure below looks rather weird, but is optimized for performance.
|
||||
#
|
||||
# We could use sub calls for sure, but these are much slower. And the logic
|
||||
# is not that easy:
|
||||
#
|
||||
# we accept:
|
||||
# a) objects
|
||||
# b) scalars
|
||||
# c) list refs
|
||||
# d) hash refs
|
||||
# e) mixed stuff of all of the above, so we have to set our element to
|
||||
# a) value if it's an object
|
||||
# b) New object of expected class with value for simple values
|
||||
# c 1) New object with value for list values and list type
|
||||
# c 2) List ref of new objects with value for list values and non-list type
|
||||
# c + e 1) List ref of objects for list values (list of objects) and non-list type
|
||||
# c + e 2) List ref of new objects for list values (list of hashes) and non-list type
|
||||
# where the hash ref is passed to new as argument
|
||||
# d) New object with values passed to new for HASH references
|
||||
#
|
||||
# We throw an error on
|
||||
# a) list refs of list refs - don't know what to do with this (maybe use for lists of list types ?)
|
||||
# b) wrong object types
|
||||
# c) non-blessed non-ARRAY/HASH references - if you can define semantics
|
||||
# for GLOB references, feel free to add them.
|
||||
# d) we should also die for non-blessed non-ARRAY/HASH references in lists but don't do yet - oh my !
|
||||
|
||||
my $is_ref = ref $_[1];
|
||||
$attribute_ref->{ ident $_[0] } = ($is_ref)
|
||||
? $is_ref eq 'ARRAY'
|
||||
? $is_list # remembered from outside closure
|
||||
? $type->new({ value => $_[1] }) # list element - can take list ref as value
|
||||
: [ map {
|
||||
ref $_
|
||||
? ref $_ eq 'HASH'
|
||||
? $type->new($_)
|
||||
: ref $_ eq $type
|
||||
? $_
|
||||
: croak "cannot use " . ref($_) . " reference as value for $name - $type required"
|
||||
: $type->new({ value => $_ })
|
||||
} @{ $_[1] }
|
||||
]
|
||||
: $is_ref eq 'HASH'
|
||||
? $type->new( $_[1] )
|
||||
: $is_ref eq $type
|
||||
? $_[1]
|
||||
: die croak "cannot use $is_ref reference as value for $name - $type required"
|
||||
: $type->new({ value => $_[1] });
|
||||
};
|
||||
|
||||
*{ "$class\::add_$name" } = sub {
|
||||
my $ident = ident $_[0];
|
||||
warn "attempting to add empty value to " . ref $_[0]
|
||||
if not defined $_[1];
|
||||
|
||||
# first call
|
||||
return $attribute_ref->{ $ident } = $_[1]
|
||||
if not defined $attribute_ref->{ $ident };
|
||||
|
||||
# second call: listify previous value if it's no list
|
||||
$attribute_ref->{ $ident } = [ $attribute_ref->{ $ident } ]
|
||||
if not ref $attribute_ref->{ $ident } eq 'ARRAY';
|
||||
|
||||
# second and following: add to list
|
||||
return push @{ $attribute_ref->{ $ident } }, $_[1];
|
||||
};
|
||||
|
||||
*{ "$class\::$name" } = *{ "$class\::add_$name" };
|
||||
}
|
||||
|
||||
*{ "$class\::new" } = sub {
|
||||
my $self = bless \my ($o), $_[0];
|
||||
$self->BUILD( ident $self, $_[1] ) if exists &BUILD;
|
||||
$self->_init( ident $self, $_[1] );
|
||||
$self->START( ident $self, $_[1] ) if exists &START;
|
||||
return $self;
|
||||
};
|
||||
|
||||
*{ "$class\::_init" } = sub {
|
||||
# We're working on @_ for speed.
|
||||
# Normally, the first line would look like this:
|
||||
# my ($self, $ident, $args_of) = @_;
|
||||
#
|
||||
# The hanging side comment show you what would be there, then.
|
||||
|
||||
# iterate over keys of arguments
|
||||
# and call set appropriate field in clase
|
||||
map { ($ATTRIBUTES_OF{ $class }->{ $_ })
|
||||
? do {
|
||||
my $method = "set_$_";
|
||||
$_[0]->$method( $_[2]->{ $_ } ); # ( $args_of->{ $_ } );
|
||||
}
|
||||
: $_ =~ m{ \A # beginning of string
|
||||
xmlns # xmlns
|
||||
}xms
|
||||
? do {}
|
||||
: do { use Data::Dumper;
|
||||
croak "unknown field $_ in $class. Valid fields are:\n"
|
||||
. join(', ', @{ $ELEMENTS_FROM{ $class } }) . "\n"
|
||||
. "Structure given:\n" . Dumper @_ };
|
||||
} keys %{ $_[2] }; # %$args_of;
|
||||
return $_[0]; # $self;
|
||||
};
|
||||
|
||||
|
||||
# this serialize method works fine for <all> and <sequence>
|
||||
# complextypes, as well as for <restriction><all> or
|
||||
# <restriction><sequence>.
|
||||
# But what about choice, extension ?
|
||||
*{ "$class\::_serialize" } = sub {
|
||||
my $ident = ident $_[0];
|
||||
# my $class = ref $_[0];
|
||||
# return concatenated return value of serialize call of all
|
||||
# elements retrieved from get_elements expanding list refs.
|
||||
# get_elements is inlined for performance.
|
||||
return join q{} , map {
|
||||
my $element = $ATTRIBUTES_OF{ $class }->{ $_ }->{ $ident };
|
||||
|
||||
# do we have some content
|
||||
if (defined $element) {
|
||||
$element = [ $element ]
|
||||
if not ref $element eq 'ARRAY';
|
||||
my $name = $_;
|
||||
|
||||
map {
|
||||
# serialize element elements with their own serializer
|
||||
# but name them like they're named here.
|
||||
if ( $_->isa( 'SOAP::WSDL::XSD::Typelib::Element' ) ) {
|
||||
$_->serialize( { name => $name } );
|
||||
}
|
||||
# serialize complextype elments (of other types) with their
|
||||
# serializer, but add element tags around.
|
||||
else {
|
||||
join q{}, $_->start_tag({ name => $name })
|
||||
, $_->serialize()
|
||||
, $_->end_tag({ name => $name });
|
||||
}
|
||||
} @{ $element }
|
||||
}
|
||||
else {
|
||||
q{};
|
||||
}
|
||||
} (@{ $ELEMENTS_FROM{ $class } });
|
||||
};
|
||||
|
||||
*{ "$class\::serialize" } = sub {
|
||||
my ($self, $opt) = @_;
|
||||
$opt ||= {};
|
||||
|
||||
# do we have a empty element ?
|
||||
return $self->start_tag({ %$opt, empty => 1 })
|
||||
if not defined $ELEMENTS_FROM{ $class } or not @{ $ELEMENTS_FROM{ $class } };
|
||||
return join q{}, $self->start_tag($opt),
|
||||
$self->_serialize(), $self->end_tag();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::ComplexType - complexType base class
|
||||
|
||||
=head1 Subclassing
|
||||
|
||||
package MyComplexType;
|
||||
use Class::Std::Storable
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::ComplexType);
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
\@elements_from,
|
||||
\%attributes_of,
|
||||
\%classes_of
|
||||
);
|
||||
|
||||
When subclassing, the following methods are created in the subclass:
|
||||
|
||||
=head2 new
|
||||
|
||||
Constructor. For your convenience, new will accept data for the object's
|
||||
properties in the following forms:
|
||||
|
||||
hash refs
|
||||
1) of scalars
|
||||
2) of list refs
|
||||
3) of hash refs
|
||||
4) of objects
|
||||
5) mixed stuff of all of the above
|
||||
|
||||
new() will set the data via the set_FOO methods to the object's element
|
||||
properties.
|
||||
|
||||
Data passed to new must comply to the object's structure or new() will
|
||||
complain. Objects passed must be of the expected type, or new() will
|
||||
complain, too.
|
||||
|
||||
Examples:
|
||||
|
||||
my $obj = MyClass->new({ MyName => $value });
|
||||
|
||||
my $obj = MyClass->new({
|
||||
MyName => {
|
||||
DeepName => $value
|
||||
},
|
||||
MySecondName => $value,
|
||||
});
|
||||
|
||||
my $obj = MyClass->new({
|
||||
MyName => [
|
||||
{ DeepName => $value },
|
||||
{ DeepName => $other_value },
|
||||
],
|
||||
MySecondName => $object,
|
||||
MyThirdName => [ $object1, $object2 ],
|
||||
});
|
||||
|
||||
To be correct, SOAP::WSDL::XSD::Typelib::ComplexType will create a START
|
||||
method, not new() - but new() will be created from Class::Std::Storable and
|
||||
behave like stated above.
|
||||
|
||||
=head2 set_FOO
|
||||
|
||||
A mutator method for every element property.
|
||||
|
||||
For your convenience, the set_FOO methods will accept all kind of data you
|
||||
can think of (and all combinations of them) as input - with the exception
|
||||
of GLOBS and filehandles.
|
||||
|
||||
This means you may set element properties by passing
|
||||
|
||||
a) objects
|
||||
b) scalars
|
||||
c) list refs
|
||||
d) hash refs
|
||||
e) mixed stuff of all of the above
|
||||
|
||||
Examples are similar to the examples provided for new() above.
|
||||
|
||||
=head1 Bugs and limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Incomplete API
|
||||
|
||||
Not all variants of XML Schema ComplexType definitions are supported yet.
|
||||
|
||||
Variants known to work are:
|
||||
|
||||
sequence
|
||||
all
|
||||
complexContent containing sequence/all definitions
|
||||
|
||||
=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 COPYING
|
||||
|
||||
This library is free software, you may distribute/modify it under the
|
||||
same terms as perl itself
|
||||
|
||||
=cut
|
||||
@@ -1,144 +0,0 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::XSD::Typelib::Element;
|
||||
use strict;
|
||||
|
||||
my %NAME;
|
||||
my %NILLABLE;
|
||||
my %REF;
|
||||
my %MIN_OCCURS;
|
||||
my %MAX_OCCURS;
|
||||
|
||||
# Class data - remember, we're the base class for a class factory or for
|
||||
# generated code...
|
||||
# use BLOCK: for scoping
|
||||
BLOCK: {
|
||||
my %method_lookup = (
|
||||
_name => \%NAME,
|
||||
_nillable => \%NILLABLE,
|
||||
_ref => \%REF,
|
||||
_minOccurs => \%MIN_OCCURS,
|
||||
_maxOccurs => \%MAX_OCCURS,
|
||||
);
|
||||
|
||||
no strict qw(refs);
|
||||
while (my ($name, $value) = each %method_lookup ) {
|
||||
*{ "__set$name" } = sub {
|
||||
my $class = ref $_[0] || $_[0];
|
||||
$value->{ $class } = $_[1];
|
||||
};
|
||||
*{ "__get$name" } = sub {
|
||||
my $class = ref $_[0] || $_[0];
|
||||
return $value->{ $class };
|
||||
};
|
||||
}
|
||||
};
|
||||
|
||||
sub start_tag {
|
||||
my ($self, $opt, $value) = @_;
|
||||
my $class = ref $self;
|
||||
my $ending = '>';
|
||||
my @attr_from = ();
|
||||
my $name = $opt->{ name } || $NAME{$class};
|
||||
$ending = '/>' if ($opt->{ empty });
|
||||
|
||||
if ($opt->{qualified}) {
|
||||
push @attr_from, 'xmlns="' . $self->get_xmlns . '"';
|
||||
}
|
||||
if ($opt->{ nil }) {
|
||||
return q{} if not $NILLABLE{ $class };
|
||||
push @attr_from, 'xsi:nil="true"';
|
||||
$ending = '/>';
|
||||
}
|
||||
return join q{ }, "<$name" , @attr_from , $ending;
|
||||
}
|
||||
|
||||
sub end_tag {
|
||||
my ($class, $opt) = (ref $_[0], $_[1]);
|
||||
my $name = $opt->{ name } || $NAME{$class};
|
||||
return "</$name>";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::Element - element base clase
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This example creates a class for this XML schema definition:
|
||||
|
||||
<element name="MyElement" type="xsd:string" nillable="1"
|
||||
minOccurs="1" maxOccurs="1"/>
|
||||
|
||||
package MyElement;
|
||||
use strict;
|
||||
use Class::Std::Storable;
|
||||
use base (
|
||||
'SOAP::WSDL::XSD::Typelib::Element',
|
||||
'SOAP::WSDL::XSD::Typelib::Builtin::string',
|
||||
);
|
||||
|
||||
__PACKAGE__->__set_name('MyElementName');
|
||||
__PACKAGE__->__set_nillable(1);
|
||||
__PACKAGE__->__set_minOccurs(1);
|
||||
__PACKAGE__->__set_maxOccurs(1);
|
||||
__PACKAGE__->__set_ref(0);
|
||||
|
||||
Now we create this XML schema definition type class:
|
||||
|
||||
<element name="MyElement2" ref="tns:MyElement"/>
|
||||
|
||||
package MyElement2;
|
||||
use strict;
|
||||
use Class::Std::Storable;
|
||||
use base (
|
||||
'SOAP::WSDL::XSD::Typelib::Element',
|
||||
'MyElement'
|
||||
);
|
||||
|
||||
__PACKAGE__->__set_name('MyElementName');
|
||||
__PACKAGE__->__set_nillable(0);
|
||||
__PACKAGE__->__set_ref(1);
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=over
|
||||
|
||||
=item * type="Foo"
|
||||
|
||||
Implemented via inheritance.
|
||||
|
||||
=item * ref="Foo"
|
||||
|
||||
Implemented via inheritance, too. Calling
|
||||
|
||||
__PACKAGE__->__set_ref(1) is highly encouraged, though it has no
|
||||
effect yet - it will probably be needed for serialization to XML
|
||||
Schema definitions some day.
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
=over
|
||||
|
||||
=item * minOccurs maxOccurs not implemented
|
||||
|
||||
These attributes are not yet supported, though they may be set as class
|
||||
properties via __PACKAGE__->__set_FOO methods.
|
||||
|
||||
=item * 'http://www.w3.org/2001/XMLSchema-instance prefix is hardcoded
|
||||
|
||||
The prefix for 'http://www.w3.org/2001/XMLSchema-instance (used as namespace
|
||||
for the {http://www.w3.org/2001/XMLSchema-instance}nil="true" attribute
|
||||
is hardcoded as 'xsi'.
|
||||
|
||||
You should definitly provide your XML envelope generator with the same prefix
|
||||
namespace combination (Default for SOAP::WSDL::Envelope).
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
@@ -1,132 +0,0 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::XSD::Typelib::SimpleType;
|
||||
use strict;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
|
||||
package SOAP::WSDL::XSD::Typelib::SimpleType::restriction;
|
||||
use strict;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use base qw(SOAP::WSDL::XSD::Typelib::SimpleType);
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType - simpleType base class
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module implements a base class for designing simple type classes
|
||||
modelling XML Schema simpleType definitions.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# example simpleType derived by restriction
|
||||
# XSD would be:
|
||||
# <simpleType name="MySimpleType">
|
||||
# <restriction base="xsd:string" />
|
||||
# </simpleType>
|
||||
package MySimpleType;
|
||||
use Class::Std::Storable;
|
||||
# restriction base implemented via inheritance
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use SOAP::WSDL::XSD::Typelib::SimpleType;
|
||||
use base qw(
|
||||
# derive by restriction
|
||||
'SOAP::WSDL::XSD::Typelib::SimpleType::restriction',
|
||||
# restriction base
|
||||
'SOAP::WSDL::XSD::Typelib::Builtin::string'
|
||||
);
|
||||
|
||||
# example simpleType derived by list.
|
||||
# XSD would be:
|
||||
# <simpleType name="MySimpleListType">
|
||||
# <list itemTipe="xsd:string" />
|
||||
# </simpleType>
|
||||
package MySimpleListType;
|
||||
use Class::Std::Storable;
|
||||
# restriction base implemented via inheritance
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use base ('SOAP::WSDL::XSD::Typelib::SimpleType',
|
||||
'SOAP::WSDL::XSD::Typelib::Builtin::list', # derive by list
|
||||
'SOAP::WSDL::XSD::Typelib::Builtin::string' # list itemType
|
||||
);
|
||||
|
||||
=head1 How to write your own simple type
|
||||
|
||||
Writing a simple type class is easy - all you have to do is setting up the
|
||||
base classes correctly.
|
||||
|
||||
The following rules apply:
|
||||
|
||||
=over
|
||||
|
||||
=item * simpleType derived via list
|
||||
|
||||
simpleType classes derived via list must inherit from these classes in
|
||||
exactly this order:
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::list # derive by list
|
||||
The::List::ItemType::Class # list itemType
|
||||
|
||||
The::List::ItemType::Class can either be a builtin class (see
|
||||
SOAP::WSDL::XSD::Builtin) or another simpleType class (any other class
|
||||
implementing the right methods is supported too, but not for the
|
||||
faint of heart).
|
||||
|
||||
=item * simpleType derived via restriction
|
||||
|
||||
simpleType classes derived via restriction must inherit from these classes in
|
||||
exactly this order:
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType # you may leave out this
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType::restriction # derive by retriction
|
||||
The::Restriction::Base::Class # resytriction base
|
||||
|
||||
The::Restriction::Base::Class can either be a builtin class (see
|
||||
SOAP::WSDL::XSD::Builtin) or another simpleType class.
|
||||
|
||||
The slight inconsistency between the these variants is caused by the
|
||||
restriction element, which has different meanings for simpleType and
|
||||
complexType definitions.
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
=over
|
||||
|
||||
=item * Thread safety
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType uses Class::Std::Storable which uses
|
||||
Class::Std. Class::Std is not thread safe, so
|
||||
SOAP::WSDL::XSD::Typelib::SimpleType is neither.
|
||||
|
||||
=item * union
|
||||
|
||||
union simple types are not supported yet.
|
||||
|
||||
=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 COPYING
|
||||
|
||||
This library is free software, you may distribute/modify it under the
|
||||
same terms as perl itself
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user