import SOAP-WSDL 2.00_29 from CPAN
git-cpan-module: SOAP-WSDL git-cpan-version: 2.00_29 git-cpan-authorid: MKUTTER git-cpan-file: authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_29.tar.gz
This commit is contained in:
Martin Kutter
committed by
Michael G. Schwern
Michael G. Schwern
parent
2bad767211
commit
874251225f
@@ -0,0 +1,78 @@
|
||||
package SOAP::WSDL::Expat::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
use XML::Parser::Expat;
|
||||
|
||||
our $VERSION = '2.00_27';
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new( Namespaces => 1 ) )->parse( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
$_[0]->{ parser }->xpcroak( $@ ) if $@;
|
||||
return $_[0]->{ data };
|
||||
}
|
||||
|
||||
sub parsefile {
|
||||
eval {
|
||||
$_[0]->_initialize( XML::Parser::Expat->new(Namespaces => 1) )->parsefile( $_[1] );
|
||||
$_[0]->{ parser }->release();
|
||||
};
|
||||
$_[0]->{ parser }->xpcroak( $@ ) if $@;
|
||||
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::Base - Base class for XML::Parser::Expat based XML parsers
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for XML::Parser::Expat based XML parsers. All XML::SAX::Expat based
|
||||
parsers in SOAP::WSDL inherit from this class.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=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 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 $
|
||||
@@ -0,0 +1,132 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::Message2Hash;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(SOAP::WSDL::Expat::Base);
|
||||
|
||||
our $VERSION = '2.00_27';
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
$self->{ parser } = $parser;
|
||||
delete $self->{ data }; # remove potential old results
|
||||
|
||||
my $characters;
|
||||
my $current = {};
|
||||
my $list = []; # node list
|
||||
my $current_part = q{}; # are we in header or body ?
|
||||
$self->{ data } = $current;
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_element, $_method,
|
||||
$_class, $_parser, %_attrs) = ();
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
push @$list, $current;
|
||||
#If our element exists and is a list ref, add to it
|
||||
if ( exists $current->{ $_[1] }
|
||||
&& ( ref ($current->{ $_[1] }) eq 'ARRAY')
|
||||
) {
|
||||
push @{ $current->{ $_[1] } }, {};
|
||||
$current = $current->{ $_[1] }->[-1];
|
||||
}
|
||||
elsif ( exists $current->{ $_[1] } )
|
||||
{
|
||||
$current->{ $_[1] } = [ $current->{ $_[1] }, {} ];
|
||||
$current = $current->{ $_[1] }->[-1];
|
||||
}
|
||||
else {
|
||||
$current->{ $_[1] } = {};
|
||||
$current = $current->{ $_[1] };
|
||||
}
|
||||
return;
|
||||
},
|
||||
|
||||
Char => sub {
|
||||
$characters .= $_[1] if $_[1] !~m{ \A \s* \z}xms;
|
||||
return;
|
||||
},
|
||||
|
||||
End => sub {
|
||||
$_element = $_[1];
|
||||
|
||||
# This one easily handles ignores for us, too...
|
||||
# return if not ref $$list[-1];
|
||||
|
||||
if (length $characters) {
|
||||
if (ref $list->[-1]->{ $_element } eq 'ARRAY') {
|
||||
$list->[-1]->{ $_element }->[-1] = $characters ;
|
||||
}
|
||||
else {
|
||||
$list->[-1]->{ $_element } = $characters;
|
||||
}
|
||||
}
|
||||
$characters = q{};
|
||||
$current = pop @$list; # step up in object hierarchy...
|
||||
return;
|
||||
}
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::Message2Hash - Convert SOAP messages to perl hash refs
|
||||
|
||||
=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::Manual::Parser> for details.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
=over
|
||||
|
||||
=item * Ignores all namespaces
|
||||
|
||||
=item * Ignores all attributes
|
||||
|
||||
=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 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 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 $
|
||||
|
||||
@@ -0,0 +1,302 @@
|
||||
#!/usr/bin/perl
|
||||
package SOAP::WSDL::Expat::MessageParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw(croak confess);
|
||||
|
||||
our $VERSION = q{2.00_27};
|
||||
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
|
||||
|
||||
use base qw(SOAP::WSDL::Expat::Base);
|
||||
|
||||
require Class::Std::Fast;
|
||||
my $OBJECT_CACHE_REF = Class::Std::Fast::OBJECT_CACHE_REF();
|
||||
|
||||
my %LOADED_OF = ();
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver },
|
||||
strict => exists $args->{ strict } ? $args->{ strict } : 1,
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
$self->load_classes() if ($args->{ class_resolver });
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub class_resolver {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{ class_resolver } = shift;
|
||||
$self->load_classes();
|
||||
}
|
||||
return $self->{ class_resolver };
|
||||
}
|
||||
|
||||
sub load_classes {
|
||||
my $self = shift;
|
||||
|
||||
return if $LOADED_OF{ $self->{ class_resolver } };
|
||||
|
||||
for (values %{ $self->{ class_resolver }->get_typemap }) {
|
||||
no strict qw(refs);
|
||||
my $class = $_;
|
||||
|
||||
# a bad test - do you know a better one?
|
||||
next if $class eq '__SKIP__';
|
||||
next if defined *{ "$class\::" }; # check if namespace exists
|
||||
|
||||
$class =~s{ :: }{/}xmsg;
|
||||
$class .= '.pm';
|
||||
require $class;
|
||||
}
|
||||
$LOADED_OF{ $self->{ class_resolver } } = 1;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
$self->{ parser } = $parser;
|
||||
|
||||
delete $self->{ data }; # remove potential old results
|
||||
delete $self->{ header };
|
||||
|
||||
my $characters;
|
||||
|
||||
# Note: $current MUST be undef - it is used as sentinel
|
||||
# on the object stack via if (! defined $list->[-1])
|
||||
# DON'T set it to anything else !
|
||||
my $current = undef;
|
||||
my $list = []; # node list (object stack)
|
||||
|
||||
my $path = []; # current path
|
||||
my $skip = 0; # skip elements
|
||||
my $depth = 0;
|
||||
|
||||
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;
|
||||
},
|
||||
1 => sub {
|
||||
$depth++;
|
||||
if ($_[1] eq 'Body') {
|
||||
if (exists $self->{ data }) { # there was header data
|
||||
$self->{ header } = $self->{ data };
|
||||
delete $self->{ data };
|
||||
$list = [];
|
||||
$path = [];
|
||||
undef $current;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
)
|
||||
: ();
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_method,
|
||||
$_class, $_leaf) = ();
|
||||
|
||||
my $char_handler = sub {
|
||||
return if (!$_leaf); # we only want characters in leaf nodes
|
||||
|
||||
$characters .= $_[1];
|
||||
# if $_[1] =~m{ [^\s] }xms;
|
||||
|
||||
return;
|
||||
};
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
# my ($parser, $element, %attrs) = @_;
|
||||
|
||||
$_leaf = 1; # believe we're a leaf node until we see an end
|
||||
|
||||
# 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 };
|
||||
|
||||
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 "
|
||||
. join('/', @{ $path }) . " via " . $self->{ class_resolver };
|
||||
|
||||
if ($_class eq '__SKIP__') {
|
||||
$skip = join('/', @{ $path });
|
||||
$_[0]->setHandlers( Char => undef );
|
||||
return;
|
||||
}
|
||||
|
||||
# step down in tree (remember current)
|
||||
#
|
||||
# on the first object (after skipping Envelope/Body), $current
|
||||
# is undef.
|
||||
# We put it on the stack, anyway, and use it as sentinel when
|
||||
# going through the closing tags in the End handler
|
||||
#
|
||||
push @$list, $current;
|
||||
|
||||
# cleanup. Mainly here to help profilers find the real hot spots
|
||||
undef $current;
|
||||
|
||||
# cleanup
|
||||
$characters = q{};
|
||||
|
||||
# Create and set new objects using Class::Std::Fast's object cache
|
||||
# if possible, or blessing directly into the class in question
|
||||
# (circumventing constructor) here.
|
||||
# That's dirty, but fast.
|
||||
#
|
||||
# The alternative would read:
|
||||
# $current = $_class->new({ @_[2..$#_] });
|
||||
#
|
||||
$current = pop @{ $OBJECT_CACHE_REF->{ $_class } };
|
||||
if (not defined $current) {
|
||||
my $o = Class::Std::Fast::ID();
|
||||
$current = bless \$o, $_class;
|
||||
}
|
||||
|
||||
$current->attr({ @_[2..$#_] }) if (@_ > 2);
|
||||
|
||||
$depth++;
|
||||
return;
|
||||
},
|
||||
|
||||
Char => $char_handler,
|
||||
|
||||
End => sub {
|
||||
|
||||
pop @{ $path }; # step up in path
|
||||
|
||||
# check __SKIP__
|
||||
if ($skip) {
|
||||
return if $skip ne join '/', @{ $path }, $_[1];
|
||||
$skip = 0;
|
||||
$_[0]->setHandlers( Char => $char_handler );
|
||||
return;
|
||||
}
|
||||
|
||||
$depth--;
|
||||
|
||||
# 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]) {
|
||||
$self->{ data } = $current if (not exists $self->{ data });
|
||||
return;
|
||||
};
|
||||
|
||||
# we only set character values in leaf nodes
|
||||
if ($_leaf) {
|
||||
# Use dirty but fast access via global variables.
|
||||
#
|
||||
# The normal way (via method) would be this:
|
||||
#
|
||||
# $current->set_value( $characters ) if (length($characters));
|
||||
#
|
||||
$SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType::___value
|
||||
->{ $$current } = $characters if $characters =~m{ [^\s] }xms;
|
||||
}
|
||||
|
||||
# empty characters
|
||||
$characters = q{};
|
||||
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
# $_method = "add_$_localname";
|
||||
$_method = "add_$_[1]";
|
||||
$list->[-1]->$_method( $current );
|
||||
|
||||
$current = pop @$list; # step up in object hierarchy
|
||||
|
||||
$_leaf = 0; # stop believing we're a leaf node
|
||||
|
||||
return;
|
||||
}
|
||||
);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub get_header {
|
||||
return $_[0]->{ header };
|
||||
}
|
||||
|
||||
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::Manual::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, set the type map entry to '__SKIP__', and comment out all
|
||||
child elements you want 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 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 Repository information
|
||||
|
||||
$Id: $
|
||||
|
||||
$LastChangedDate: 2008-01-19 13:57:57 +0100 (Sa, 19 Jan 2008) $
|
||||
$LastChangedRevision: 497 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
|
||||
|
||||
@@ -0,0 +1,77 @@
|
||||
#!/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);
|
||||
|
||||
our $VERSION = '2.00_24';
|
||||
|
||||
sub parse_start {
|
||||
my $self = shift;
|
||||
$self->{ parser } = $_[0]->_initialize( XML::Parser::ExpatNB->new( Namespaces => 1 ) );
|
||||
}
|
||||
sub init;
|
||||
*init = \&parse_start;
|
||||
|
||||
sub parse_more {
|
||||
$_[0]->{ parser }->parse_more( $_[1] );
|
||||
}
|
||||
|
||||
sub parse_done {
|
||||
$_[0]->{ parser }->parse_done();
|
||||
$_[0]->{ parser }->release();
|
||||
}
|
||||
|
||||
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::Manual::Parser> for details.
|
||||
|
||||
=head1 Bugs and Limitations
|
||||
|
||||
See SOAP::WSDL::Expat::MessageParser
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2007 Martin Kutter.
|
||||
|
||||
This file is part of SOAP-WSDL. You may distribute/modify it under
|
||||
the same terms as perl itself
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 477 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: MessageStreamParser.pm 477 2007-12-24 10:23:52Z kutterma $
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageStreamParser.pm $
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,187 @@
|
||||
package SOAP::WSDL::Expat::WSDLParser;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use SOAP::WSDL::TypeLookup;
|
||||
use base qw(SOAP::WSDL::Expat::Base);
|
||||
|
||||
our $VERSION = q{2.00_29};
|
||||
|
||||
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,
|
||||
xmlns => { '#default' => $parser->namespace($localname) }
|
||||
})
|
||||
->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 };
|
||||
|
||||
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)
|
||||
);
|
||||
}
|
||||
|
||||
return;
|
||||
},
|
||||
|
||||
Char => sub { $characters .= $_[1]; return; },
|
||||
|
||||
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;
|
||||
}
|
||||
);
|
||||
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;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SOAP::WSDL::Expat::WSDLParser - Parse WSDL files into object trees
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $parser = SOAP::WSDL::Expat::WSDLParser->new();
|
||||
$parser->parse( $xml );
|
||||
my $obj = $parser->get_data();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
WSDL parser used by SOAP::WSDL.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Replace the whitespace by @ for E-Mail Address.
|
||||
|
||||
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
|
||||
|
||||
=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 Repository information
|
||||
|
||||
$Id: $
|
||||
|
||||
$LastChangedDate: 2007-12-24 11:23:52 +0100 (Mo, 24 Dez 2007) $
|
||||
$LastChangedRevision: 477 $
|
||||
$LastChangedBy: kutterma $
|
||||
|
||||
$HeadURL: http://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/WSDLParser.pm $
|
||||
|
||||
Reference in New Issue
Block a user