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
@@ -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;
|
||||
|
||||
Reference in New Issue
Block a user