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

import SOAP-WSDL 2.00.07 from CPAN

Browse Source 
git-cpan-module:   SOAP-WSDL
git-cpan-version:  2.00.07
git-cpan-authorid: MKUTTER
git-cpan-file:     authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00.07.tar.gz
This commit is contained in:
Martin Kutter
2009-12-12 19:48:57 -08:00
committed by Michael G. Schwern
parent 3de318be40
commit bfc3247583
229 changed files with 16685 additions and 2064 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lib/SOAP/WSDL/Expat/Base.pm
+1 -1
View File
@@ -6,7 +6,7 @@ use XML::Parser::Expat;
# TODO: convert to Class::Std::Fast based class - hash based classes suck.
use version; our $VERSION = qv('2.00.05');
use version; our $VERSION = qv('2.00.07');
sub new {
my ($class, $arg_ref) = @_;
lib/SOAP/WSDL/Expat/Message2Hash.pm
+1 -1
View File
@@ -4,7 +4,7 @@ use strict;
use warnings;
use base qw(SOAP::WSDL::Expat::Base);
use version; our $VERSION = qv('2.00.05');
use version; our $VERSION = qv('2.00.07');
sub _initialize {
my ($self, $parser) = @_;
lib/SOAP/WSDL/Expat/MessageParser.pm
+18 -11
View File
@@ -9,7 +9,7 @@ use base qw(SOAP::WSDL::Expat::Base);
BEGIN { require Class::Std::Fast };
use version; our $VERSION = qv('2.00.05');
use version; our $VERSION = qv('2.00.07');
# GLOBALS
my $OBJECT_CACHE_REF = Class::Std::Fast::OBJECT_CACHE_REF();
@@ -108,7 +108,10 @@ sub _initialize {
return;
}
)
: ();
: (
0 => sub { $depth++ },
1 => sub { $depth++ },
);
# use "globals" for speed
my ($_prefix, $_method, $_class, $_leaf) = ();
@@ -137,11 +140,14 @@ sub _initialize {
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 };
$_class = $self->{ class_resolver }->get_class( $path );
if ($_class eq '__SKIP__') {
if (! defined($_class) and $self->{ strict }) {
die "Cannot resolve class for "
. join('/', @{ $path }) . " via " . $self->{ class_resolver };
}
if (! defined($_class) or ($_class eq '__SKIP__') ) {
$skip = join('/', @{ $path });
$_[0]->setHandlers( Char => undef );
return;
@@ -233,6 +239,9 @@ sub _initialize {
# empty characters
$characters = q{};
# stop believing we're a leaf node
$_leaf = 0;
# return if there's only one elment - can't set it in parent ;-)
# but set as root element if we don't have one already.
if (not defined $list->[-1]) {
@@ -254,8 +263,6 @@ sub _initialize {
$current = pop @$list; # step up in object hierarchy
$_leaf = 0; # stop believing we're a leaf node
return;
}
);
@@ -323,10 +330,10 @@ the same terms as perl itself
=head1 Repository information
$Id: MessageParser.pm 728 2008-07-13 19:28:50Z kutterma $
$Id: MessageParser.pm 795 2009-02-21 00:04:29Z kutterma $
$LastChangedDate: 2008-07-13 21:28:50 +0200 (So, 13 Jul 2008) $
$LastChangedRevision: 728 $
$LastChangedDate: 2009-02-21 01:04:29 +0100 (Sa, 21 Feb 2009) $
$LastChangedRevision: 795 $
$LastChangedBy: kutterma $
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
lib/SOAP/WSDL/Expat/MessageStreamParser.pm
+3 -3
View File
@@ -6,7 +6,7 @@ use XML::Parser::Expat;
use SOAP::WSDL::Expat::MessageParser;
use base qw(SOAP::WSDL::Expat::MessageParser);
use version; our $VERSION = qv('2.00.05');
use version; our $VERSION = qv('2.00.07');
sub parse_start {
my $self = shift;
@@ -69,9 +69,9 @@ the same terms as perl itself
=head1 REPOSITORY INFORMATION
$Rev: 728 $
$Rev: 795 $
$LastChangedBy: kutterma $
$Id: MessageStreamParser.pm 728 2008-07-13 19:28:50Z kutterma $
$Id: MessageStreamParser.pm 795 2009-02-21 00:04:29Z kutterma $
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageStreamParser.pm $
=cut
lib/SOAP/WSDL/Expat/WSDLParser.pm
+157 -126
View File
@@ -5,7 +5,7 @@ use Carp;
use SOAP::WSDL::TypeLookup;
use base qw(SOAP::WSDL::Expat::Base);
use version; our $VERSION = qv('2.00.05');
use version; our $VERSION = qv('2.00.07');
#
# Import child elements of a WSDL / XML Schema tree into the current tree
@@ -18,33 +18,38 @@ use version; our $VERSION = qv('2.00.05');
#
sub _import_children {
my ($self, $name, $imported, $importer, $import_namespace) = @_;
my ( $self, $name, $imported, $importer, $import_namespace ) = @_;
my $targetNamespace = $importer->get_targetNamespace();
my $push_method = "push_$name";
my $get_method = "get_$name";
my $default_namespace = $imported->get_xmlns()->{ '#default' };
my $targetNamespace = $importer->get_targetNamespace();
my $push_method = "push_$name";
my $get_method = "get_$name";
my $default_namespace = $imported->get_xmlns()->{'#default'};
no strict qw(refs);
my $value_ref = $imported->$get_method();
if ($value_ref) {
$value_ref = [ $value_ref ] if (not ref $value_ref eq 'ARRAY');
$value_ref = [$value_ref] if ( not ref $value_ref eq 'ARRAY' );
for ( @{$value_ref} ) {
for (@{ $value_ref }) {
# fixup namespace - new parent may be from different namespace
if (defined ($default_namespace)) {
if ( defined($default_namespace) ) {
my $xmlns = $_->get_xmlns();
# it's a hash ref, so we can just update values
if (! defined $xmlns->{ '#default'}) {
$xmlns->{ '#default' } = $default_namespace;
if ( !defined $xmlns->{'#default'} ) {
$xmlns->{'#default'} = $default_namespace;
}
}
# fixup targetNamespace, but don't override
$_->set_targetNamespace( $import_namespace )
if ( ($import_namespace ne $targetNamespace) && ! $_->get_targetNamespace);
$_->set_targetNamespace($import_namespace)
if ( ( $import_namespace ne $targetNamespace )
&& !$_->get_targetNamespace );
# update parent...
$_->set_parent( $importer );
$_->set_parent($importer);
# push elements into importing WSDL
$importer->$push_method($_);
@@ -53,225 +58,254 @@ sub _import_children {
}
sub _import_namespace_definitions {
my $self = shift;
my $arg_ref = shift;
my $importer = $arg_ref->{ importer };
my $imported = $arg_ref->{ imported };
my $self = shift;
my $arg_ref = shift;
my $importer = $arg_ref->{importer};
my $imported = $arg_ref->{imported};
# import namespace definitions, too
my $importer_ns_of = $importer->get_xmlns();
my %xmlns_of = %{ $imported->get_xmlns() };
my %xmlns_of = %{$imported->get_xmlns()};
# it's a hash ref, we can just add to.
# TODO: check whether prefix is already taken.
# TODO: check wheter URI is the better key.
while (my ($prefix, $url) = each %xmlns_of) {
$importer_ns_of->{ $prefix } = $url;
# TODO: check whether URI is the better key.
while ( my ( $prefix, $url ) = each %xmlns_of ) {
if ( exists( $importer_ns_of->{$prefix} ) ) {
# warn "$prefix already exists";
next;
}
$importer_ns_of->{$prefix} = $url;
}
}
sub xml_schema_import {
my $self = shift;
my $schema = shift;
my $parser = $self->clone();
my %attr_of = @_;
my $import_namespace = $attr_of{ namespace };
my $self = shift;
my $schema = shift;
my $parser = $self->clone();
my %attr_of = @_;
my $import_namespace = $attr_of{namespace};
if (not $attr_of{schemaLocation}) {
warn "cannot import document for namespace >$import_namespace< without location";
if ( not $attr_of{schemaLocation} ) {
warn
"cannot import document for namespace >$import_namespace< without location";
return;
}
if (not $self->get_uri) {
die "cannot import document from namespace >$import_namespace< without base uri. Use >parse_uri< or >set_uri< to set one."
if ( not $self->get_uri ) {
die
"cannot import document from namespace >$import_namespace< without base uri. Use >parse_uri< or >set_uri< to set one.";
}
my $uri = URI->new_abs($attr_of{schemaLocation}, $self->get_uri() );
my $uri = URI->new_abs( $attr_of{schemaLocation}, $self->get_uri() );
my $imported = $parser->parse_uri($uri);
# might already be imported - parse_uri just returns in this case
return if not defined $imported;
$self->_import_namespace_definitions({
importer => $schema,
imported => $imported,
});
$self->_import_namespace_definitions( {
importer => $schema,
imported => $imported,
} );
for my $name ( qw(type element group attribute attributeGroup) ) {
$self->_import_children( $name, $imported, $schema, $import_namespace);
for my $name (qw(type element group attribute attributeGroup)) {
$self->_import_children( $name, $imported, $schema,
$import_namespace );
}
}
sub wsdl_import {
my $self = shift;
my $definitions = shift;
my $parser = $self->clone();
my %attr_of = @_;
my $import_namespace = $attr_of{ namespace };
my $self = shift;
my $definitions = shift;
my $parser = $self->clone();
my %attr_of = @_;
my $import_namespace = $attr_of{namespace};
if (not $attr_of{location}) {
warn "cannot import document for namespace >$import_namespace< without location";
if ( not $attr_of{location} ) {
warn
"cannot import document for namespace >$import_namespace< without location";
return;
}
if (not $self->get_uri) {
die "cannot import document from namespace >$import_namespace< without base uri. Use >parse_uri< or >set_uri< to set one."
if ( not $self->get_uri ) {
die
"cannot import document from namespace >$import_namespace< without base uri. Use >parse_uri< or >set_uri< to set one.";
}
my $uri = URI->new_abs($attr_of{location}, $self->get_uri() );
my $uri = URI->new_abs( $attr_of{location}, $self->get_uri() );
my $imported = $parser->parse_uri($uri);
# might already be imported - parse_uri just returns in this case
return if not defined $imported;
$self->_import_namespace_definitions({
importer => $definitions,
imported => $imported,
});
$self->_import_namespace_definitions( {
importer => $definitions,
imported => $imported,
} );
for my $name ( qw(types message binding portType service) ) {
$self->_import_children( $name, $imported, $definitions, $import_namespace);
for my $name (qw(types message binding portType service)) {
$self->_import_children( $name, $imported, $definitions,
$import_namespace );
}
}
sub _initialize {
my ($self, $parser) = @_;
my ( $self, $parser ) = @_;
# init object data
$self->{ parser } = $parser;
delete $self->{ data };
$self->{parser} = $parser;
delete $self->{data};
# setup local variables for keeping temp data
my $characters = undef;
my $current = undef;
my $list = []; # node list
my $characters = undef;
my $current = undef;
my $list = []; # node list
my $elementFormQualified = 1; # default for WSDLs, schema may override
# TODO skip non-XML Schema namespace tags
$parser->setHandlers(
Start => sub {
# handle attrs as list - expat uses dual-vars for looking
# up namespace information, and hash keys don't allow dual vars...
my ($parser, $localname, @attrs) = @_;
my ( $parser, $localname, @attrs ) = @_;
$characters = q{};
my $action = SOAP::WSDL::TypeLookup->lookup(
$parser->namespace($localname),
$localname
);
my $action =
SOAP::WSDL::TypeLookup->lookup( $parser->namespace($localname),
$localname );
return if not $action;
if ($action->{ type } eq 'CLASS') {
if ( $action->{type} eq 'CLASS' ) {
eval "require $action->{ class }";
croak $@ if ($@);
my $obj = $action->{ class }->new({
parent => $current,
my $obj = $action->{class}->new( {
parent => $current,
namespace => $parser->namespace($localname),
})
->init( _fixup_attrs( $parser, @attrs ) );
defined($current)
? ( xmlns => $current->get_xmlns() )
: ()} )->init( _fixup_attrs( $parser, @attrs ) );
if ($current) {
if ( defined $list->[-1]
&& $list->[-1]->isa('SOAP::WSDL::XSD::Schema') ) {
$elementFormQualified =
$list->[-1]->get_elementFormDefault() eq
'qualified';
}
# inherit namespace, but don't override
$obj->set_targetNamespace( $current->get_targetNamespace() )
if not $obj->get_targetNamespace();
if ($elementFormQualified) {
$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 );
$current->$method($obj);
# remember element for stepping back
push @{ $list }, $current;
push @{$list}, $current;
}
# set new element (step down)
$current = $obj;
}
elsif ($action->{ type } eq 'PARENT') {
$current->init( _fixup_attrs($parser, @attrs) );
elsif ( $action->{type} eq 'PARENT' ) {
$current->init( _fixup_attrs( $parser, @attrs ) );
}
elsif ($action->{ type } eq 'METHOD') {
my $method = $action->{ method };
elsif ( $action->{type} eq 'METHOD' ) {
my $method = $action->{method};
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)
);
$current->$method(
defined $action->{value}
? ref $action->{value}
? @{$action->{value}}
: ( $action->{value} )
: _fixup_attrs( $parser, @attrs ) );
}
elsif ($action->{type} eq 'HANDLER') {
my $method = $self->can($action->{method});
$method->($self, $current, @attrs);
elsif ( $action->{type} eq 'HANDLER' ) {
my $method = $self->can( $action->{method} );
$method->( $self, $current, @attrs );
}
else {
# TODO replace by hash lookup of known namespaces.
my $namespace = $parser->namespace($localname) || q{};
my $part = $namespace eq 'http://schemas.xmlsoap.org/wsdl/'
? 'WSDL 1.1'
: 'XML Schema';
my $part =
$namespace eq 'http://schemas.xmlsoap.org/wsdl/'
? 'WSDL 1.1'
: 'XML Schema';
warn "$part element <$localname> is not implemented yet"
if ($localname !~m{ \A (:? annotation | documentation ) \z }xms );
if ( $localname !~
m{ \A (:? annotation | documentation ) \z }xms );
}
return;
},
Char => sub { $characters .= $_[1]; return; },
Char => sub { $characters .= $_[1]; return; },
End => sub {
my ($parser, $localname) = @_;
my ( $parser, $localname ) = @_;
my $action = SOAP::WSDL::TypeLookup->lookup(
$parser->namespace( $localname ),
$localname
) || {};
my $action =
SOAP::WSDL::TypeLookup->lookup( $parser->namespace($localname),
$localname )
|| {};
if (! defined $list->[-1]) {
$self->{ data } = $current;
if ( !defined $list->[-1] ) {
$self->{data} = $current;
return;
}
return if not ($action->{ type });
if ( $action->{ type } eq 'CLASS' ) {
$current = pop @{ $list };
return if not( $action->{type} );
if ( $action->{type} eq 'CLASS' ) {
$current = pop @{$list};
if ( defined $list->[-1] && $list->[-1]->isa('SOAP::WSDL::XSD::Schema') ) {
$elementFormQualified = 1;
}
}
elsif ($action->{ type } eq 'CONTENT' ) {
my $method = $action->{ method };
elsif ( $action->{type} eq 'CONTENT' ) {
my $method = $action->{method};
# normalize whitespace
$characters =~s{ ^ \s+ (.+) \s+ $ }{$1}xms;
$characters =~s{ \s+ }{ }xmsg;
$characters =~ s{ ^ \s+ (.+) \s+ $ }{$1}xms;
$characters =~ s{ \s+ }{ }xmsg;
no strict qw(refs);
$current->$method( $characters );
$current->$method($characters);
}
return;
}
);
} );
return $parser;
}
# make attrs SAX style
sub _fixup_attrs {
my ($parser, @attrs) = @_;
my ( $parser, @attrs ) = @_;
my @attr_key_from = ();
my @attr_key_from = ();
my @attr_value_from = ();
while (@attrs) {
push @attr_key_from, shift @attrs;
push @attr_key_from, shift @attrs;
push @attr_value_from, shift @attrs;
}
@@ -281,20 +315,18 @@ sub _fixup_attrs {
#
# add namespaces before attributes: Attributes may be namespace-qualified
#
push @attrs_from, map {
{
Name => "xmlns:$_",
Value => $parser->expand_ns_prefix( $_ ),
push @attrs_from, map { {
Name => "xmlns:$_",
Value => $parser->expand_ns_prefix($_),
LocalName => $_
}
} $parser->new_ns_prefixes();
push @attrs_from, map {
{
push @attrs_from, map { {
Name => defined $parser->namespace($_)
? $parser->namespace($_) . '|' . $_
: '|' . $_,
Value => shift @attr_value_from, # $attrs_of{ $_ },
? $parser->namespace($_) . '|' . $_
: '|' . $_,
Value => shift @attr_value_from, # $attrs_of{ $_ },
LocalName => $_
}
} @attr_key_from;
@@ -304,7 +336,6 @@ sub _fixup_attrs {
1;
=pod
=head1 NAME
@@ -336,10 +367,10 @@ the same terms as perl itself
=head1 Repository information
$Id: WSDLParser.pm 728 2008-07-13 19:28:50Z kutterma $
$Id: WSDLParser.pm 795 2009-02-21 00:04:29Z kutterma $
$LastChangedDate: 2008-07-13 21:28:50 +0200 (So, 13 Jul 2008) $
$LastChangedRevision: 728 $
$LastChangedDate: 2009-02-21 01:04:29 +0100 (Sa, 21 Feb 2009) $
$LastChangedRevision: 795 $
$LastChangedBy: kutterma $
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/WSDLParser.pm $