import SOAP-WSDL 2.00_24 from CPAN
git-cpan-module: SOAP-WSDL git-cpan-version: 2.00_24 git-cpan-authorid: MKUTTER git-cpan-file: authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_24.tar.gz
This commit is contained in:
Martin Kutter
committed by
Michael G. Schwern
Michael G. Schwern
parent
b955c5ad79
commit
84b53d9261
@@ -5,11 +5,13 @@ use warnings;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use base qw(SOAP::WSDL::Expat::Base);
|
||||
|
||||
our $VERSION = '2.00_24';
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver },
|
||||
strict => exists $args->{ strict } ? $args->{ strict } : 1,
|
||||
strict => exists $args->{ strict } ? $args->{ strict } : 1,
|
||||
};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
@@ -18,7 +20,7 @@ sub new {
|
||||
sub class_resolver {
|
||||
my $self = shift;
|
||||
$self->{ class_resolver } = shift if @_;
|
||||
return $self->{ class_resolver };
|
||||
return $self->{ class_resolver };
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
@@ -27,30 +29,30 @@ sub _initialize {
|
||||
|
||||
delete $self->{ data }; # remove potential old results
|
||||
delete $self->{ header };
|
||||
|
||||
|
||||
my $characters;
|
||||
#my @characters_from = ();
|
||||
my $current = undef;
|
||||
my $list = []; # node list
|
||||
my $path = []; # current path
|
||||
my $path = []; # current path
|
||||
my $skip = 0; # skip elements
|
||||
my $current_part = q{}; # are we in header or body ?
|
||||
|
||||
my $depth = 0;
|
||||
|
||||
my %content_check = $self->{strict}
|
||||
my %content_check = $self->{strict}
|
||||
? (
|
||||
0 => sub {
|
||||
die "Bad top node $_[1]" if $_[1] ne 'Envelope';
|
||||
die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string()
|
||||
if $_[0]->namespace($_[1]) ne 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
$depth++;
|
||||
return;
|
||||
return;
|
||||
},
|
||||
1 => sub {
|
||||
$depth++;
|
||||
if ($_[1] eq 'Body') {
|
||||
if (exists $self->{ data }) { # there was header data
|
||||
if (exists $self->{ data }) { # there was header data
|
||||
$self->{ header } = $self->{ data };
|
||||
delete $self->{ data };
|
||||
$list = [];
|
||||
@@ -58,37 +60,37 @@ sub _initialize {
|
||||
undef $current;
|
||||
}
|
||||
}
|
||||
return;
|
||||
return;
|
||||
}
|
||||
)
|
||||
)
|
||||
: ();
|
||||
|
||||
my $char_handler = sub {
|
||||
# push @characters_from, $_[1] if $_[1] =~m{ [^s] }xms;
|
||||
$characters .= $_[1] if $_[1] =~m{ [^\s] }xms;
|
||||
|
||||
|
||||
return;
|
||||
};
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_method,
|
||||
my ($_prefix, $_method,
|
||||
$_class) = ();
|
||||
|
||||
no strict qw(refs);
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
Start => sub {
|
||||
# my ($parser, $element, %_attrs) = @_;
|
||||
# $depth = $parser->depth();
|
||||
|
||||
# call methods without using their parameter stack
|
||||
# That's slightly faster than $content_check{ $depth }->()
|
||||
# and we don't have to pass $_[1] to the method.
|
||||
# Yup, that's dirty.
|
||||
return &{$content_check{ $depth }} if exists $content_check{ $depth };
|
||||
# Yup, that's dirty.
|
||||
return &{$content_check{ $depth }} if exists $content_check{ $depth };
|
||||
|
||||
push @{ $path }, $_[1]; # step down in path
|
||||
return if $skip; # skip inside __SKIP__
|
||||
|
||||
|
||||
# resolve class of this element
|
||||
$_class = $self->{ class_resolver }->get_class( $path )
|
||||
or die "Cannot resolve class for "
|
||||
@@ -96,66 +98,65 @@ sub _initialize {
|
||||
|
||||
if ($_class eq '__SKIP__') {
|
||||
$skip = join('/', @{ $path });
|
||||
$self->setHandlers( Char => undef );
|
||||
$_[0]->setHandlers( Char => undef );
|
||||
return;
|
||||
}
|
||||
|
||||
push @$list, $current; # step down in tree ()remember current)
|
||||
|
||||
}
|
||||
|
||||
push @$list, $current; # step down in tree (remember current)
|
||||
|
||||
$characters = q(); # empty characters
|
||||
#@characters_from = ();
|
||||
|
||||
|
||||
# Check whether we have a builtin - we implement them as classes
|
||||
# We could replace this with UNIVERSAL->isa() - but it's slow...
|
||||
# match is a bit faster if the string does not match, but WAY slower
|
||||
# if $class matches...
|
||||
if (index $_class, 'SOAP::WSDL::XSD::Typelib::Builtin', 0 < 0) {
|
||||
# match is a bit faster if the string does not match, but WAY slower
|
||||
# if $class matches. We hope to match often...
|
||||
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
|
||||
# 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 $@;
|
||||
or die $@;
|
||||
}
|
||||
|
||||
|
||||
$current = $_class->new({ @_[2..$#_] }); # set new current object
|
||||
|
||||
|
||||
# remember top level element
|
||||
exists $self->{ data }
|
||||
or ($self->{ data } = $current);
|
||||
exists $self->{ data }
|
||||
or ($self->{ data } = $current);
|
||||
$depth++;
|
||||
return;
|
||||
},
|
||||
|
||||
|
||||
Char => $char_handler,
|
||||
|
||||
|
||||
End => sub {
|
||||
pop @{ $path }; # step up in path
|
||||
|
||||
|
||||
if ($skip) {
|
||||
return if $skip ne join '/', @{ $path }, $_[1];
|
||||
$skip = 0;
|
||||
$_[0]->setHandler( Char => $char_handler );
|
||||
$_[0]->setHandlers( Char => $char_handler );
|
||||
return;
|
||||
}
|
||||
|
||||
$depth--;
|
||||
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
return if not ref $list->[-1];
|
||||
|
||||
|
||||
# set characters in current if we are a simple type
|
||||
# we may have characters in complexTypes with simpleContent,
|
||||
# too - maybe we should rely on the presence of characters ?
|
||||
# may get a speedup by defining a ident method in anySimpleType
|
||||
# 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 -
|
||||
# currently doesn't work, as anyType does not implement value -
|
||||
# maybe change ?
|
||||
$current->set_value( $characters ) if (length $characters);
|
||||
#$current->set_value( join @characters_from ) if (@characters_from);
|
||||
@@ -166,7 +167,7 @@ sub _initialize {
|
||||
#$_method = "add_$_localname";
|
||||
$_method = "add_$_[1]";
|
||||
$list->[-1]->$_method( $current );
|
||||
|
||||
|
||||
$current = pop @$list; # step up in object hierarchy...
|
||||
return;
|
||||
}
|
||||
@@ -174,7 +175,6 @@ sub _initialize {
|
||||
return $parser;
|
||||
}
|
||||
|
||||
|
||||
sub get_header {
|
||||
return $_[0]->{ header };
|
||||
}
|
||||
@@ -190,7 +190,7 @@ SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::MessageParser->new({
|
||||
class_resolver => 'My::Resolver'
|
||||
class_resolver => 'My::Resolver'
|
||||
});
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
@@ -205,8 +205,8 @@ See L<SOAP::WSDL::Manual::Parser> for details.
|
||||
|
||||
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__'.
|
||||
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
|
||||
|
||||
@@ -220,23 +220,22 @@ the message and set the type map entry to '__SKIP__'.
|
||||
|
||||
=back
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
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
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
This module may be used under the same terms as perl itself.
|
||||
|
||||
=head1 Repository information
|
||||
|
||||
$ID: $
|
||||
|
||||
$LastChangedDate: 2007-10-07 19:27:58 +0200 (Son, 07 Okt 2007) $
|
||||
$LastChangedRevision: 313 $
|
||||
$Rev: 391 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$Id: MessageParser.pm 391 2007-11-17 21:56:13Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user