File Coverage

blib/lib/SOAP/WSDL/Expat/MessageParser.pm
Criterion Covered Total %
statement 15 15 100.0
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 20 20 100.0


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             package SOAP::WSDL::Expat::MessageParser;
3 30     30   69510 use strict; use warnings;
  30     30   60  
  30         1156  
  30         150  
  30         64  
  30         874  
4              
5 30     30   18934 use SOAP::WSDL::XSD::Typelib::Builtin;
  30         97  
  30         853  
6 30     30   394 use SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
  30         56  
  30         753  
7              
8 30     30   152 use base qw(SOAP::WSDL::Expat::Base);
  30         60  
  30         17244  
9              
10             BEGIN { require Class::Std::Fast };
11              
12             our $VERSION = $SOAP::WSDL::VERSION;
13              
14             # GLOBALS
15             my $OBJECT_CACHE_REF = Class::Std::Fast::OBJECT_CACHE_REF();
16              
17             # keep track of classes loaded
18             my %LOADED_OF = ();
19              
20             sub new {
21             my ($class, $args) = @_;
22             my $self = {
23             class_resolver => $args->{ class_resolver },
24             strict => exists $args->{ strict } ? $args->{ strict } : 1,
25             };
26              
27             bless $self, $class;
28              
29             # could be written as && - but Devel::Cover doesn't like that
30             if ($args->{ class_resolver }) {
31             $self->load_classes()
32             if ! exists $LOADED_OF{ $self->{ class_resolver } };
33             }
34             return $self;
35             }
36              
37             sub class_resolver {
38             my $self = shift;
39             if (@_) {
40             $self->{ class_resolver } = shift;
41             $self->load_classes()
42             if ! exists $LOADED_OF{ $self->{ class_resolver } };
43             }
44             return $self->{ class_resolver };
45             }
46              
47             sub load_classes {
48             my $self = shift;
49              
50             return if $LOADED_OF{ $self->{ class_resolver } };
51              
52             # requires sorting to make sub-packages load after their parent
53             for (sort values %{ $self->{ class_resolver }->get_typemap }) {
54             no strict qw(refs);
55             my $class = $_;
56              
57             # a bad test - do you know a better one?
58             next if $class eq '__SKIP__';
59             next if defined *{ "$class\::" }; # check if namespace exists
60              
61             # Require takes a bareword or a file name - we have to take
62             # the filname road here...
63             $class =~s{ :: }{/}xmsg;
64             require "$class.pm"; ## no critic (RequireBarewordIncludes)
65             }
66             $LOADED_OF{ $self->{ class_resolver } } = 1;
67             }
68              
69             sub _initialize {
70             my ($self, $parser) = @_;
71             $self->{ parser } = $parser;
72              
73             delete $self->{ data }; # remove potential old results
74             delete $self->{ header };
75              
76             my $characters;
77              
78             # Note: $current MUST be undef - it is used as sentinel
79             # on the object stack via if (! defined $list->[-1])
80             # DON'T set it to anything else !
81             my $current = undef;
82             my $list = []; # node list (object stack)
83              
84             my $path = []; # current path
85             my $skip = 0; # skip elements
86             my $depth = 0;
87              
88             my %content_check = $self->{strict}
89             ? (
90             0 => sub {
91             die "Bad top node $_[1]" if $_[1] ne 'Envelope';
92             die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string()
93             if $_[0]->namespace($_[1]) ne 'http://schemas.xmlsoap.org/soap/envelope/';
94             $depth++;
95             return;
96             },
97             1 => sub {
98             $depth++;
99             if ($_[1] eq 'Body') {
100             if (exists $self->{ data }) { # there was header data
101             $self->{ header } = $self->{ data };
102             delete $self->{ data };
103             $list = [];
104             $path = [];
105             undef $current;
106             }
107             }
108             return;
109             }
110             )
111             : (
112             0 => sub { $depth++ },
113             1 => sub { $depth++ },
114             );
115              
116             # use "globals" for speed
117             my ($_prefix, $_method, $_class, $_leaf) = ();
118              
119             my $char_handler = sub {
120             return if (!$_leaf); # we only want characters in leaf nodes
121             $characters .= $_[1]; # add to characters
122             return; # return void
123             };
124              
125             no strict qw(refs);
126             $parser->setHandlers(
127             Start => sub {
128             # my ($parser, $element, %attrs) = @_;
129              
130             $_leaf = 1; # believe we're a leaf node until we see an end
131              
132             # call methods without using their parameter stack
133             # That's slightly faster than $content_check{ $depth }->()
134             # and we don't have to pass $_[1] to the method.
135             # Yup, that's dirty.
136             return &{$content_check{ $depth }}
137             if exists $content_check{ $depth };
138              
139             push @{ $path }, $_[1]; # step down in path
140             return if $skip; # skip inside __SKIP__
141              
142             # resolve class of this element
143             $_class = $self->{ class_resolver }->get_class( $path );
144              
145             if (! defined($_class) and $self->{ strict }) {
146             die "Cannot resolve class for "
147             . join('/', @{ $path }) . " via " . $self->{ class_resolver };
148             }
149              
150             if (! defined($_class) or ($_class eq '__SKIP__') ) {
151             $skip = join('/', @{ $path });
152             $_[0]->setHandlers( Char => undef );
153             return;
154             }
155              
156             # step down in tree (remember current)
157             #
158             # on the first object (after skipping Envelope/Body), $current
159             # is undef.
160             # We put it on the stack, anyway, and use it as sentinel when
161             # going through the closing tags in the End handler
162             #
163             push @$list, $current;
164              
165             # cleanup. Mainly here to help profilers find the real hot spots
166             undef $current;
167              
168             # cleanup
169             $characters = q{};
170              
171             # Create and set new objects using Class::Std::Fast's object cache
172             # if possible, or blessing directly into the class in question
173             # (circumventing constructor) here.
174             # That's dirty, but fast.
175             #
176             # TODO: check whether this is faster under all perls - there's
177             # strange benchmark results...
178             #
179             # The alternative would read:
180             # $current = $_class->new({ @_[2..$#_] });
181             #
182             $current = pop @{ $OBJECT_CACHE_REF->{ $_class } };
183             if (not defined $current) {
184             my $o = Class::Std::Fast::ID();
185             $current = bless \$o, $_class;
186             }
187              
188             # set attributes if there are any
189             ATTR: {
190             if (@_ > 2) {
191             # die Data::Dumper::Dumper(@_[2..$#_]);
192             my %attr = @_[2..$#_];
193             if (my $nil = delete $attr{nil}) {
194             # TODO: check namespace
195             if ($nil && $nil ne 'false') {
196             undef $characters;
197             last ATTR if not (%attr);
198             }
199             }
200             $current->attr(\%attr);
201             }
202             }
203             $depth++;
204              
205             # TODO: Skip content of anyType / any stuff
206              
207             return;
208             },
209              
210             Char => $char_handler,
211              
212             End => sub {
213              
214             pop @{ $path }; # step up in path
215              
216             # check __SKIP__
217             if ($skip) {
218             return if $skip ne join '/', @{ $path }, $_[1];
219             $skip = 0;
220             $_[0]->setHandlers( Char => $char_handler );
221             return;
222             }
223              
224             $depth--;
225              
226             # we only set character values in leaf nodes
227             if ($_leaf) {
228             # Use dirty but fast access via global variables.
229             #
230             # The normal way (via method) would be this:
231             #
232             # $current->set_value( $characters ) if (length($characters));
233             #
234             $SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType::___value
235             ->{ $$current } = $characters
236             if defined $characters && defined $current; # =~m{ [^\s] }xms;
237             }
238              
239             # empty characters
240             $characters = q{};
241              
242             # stop believing we're a leaf node
243             $_leaf = 0;
244              
245             # return if there's only one elment - can't set it in parent ;-)
246             # but set as root element if we don't have one already.
247             if (not defined $list->[-1]) {
248             $self->{ data } = $current if (not exists $self->{ data });
249             return;
250             };
251              
252             # set appropriate attribute in last element
253             # multiple values must be implemented in base class
254             # TODO check if hash access is faster
255             # $_method = "add_$_localname";
256             $_method = "add_$_[1]";
257             #
258             # fixup XML names for perl names
259             #
260             $_method =~s{\.}{__}xg;
261             $_method =~s{\-}{_}xg;
262             $list->[-1]->$_method( $current );
263              
264             $current = pop @$list; # step up in object hierarchy
265              
266             return;
267             }
268             );
269             return $parser;
270             }
271              
272             sub get_header {
273             return $_[0]->{ header };
274             }
275              
276             1;
277              
278             =pod
279              
280             =head1 NAME
281              
282             SOAP::WSDL::Expat::MessageParser - Convert SOAP messages to custom object trees
283              
284             =head1 SYNOPSIS
285              
286             my $parser = SOAP::WSDL::Expat::MessageParser->new({
287             class_resolver => 'My::Resolver'
288             });
289             $parser->parse( $xml );
290             my $obj = $parser->get_data();
291              
292             =head1 DESCRIPTION
293              
294             Real fast expat based SOAP message parser.
295              
296             See L for details.
297              
298             =head2 Skipping unwanted items
299              
300             Sometimes there's unneccessary information transported in SOAP messages.
301              
302             To skip XML nodes (including all child nodes), just edit the type map for
303             the message, set the type map entry to '__SKIP__', and comment out all
304             child elements you want to skip.
305              
306             =head1 Bugs and Limitations
307              
308             =over
309              
310             =item * Ignores all namespaces
311              
312             =item * Does not handle mixed content
313              
314             =item * The SOAP header is ignored
315              
316             =back
317              
318             =head1 AUTHOR
319              
320             Replace the whitespace by @ for E-Mail Address.
321              
322             Martin Kutter Emartin.kutter fen-net.deE
323              
324             =head1 LICENSE AND COPYRIGHT
325              
326             Copyright 2004-2007 Martin Kutter.
327              
328             This file is part of SOAP-WSDL. You may distribute/modify it under
329             the same terms as perl itself
330              
331             =head1 Repository information
332              
333             $Id: MessageParser.pm 851 2009-05-15 22:45:18Z kutterma $
334              
335             $LastChangedDate: 2009-05-16 00:45:18 +0200 (Sa, 16. Mai 2009) $
336             $LastChangedRevision: 851 $
337             $LastChangedBy: kutterma $
338              
339             $HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $
340