dinislage/SOAP-WSDL
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

import SOAP-WSDL 2.00_06 from CPAN

Browse Source 
git-cpan-module:   SOAP-WSDL
git-cpan-version:  2.00_06
git-cpan-authorid: MKUTTER
git-cpan-file:     authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_06.tar.gz
This commit is contained in:
Martin Kutter authored and Michael G. Schwern committed 2009-12-12 19:47:44 -08:00
1 parent a78d6d15b5
commit 25548e6296
45 files changed
+2227 -844
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

lib/SOAP/WSDL/XSD/ComplexType.pm
+120 -56
View File
@@ -57,8 +57,7 @@ sub init {
$self->SUPER::init( @args );
}
sub serialize
{
sub serialize {
my ($self, $name, $value, $opt) = @_;
$opt->{ indent } ||= q{};
@@ -74,7 +73,7 @@ sub serialize
$xml .= join q{ } , "<$name" , @{ $opt->{ attributes } };
delete $opt->{ attributes }; # don't propagate...
delete $opt->{ attributes }; # don't propagate...
if ( $opt->{ autotype }) {
my $ns = $self->get_targetNamespace();
@@ -120,39 +119,38 @@ sub serialize
return $xml;
}
sub explain
{
my ($self, $opt, $name ) = @_;
my $flavor = $self->get_flavor();
my $xml = '';
$xml .= $opt->{ indent } if ($opt->{ readable }); # add indentation
$xml .= q{'} . $name . q{' => };
sub explain {
my ($self, $opt, $name ) = @_;
my $flavor = $self->get_flavor();
return q{} if not $flavor; # empty complexType
$name ||= q{};
if ( ($flavor eq "sequence") or ($flavor eq "all") )
{
$xml .= "{\n";
$opt->{ indent } .= "\t";
return q{} if not $flavor; # empty complexType
$opt->{ indent } ||= q{ };
my $xml = q{};
$xml .= "$opt->{indent}\'$name'=> " if $name;
if ( ($flavor eq "sequence") or ($flavor eq "all") ) {
$xml .= "{\n";
$opt->{ indent } .= " ";
$xml .= join q{}, map { $_->explain( $opt ) }
@{ $self->get_element() };
$opt->{ indent } =~s/\t$//; # step back
$xml .= $opt->{ indent } . "},\n";
}
elsif ($flavor eq "complexContent")
{
$opt->{ indent } =~s/\s{2}$//; # step back
$xml .= "$opt->{ indent }},\n";
}
elsif ($flavor eq "complexContent")
{
}
elsif ($flavor eq "simpleContent")
{
}
else
{
warn "unknown complexType definition $flavor";
}
$xml .= "\n" if ($opt->{ readable } ); # add linebreak
return $xml;
}
elsif ($flavor eq "simpleContent")
{
warn "found unsupported complexType definition $flavor";
}
else
{
warn "found unsupported complexType definition $flavor";
}
return $xml;
}
sub to_typemap {
@@ -172,12 +170,12 @@ sub to_typemap {
return $txt;
}
sub toClass {
sub to_class {
my $self = shift;
my $opt = shift;
my $template = <<'EOT';
package [% class_prefix %]::[% self.get_name %];
package [% type_prefix %][% self.get_name %];
use strict;
use Class::Std::Storable;
use SOAP::WSDL::XSD::Typelib::ComplexType;
@@ -194,19 +192,38 @@ __PACKAGE__->_factory(
[% element.get_name %]
[% END %]) ],
{
[% FOREACH element=self.get_element %] [% element.get_name %] => \%[% element.get_name %]_of,
[% FOREACH element=self.get_element %][% element.get_name %] => \%[% element.get_name %]_of,
[% END %]
},
{
[%- FOREACH element=self.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 %] => '[% class_prefix %]::[% localname %]',
[%- END;
[%-
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 (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 %]
}
);
@@ -214,21 +231,68 @@ __PACKAGE__->_factory(
sub get_xmlns { '[% self.get_targetNamespace %]' }
1;
__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 (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
$opt->{ base_path } ||= '.';
require Template;
my $tt = Template->new(
RELATIVE => 1,
);
my $code = $tt->process( \$template, {
class_prefix => $opt->{ prefix },
self => $self,
nsmap => { reverse %{ $opt->{ wsdl }->get_xmlns() } },
},
$opt->{ output },
) or die $tt->error();
$self->SUPER::to_class($opt, $template);
}
sub _check_value {
lib/SOAP/WSDL/XSD/Element.pm
+87 -35
View File
@@ -43,8 +43,7 @@ sub first_complexType {
}
# serialize type instead...
sub serialize
{
sub serialize {
my ($self, $name, $value, $opt) = @_;
my $type;
my $typelib = $opt->{ typelib };
@@ -109,8 +108,7 @@ sub serialize
return $type->serialize( $name, $value, $opt );
}
sub explain
{
sub explain {
my ($self, $opt, $name) = @_;
my $type;
my $text = q{};
@@ -119,10 +117,12 @@ sub explain
if ($type = $self->first_simpleType() )
{
$text .= $type->explain( $opt, $self->get_name() );
return $text;
}
elsif ($type = $self->first_complexType() )
{
$text .= $type->explain( $opt, $self->get_name() )
$text .= $type->explain( $opt, $self->get_name() );
return $text;
}
# return if it's not a derived type - we don't handle
@@ -131,14 +131,17 @@ sub explain
# if we have a derived type, fetch type and explain
my ($prefix, $localname) = split /:/ , $self->get_type();
my %ns_map = reverse %{ $opt->{ namespace } };
my $ns = $ns_map{ $prefix };
my %ns_map = reverse %{ $opt->{ wsdl }->get_xmlns };
$type = $opt->{ wsdl }->first_types()->find_type(
$ns, $localname
$ns_map{ $prefix }, $localname
);
die "no type for $prefix:$localname ($ns)" if (not $type);
use Data::Dumper;
die "no type for $prefix:$localname ($ns_map{ $prefix })"
. Dumper $opt->{ wsdl }->first_types()->first_schema()->_DUMP
if (not $type);
return $text .= $type->explain( $opt, $self->get_name() );
return 'ERROR: '. $@;
@@ -150,10 +153,10 @@ sub to_typemap {
my $txt = q{};
my %nsmap = reverse %{ $opt->{ wsdl }->get_xmlns() };
my $type;
push @{ $opt->{path} }, $self->get_name();
# referenced types need type_prefix
if ( my $typename = $self->get_type() ) {
my ($prefix, $localname) = split /:/, $self->get_type();
my $ns = $nsmap{ $prefix };
@@ -166,18 +169,21 @@ sub to_typemap {
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";
@@ -194,7 +200,8 @@ sub to_typemap {
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();
my $flavor = $type->get_flavor()
|| 'UNKNOWN';
if ( $flavor eq 'sequence' ) {
$txt .= "# atomic complex type (sequence)\n";
$txt .= $type->to_typemap($opt). "\n";;
@@ -205,18 +212,22 @@ sub to_typemap {
$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 toClass {
sub to_class {
my $self = shift;
my $opt = shift;
my $template = <<'EOT';
package [% class_prefix %]::[% self.get_name %];
package [% element_prefix %][% self.get_name %];
use strict;
use Class::Std::Storable;
use SOAP::WSDL::XSD::Typelib::Element;
@@ -227,7 +238,7 @@ use base qw(
SOAP::WSDL::XSD::Typelib::Element
SOAP::WSDL::XSD::Typelib::SimpleType
[% type.flavor_class %]
[% type.base_class($class_prefix) %]
[% type.base_class($type_prefix) %]
);
[% ELSIF (type = self.first_complexType) %]
# atomic complexType
@@ -258,23 +269,24 @@ __PACKAGE__->_factory(
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 %]',
[% 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
[% (typename = self.get_type);
split_name = element.type.split(':');
#
[% split_name = self.get_type.split(':');
prefix = split_name.0;
localname = split_name.1;
-%]
[% IF (nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema');
IF (nsmap.$prefix == 'http://www.w3.org/2001/XMLSchema');
base_class = 'SOAP::WSDL::XSD::Typelib::Builtin::' _ localname ;
ELSE;
base_class = type_prefix _ '::' _ localname;
base_class = type_prefix _ localname;
-%]
use [% base_class %];
@@ -298,21 +310,61 @@ __PACKAGE__->__set_maxOccurs([% self.get_maxOccurs %]);
__PACKAGE__->__set_ref('[% self.get_ref %]');
1;
EOT
require Template;
my $tt = Template->new(
RELATIVE => 1,
);
my $code = $tt->process( \$template, {
class_prefix => $opt->{ prefix },
type_prefix => $opt->{ type_prefix },
self => $self,
nsmap => { reverse %{ $opt->{ wsdl }->get_xmlns() } },
},
$opt->{ output },
)
or die $tt->error();
__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;
lib/SOAP/WSDL/XSD/Primitive.pm
+1 -6
View File
@@ -40,13 +40,8 @@ sub serialize
sub explain
{
my ($self, $opt, $name ) = @_;
my $perl;
$opt->{ indent } ||= "";
$perl .= $opt->{ indent } if ($opt->{ readable });
$perl .= q{'} . $name . q{' => $someValue };
$perl .= "\n" if ($opt->{ readable });
return $perl;
return "$opt->{ indent }'$name' => \$someValue,\n"
}
sub toClass {
lib/SOAP/WSDL/XSD/SimpleType.pm
+32 -32
View File
@@ -5,43 +5,42 @@ use Class::Std::Storable;
use base qw(SOAP::WSDL::Base);
my %base_of :ATTR(:name<base> :default<()>);
my %flavor_of :ATTR(:name<flavor> :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' );
foreach my $attr (@attributes)
{
next if (not $attr->{ LocalName } eq 'restriction');
$self->base( $attr->{ Value } );
}
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' );
foreach my $attr (@attributes)
{
next if (not $attr->{ LocalName } eq 'list');
$self->set_base( $attr->{ Value } );
}
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' );
foreach my $attr (@attributes)
{
next if (not $attr->{ LocalName } eq 'memberTypes');
$self->set_base( [ split /\s/, $attr->{ Value } ] );
}
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
@@ -50,10 +49,9 @@ sub push_enumeration
my @attr = @_;
my @attributes = @_;
$self->set_flavor( 'enumeration' );
foreach my $attr (@attributes)
{
next if (not $attr->{ LocalName } eq 'value');
push @{ $enumeration_of{ ident $self } }, $attr->{ 'Value' };
for (@attributes) {
next if (not $_->{ LocalName } eq 'value');
push @{ $enumeration_of{ ident $self } }, $_->{ 'Value' };
}
}
@@ -115,11 +113,13 @@ sub explain {
sub _check_value {
my $self = shift;
}
# TODO: implement to_class based on template...
sub toClass {
sub to_class {
my $self = shift;
my $opt = shift;
my $class_prefix = $opt->{ prefix };
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'
lib/SOAP/WSDL/XSD/Typelib/Builtin/anySimpleType.pm
+7 -3
View File
@@ -1,8 +1,11 @@
package SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
use strict;
use warnings;
use Class::Std::Storable;
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anyType);
BEGIN {
use Class::Std::Storable;
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anyType);
}
my %value_of :ATTR(:get<value> :init_arg<value> :default<()>);
@@ -27,7 +30,8 @@ sub as_bool :BOOLIFY {
}
Class::Std::initialize(); # make :BOOLIFY overloading serializable
1;
__END__
lib/SOAP/WSDL/XSD/Typelib/Builtin/boolean.pm
+29 -6
View File
@@ -1,13 +1,34 @@
package SOAP::WSDL::XSD::Typelib::Builtin::boolean;
use strict;
use warnings;
use Class::Std::Storable;
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
# 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);
}
my %pattern_of :ATTR(:name<pattern> :default<()>);
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
my %value_of :ATTR(:get<value> :init_attr<value> :default<()>);
{
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;
};
}
my %pattern_of :ATTR(:name<pattern> :default<()>);
my %whiteSpace_of :ATTR(:name<whiteSpace> :default<()>);
my %value_of :ATTR(:get<value> :init_attr<value> :default<()>);
sub serialize {
my ($self, $opt) = @_;
@@ -33,6 +54,8 @@ sub set_value {
: 0;
}
Class::Std::initialize(); # make :BOOLIFY overloading serializable
1;
lib/SOAP/WSDL/XSD/Typelib/Builtin/int.pm
+20 -2
View File
@@ -1,9 +1,27 @@
package SOAP::WSDL::XSD::Typelib::Builtin::int;
use strict;
use warnings;
use Class::Std::Storable;
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::long);
# 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;
lib/SOAP/WSDL/XSD/Typelib/Builtin/integer.pm
+22 -2
View File
@@ -1,8 +1,28 @@
package SOAP::WSDL::XSD::Typelib::Builtin::integer;
use strict;
use warnings;
use Class::Std::Storable;
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::decimal);
# 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();
lib/SOAP/WSDL/XSD/Typelib/Builtin/long.pm
+21 -2
View File
@@ -1,8 +1,27 @@
package SOAP::WSDL::XSD::Typelib::Builtin::long;
use strict;
use warnings;
use Class::Std::Storable;
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::integer);
# 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;
lib/SOAP/WSDL/XSD/Typelib/Builtin/string.pm
+31 -10
View File
@@ -1,17 +1,37 @@
package SOAP::WSDL::XSD::Typelib::Builtin::string;
use strict;
use warnings;
use Class::Std::Storable;
# use HTML::Entities qw(encode_entities);
use base qw(SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType);
my %length_of :ATTR(:name<length> :default<()>);
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;
};
}
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{&amp;},
q{<} => q{&lt;},
@@ -20,6 +40,7 @@ my %char2entity = (
q{'} => q{&apos;},
);
sub serialize {
my ($self, $opt) = @_;
my $ident = ident $self;
lib/SOAP/WSDL/XSD/Typelib/ComplexType.pm
+124 -98
View File
@@ -16,18 +16,19 @@ my %CLASSES_OF;
# we store per-class elements.
# call as __PACKAGE__->_factory
sub _factory {
sub _factory {
my $class = shift;
$ELEMENTS_FROM{ $class } = shift;
$ATTRIBUTES_OF{ $class } = shift;
$CLASSES_OF{ $class } = shift;
no strict qw(refs);
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";
$type->isa('UNIVERSAL')
or eval "require $type"
or croak $@;
@@ -35,27 +36,40 @@ sub _factory {
*{ "$class\::set_$name" } = sub {
my ($self, $value) = @_;
# set to
# 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 with value for simple values
# c) New object with value for list values and list type
# d) List ref of new objects with value for list values and non-list type
# e) New object with values passed to new for HASH references
# 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) List ref of objects for list values (list of objects) and non-list type
# d) New object with values passed to new for HASH references
#
# Die on non-ARRAY/HASH references - if you can define semantics
# for GLOB references, feel free to add them.
$attribute_ref->{ ident $self } = (blessed $value)
$attribute_ref->{ ident $self } = blessed $value
? $value
: (ref $value ) ?
(ref $value eq 'ARRAY')
: ref $value
? ref $value eq 'ARRAY'
? $type->isa('SOAP::WSDL::XSD::Typelib::Builtin::list')
? $type->new({ value => $value })
: [ map { $type->new({ value => $_ }) } @{ $value } ]
: (ref $value eq 'HASH')
? $type->new( $value )
: die "Cannot use non-ARRAY/HASH as data"
: $type->new({ value => $value });
: [ map {
blessed($_)
? ($_->isa('SOAP::WSDL::XSD::Typelib::Builtin::anyType'))
? $_
: croak 'cannot use non-XSD object as value'
: $type->new({ value => $_ })
} @{ $value }
]
: ref $value eq 'HASH'
? $type->new( $value )
: die 'Cannot use non-ARRAY/HASH as data'
: $type->new({ value => $value });
};
*{ "$class\::add_$name" } = sub {
@@ -74,98 +88,110 @@ sub _factory {
# add to list
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\::_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 = $_;
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();
}
}
}
sub START {
my ($self, $ident, $args_of) = @_;
my $class = ref $self;
# 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 {}
: croak "unknown field $_ in $class";
# TODO maybe only warn for unknown fields ?
} keys %$args_of;
};
sub _get_elements {
my $self = shift;
my $class = ref $self;
my $ident = ident $self;
return map { $_->{ $ident } } @{ $ELEMENTS_FROM{ $class } };
}
# 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 ?
#
sub _serialize {
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 = $_;
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 => $_ } );
}
# 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 } });
}
sub serialize {
my ($self, $opt) = @_;
$opt ||= {};
# do we have a empty element ?
return $self->start_tag({ %$opt, empty => 1 })
if not @{ $ELEMENTS_FROM{ ref $self } };
return join q{}, $self->start_tag($opt),
$self->_serialize(), $self->end_tag();
}
1;
__END__
=pod
=head1 NAME
SOAP::WSDL::XSD::Typelib::ComplexType - ComplexType XML Schema definitions
=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
lib/SOAP/WSDL/XSD/Typelib/Element.pm
+5 -4
View File
@@ -40,7 +40,7 @@ sub start_tag {
my $class = ref $self;
my $ending = '>';
my @attr_from = ();
my $name = $opt->{ name } || $NAME{$class};
$ending = '/>' if ($opt->{ empty });
if ($opt->{qualified}) {
@@ -51,12 +51,13 @@ sub start_tag {
push @attr_from, 'xsi:nil="true"';
$ending = '/>';
}
return join q{ }, "<$NAME{$class}" , @attr_from , $ending;
return join q{ }, "<$name" , @attr_from , $ending;
}
sub end_tag {
my ($self, $class) = ($_[0], ref $_[0]);
return "</$NAME{$class}>";
my ($class, $opt) = (ref $_[0], $_[1]);
my $name = $opt->{ name } || $NAME{$class};
return "</$name>";
}
1;