import SOAP-WSDL 2.00_09 from CPAN
git-cpan-module: SOAP-WSDL git-cpan-version: 2.00_09 git-cpan-authorid: MKUTTER git-cpan-file: authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_09.tar.gz
This commit is contained in:
Martin Kutter
committed by
Michael G. Schwern
Michael G. Schwern
parent
312f3d6bbd
commit
a554e87f49
+3
-3
@@ -12,7 +12,7 @@ use XML::LibXML;
|
||||
|
||||
use Data::Dumper;
|
||||
use LWP::UserAgent;
|
||||
our $VERSION='2.00_08';
|
||||
our $VERSION='2.00_09';
|
||||
|
||||
my %no_dispatch_of :ATTR(:name<no_dispatch>);
|
||||
my %wsdl_of :ATTR(:name<wsdl>);
|
||||
@@ -565,7 +565,7 @@ Passing in item => [1,2,3] could serialize to
|
||||
<item>1 2</item><item>3</item>
|
||||
<item>1</item><item>2 3</item>
|
||||
|
||||
Ambiguos data can be avoided by passing an objects as data.
|
||||
Ambiguos data can be avoided by providing data as objects.
|
||||
|
||||
=item * XML Schema facets
|
||||
|
||||
@@ -615,7 +615,7 @@ the same terms as perl itself
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
@@ -34,10 +34,9 @@ sub __create_methods {
|
||||
$_->new( $data );
|
||||
} @{ $parts_of{ $method } };
|
||||
|
||||
$self->call( $method, @param );
|
||||
return $self->SUPER::call( $method, @param );
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -5,27 +5,8 @@ use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
=pod
|
||||
|
||||
=head2 new
|
||||
|
||||
=over
|
||||
|
||||
=item SYNOPSIS
|
||||
|
||||
my $obj = ->new();
|
||||
|
||||
=item DESCRIPTION
|
||||
|
||||
Constructor.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $args = shift;
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver }
|
||||
};
|
||||
@@ -39,9 +20,9 @@ sub class_resolver {
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my $self = shift;
|
||||
my ($self, $parser) = @_;
|
||||
|
||||
$self->{ data } = undef;
|
||||
delete $self->{ data };
|
||||
|
||||
my $characters;
|
||||
my $current = undef;
|
||||
@@ -50,7 +31,6 @@ sub _initialize {
|
||||
my $path = []; # current path (without
|
||||
# number)
|
||||
my $skip = 0; # skip elements
|
||||
my $parser = XML::Parser::Expat->new();
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_localname, $_element, $_method,
|
||||
@@ -78,17 +58,16 @@ sub _initialize {
|
||||
or die "Cannot resolve class for "
|
||||
. join('/', @{ $path }) . " via $self->{ class_resolver }";
|
||||
|
||||
if ($_class eq '__SKIP__') {
|
||||
$skip = join '/', @{ $path };
|
||||
return;
|
||||
}
|
||||
# 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
|
||||
# TODO replace with UNIVERSAL->isa()
|
||||
# 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...
|
||||
|
||||
@@ -155,18 +134,17 @@ sub _initialize {
|
||||
}
|
||||
|
||||
sub parse {
|
||||
$_[0]->_initialize->parse( $_[1] );
|
||||
$_[0]->_initialize( XML::Parser::Expat->new() )->parse( $_[1] );
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
$_[0]->_initialize->parsefile( $_[1] );
|
||||
$_[0]->_initialize( XML::Parser::Expat->new() )->parsefile( $_[1] );
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
my $self = shift;
|
||||
return $self->{ data };
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -2,148 +2,25 @@
|
||||
package SOAP::WSDL::Expat::MessageStreamParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use XML::Parser::Expat;
|
||||
use SOAP::WSDL::Expat::MessageParser;
|
||||
use base qw(SOAP::WSDL::Expat::MessageParser);
|
||||
|
||||
=pod
|
||||
|
||||
=head2 new
|
||||
|
||||
=over
|
||||
|
||||
=item SYNOPSIS
|
||||
|
||||
my $obj = ->new();
|
||||
|
||||
=item DESCRIPTION
|
||||
|
||||
Constructor.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
class_resolver => shift->{ class_resolver }
|
||||
};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub class_resolver {
|
||||
sub parse_start {
|
||||
my $self = shift;
|
||||
$self->{ class_resolver } = shift;
|
||||
$self->{ parser } = $_[0]->_initialize( XML::Parser::ExpatNB->new() );
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $xml = shift;
|
||||
$self->{ data } = undef;
|
||||
|
||||
my $characters;
|
||||
my $current = '__STOP__';
|
||||
my $ignore = [ 'Envelope', 'Body' ];
|
||||
my $list = [];
|
||||
my $namespace = {};
|
||||
my $path = [];
|
||||
my $parser = XML::Parser::ExpatNB->new();
|
||||
sub init;
|
||||
*init = \&parse_start;
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
my ($parser, $element, %attrs) = @_;
|
||||
my ($prefix, $localname) = split m{:}xms , $element;
|
||||
# for non-prefixed elements
|
||||
if (not $localname) {
|
||||
$localname = $element;
|
||||
$prefix = q{};
|
||||
}
|
||||
# ignore top level elements
|
||||
if (@{ $ignore } && $localname eq $ignore->[0]) {
|
||||
shift @{ $ignore };
|
||||
return;
|
||||
}
|
||||
# empty characters
|
||||
$characters = q{};
|
||||
|
||||
push @{ $path }, $localname; # step down...
|
||||
push @{ $list }, $current; # remember current
|
||||
|
||||
# resolve class of this element
|
||||
my $class = $self->{ class_resolver }->get_class( $path )
|
||||
or die "Cannot resolve class for "
|
||||
. join('/', @{ $path }) . " via $self->{ class_resolver }";
|
||||
|
||||
# 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
|
||||
*{ "$class\::new" }{ CODE }
|
||||
or eval "require $class" ## no critic qw(ProhibitStringyEval)
|
||||
or die $@;
|
||||
}
|
||||
# create object
|
||||
# set current object
|
||||
$current = $class->new({ %attrs });
|
||||
|
||||
# remember top level element
|
||||
defined $self->{ data }
|
||||
or ($self->{ data } = $current);
|
||||
},
|
||||
Char => sub {
|
||||
$characters .= $_[1];
|
||||
},
|
||||
End => sub {
|
||||
my $element = $_[1];
|
||||
|
||||
my ($prefix, $localname) = split m{:}xms , $element;
|
||||
# for non-prefixed elements
|
||||
if (not $localname) {
|
||||
$localname = $element;
|
||||
$prefix = q{};
|
||||
}
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
return if not ref $list->[-1];
|
||||
|
||||
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
|
||||
my $method = "add_$localname";
|
||||
|
||||
$list->[-1]->$method( $current );
|
||||
|
||||
# step up in path
|
||||
pop @{ $path };
|
||||
|
||||
# step up in object hierarchy...
|
||||
$current = pop @{ $list };
|
||||
}
|
||||
);
|
||||
|
||||
return $parser;
|
||||
sub parse_more {
|
||||
$_[0]->{ parser }->parse_more( $_[1] );
|
||||
}
|
||||
|
||||
sub get_data {
|
||||
my $self = shift;
|
||||
return $self->{ data };
|
||||
sub parse_done {
|
||||
$_[0]->{ parser }->parse_done();
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
@@ -174,15 +51,7 @@ 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
|
||||
See SOAP::WSDL::Expat::MessageParser
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
|
||||
@@ -192,17 +192,17 @@ my %[% element.get_name %]_of :ATTR(:get<[% element.get_name %]>);
|
||||
[% END %]
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
[ qw([% FOREACH element=self.get_element -%]
|
||||
[% element.get_name %]
|
||||
[ 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 %][% element.get_name %] => \%[% element.get_name %]_of,
|
||||
[% END %]
|
||||
},
|
||||
{
|
||||
[%-
|
||||
[%-
|
||||
FOREACH element=self.get_element;
|
||||
IF (element.get_type);
|
||||
IF (element.get_type); # element type="..."
|
||||
split_name = element.get_type.split(':');
|
||||
prefix = split_name.0;
|
||||
localname = split_name.1;
|
||||
@@ -210,8 +210,13 @@ __PACKAGE__->_factory(
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[%- END;
|
||||
ELSIF (simpleType = element.first_simpleType);
|
||||
[%- 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
|
||||
@@ -269,7 +274,12 @@ methods:
|
||||
[% ELSE -%]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[%- END;
|
||||
ELSIF (simpleType = element.first_simpleType);
|
||||
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;
|
||||
|
||||
@@ -90,8 +90,8 @@ sub serialize {
|
||||
elsif (my $ref_name = $ref_of{ $ident }) { # ref
|
||||
my ($prefix, $localname) = split /:/ , $ref_name;
|
||||
my $ns = $ns_map{ $prefix };
|
||||
$type = $typelib->find_type( $ns, $localname );
|
||||
die "no type for $prefix:$localname" if (not $type);
|
||||
$type = $typelib->find_element( $ns, $localname );
|
||||
die "no element for ref $prefix:$localname" if (not $type);
|
||||
return $type->serialize( $name, $value, $opt );
|
||||
}
|
||||
|
||||
@@ -130,6 +130,12 @@ sub explain {
|
||||
}
|
||||
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.
|
||||
@@ -152,7 +158,7 @@ sub explain {
|
||||
delete $opt->{ anonymous };
|
||||
return $text .= $type->explain( $opt, undef );
|
||||
}
|
||||
return $text .= $type->explain( $opt, $self->get_name() );
|
||||
return $text .= $type->explain( $opt, $name || $self->get_name() );
|
||||
return 'ERROR: '. $@;
|
||||
}
|
||||
|
||||
@@ -240,6 +246,7 @@ package [% element_prefix %][% self.get_name %];
|
||||
use strict;
|
||||
use Class::Std::Storable;
|
||||
use SOAP::WSDL::XSD::Typelib::Element;
|
||||
|
||||
[% IF (type = self.first_simpleType) %]
|
||||
# <element name="[% self.get_name %]"><simpleType> definition
|
||||
use SOAP::WSDL::XSD::Typelib::SimpleType;
|
||||
@@ -249,6 +256,17 @@ use base qw(
|
||||
[% 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
|
||||
@@ -263,7 +281,7 @@ my %[% element.get_name %]_of :ATTR(:get<[% element.get_name %]>);
|
||||
[% END %]
|
||||
|
||||
__PACKAGE__->_factory(
|
||||
[ qw([% FOREACH element = type.get_element %]
|
||||
[ qw([% FOREACH element = type.get_element %]
|
||||
[% element.get_name %]
|
||||
[% END %]) ],
|
||||
{
|
||||
@@ -276,10 +294,10 @@ __PACKAGE__->_factory(
|
||||
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 %]',
|
||||
[% element.get_name %] => 'SOAP::WSDL::XSD::Typelib::Builtin::[% localname %]',
|
||||
[% ELSE %]
|
||||
[% element.get_name %] => '[% type_prefix %][% localname %]',
|
||||
[% END %]
|
||||
[% END %]
|
||||
[% END %]
|
||||
}
|
||||
);
|
||||
@@ -304,10 +322,6 @@ use base qw(
|
||||
SOAP::WSDL::XSD::Typelib::Element
|
||||
[% base_class %]
|
||||
);
|
||||
[% ELSIF (element = self.get_ref)
|
||||
%]
|
||||
# element ref"element" definition
|
||||
# Sorry, we don't handle this yet...
|
||||
[% END %]
|
||||
|
||||
sub get_xmlns { '[% self.get_targetNamespace %]' }
|
||||
|
||||
@@ -7,6 +7,7 @@ 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<()>);
|
||||
|
||||
@@ -29,6 +29,13 @@ 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
|
||||
|
||||
|
||||
|
||||
@@ -40,7 +40,7 @@ sub serialize {
|
||||
, $self->end_tag($opt);
|
||||
}
|
||||
|
||||
sub as_num :NUMERIFY {
|
||||
sub as_num :NUMERIFY :BOOLIFY {
|
||||
return $_[0]->get_value();
|
||||
}
|
||||
|
||||
|
||||
@@ -36,10 +36,10 @@ BEGIN {
|
||||
|
||||
sub set_value {
|
||||
# use set_value from base class if we have a XML-DateTime format
|
||||
#2037-12-31T00:00:00.0000000+01:00
|
||||
#2037-12-31+01:00
|
||||
if (
|
||||
$_[1] =~ m{ ^\d{4} \- \d{2} \- \d{2}
|
||||
(:? [\+\-] \d{2} \: \d{2} )?
|
||||
(:? [\+\-] \d{2} \: \d{2} )?$
|
||||
}xms
|
||||
) {
|
||||
$_[0]->SUPER::set_value($_[1])
|
||||
|
||||
@@ -46,16 +46,19 @@ sub set_value {
|
||||
$_[0]->SUPER::set_value($_[1])
|
||||
}
|
||||
# use a combination of strptime and strftime for converting the date
|
||||
# strptime does not emit timezone info, so we're pretty fucked up here.
|
||||
#
|
||||
# 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...
|
||||
my @time_from = map { ! defined $_ ? 0 : $_ } strptime($_[1]);
|
||||
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);
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@@ -22,26 +22,3 @@ BEGIN {
|
||||
};
|
||||
}
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::XSD::Typelib::Builtin::unsignedLong - unsigned long integer objects
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Subclass of nonNegativeInteger.
|
||||
|
||||
=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
|
||||
@@ -40,15 +40,13 @@ sub _factory {
|
||||
*{ "$class\::set_$name" } = sub {
|
||||
my ($self, $value) = @_;
|
||||
|
||||
=pod
|
||||
|
||||
=for developers
|
||||
|
||||
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
|
||||
@@ -92,7 +90,7 @@ is not that easy:
|
||||
? $type->new( $value )
|
||||
: $is_ref eq $type
|
||||
? $value
|
||||
: die 'Cannot use non-ARRAY/HASH as data'
|
||||
: die croak "cannot use $is_ref reference as value for $name - $type required"
|
||||
: $type->new({ value => $value });
|
||||
};
|
||||
|
||||
@@ -114,70 +112,69 @@ is not that easy:
|
||||
return push @{ $attribute_ref->{ $ident } }, $value;
|
||||
};
|
||||
|
||||
*{ "$class\::START" } = sub {
|
||||
my ($self, $ident, $args_of) = @_;
|
||||
|
||||
# iterate over keys of arguments
|
||||
# and call set appropriate field in clase
|
||||
map { ($ATTRIBUTES_OF{ $class }->{ $_ })
|
||||
? do {
|
||||
my $method = "set_$_";
|
||||
$self->$method( $args_of->{ $_ } );
|
||||
}
|
||||
: $_ =~ m{ \A # beginning of string
|
||||
xmlns # xmlns
|
||||
}xms
|
||||
? do {}
|
||||
: do { use Data::Dumper;
|
||||
croak "unknown field $_ in $class. Valid fields are "
|
||||
. join(', ', @{ $ELEMENTS_FROM{ $class } }) . "\n"
|
||||
. Dumper @_ };
|
||||
# TODO maybe only warn for unknown fields ?
|
||||
|
||||
} keys %$args_of;
|
||||
};
|
||||
|
||||
# this serialize method works fine for <all> and <sequence>
|
||||
# complextypes, as well as for <restriction><all> or
|
||||
# <restriction><sequence>.
|
||||
# But what about choice, group, extension ?
|
||||
#
|
||||
}
|
||||
|
||||
*{ "$class\::START" } = sub {
|
||||
my ($self, $ident, $args_of) = @_;
|
||||
# iterate over keys of arguments
|
||||
# and call set appropriate field in clase
|
||||
map { ($ATTRIBUTES_OF{ $class }->{ $_ })
|
||||
? do {
|
||||
my $method = "set_$_";
|
||||
$self->$method( $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 %$args_of;
|
||||
return $self;
|
||||
};
|
||||
|
||||
|
||||
# this serialize method works fine for <all> and <sequence>
|
||||
# complextypes, as well as for <restriction><all> or
|
||||
# <restriction><sequence>.
|
||||
# But what about choice, group, 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 };
|
||||
|
||||
if (defined $element) {
|
||||
$element = [ $element ]
|
||||
if not ref $element eq 'ARRAY';
|
||||
my $name = $_;
|
||||
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 } });
|
||||
};
|
||||
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) = @_;
|
||||
@@ -191,7 +188,7 @@ is not that easy:
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
@@ -202,6 +199,81 @@ __END__
|
||||
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user