File Coverage

blib/lib/SOAP/WSDL/Expat/WSDLParser.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             package SOAP::WSDL::Expat::WSDLParser;
2 13     13   551420 use strict;
  13         26  
  13         428  
3 13     13   120 use warnings;
  13         14  
  13         331  
4 13     13   55 use Carp;
  13         13  
  13         705  
5 13     13   4257 use SOAP::WSDL::TypeLookup;
  13         21  
  13         396  
6 13     13   57 use base qw(SOAP::WSDL::Expat::Base);
  13         13  
  13         4603  
7              
8             our $VERSION = 3.003;
9              
10             #
11             # Import child elements of a WSDL / XML Schema tree into the current tree
12             #
13             # Set the targetNamespace of the imported nodes to $import_namespace
14             #
15             # SYNOPSIS
16             #
17             # $self->_import_children($name, $imported, $imported, $import_namespace)
18             #
19              
20             sub _import_children {
21             my ( $self, $name, $imported, $importer, $import_namespace ) = @_;
22              
23             my $targetNamespace = $importer->get_targetNamespace();
24             my $push_method = "push_$name";
25             my $get_method = "get_$name";
26             my $default_namespace = $imported->get_xmlns()->{'#default'};
27              
28             no strict qw(refs);
29             my $value_ref = $imported->$get_method();
30             if ($value_ref) {
31              
32             $value_ref = [$value_ref] if ( not ref $value_ref eq 'ARRAY' );
33              
34             for ( @{$value_ref} ) {
35              
36             # fixup namespace - new parent may be from different namespace
37             if ( defined($default_namespace) ) {
38             my $xmlns = $_->get_xmlns();
39              
40             # it's a hash ref, so we can just update values
41             if ( !defined $xmlns->{'#default'} ) {
42             $xmlns->{'#default'} = $default_namespace;
43             }
44             }
45              
46             # fixup targetNamespace, but don't override
47             $_->set_targetNamespace($import_namespace)
48             if ( ( $import_namespace ne $targetNamespace )
49             && !$_->get_targetNamespace );
50              
51             # update parent...
52             $_->set_parent($importer);
53              
54             # push elements into importing WSDL
55             $importer->$push_method($_);
56             }
57             }
58             }
59              
60             sub _import_namespace_definitions {
61             my $self = shift;
62             my $arg_ref = shift;
63             my $importer = $arg_ref->{importer};
64             my $imported = $arg_ref->{imported};
65              
66             # import namespace definitions, too
67             my $importer_ns_of = $importer->get_xmlns();
68             my %xmlns_of = %{$imported->get_xmlns()};
69              
70             # it's a hash ref, we can just add to.
71             # TODO: check whether URI is the better key.
72             while ( my ( $prefix, $url ) = each %xmlns_of ) {
73             if ( exists( $importer_ns_of->{$prefix} ) ) {
74              
75             # warn "$prefix already exists";
76             next;
77             }
78             $importer_ns_of->{$prefix} = $url;
79             }
80             }
81              
82             sub xml_schema_import {
83             my $self = shift;
84             my $schema = shift;
85             my $parser = $self->clone();
86             my %attr_of = @_;
87             my $import_namespace = $attr_of{namespace};
88              
89             if ( not $attr_of{schemaLocation} ) {
90             warn
91             "cannot import document for namespace >$import_namespace< without location";
92             return;
93             }
94              
95             if ( not $self->get_uri ) {
96             die
97             "cannot import document from namespace >$import_namespace< without base uri. Use >parse_uri< or >set_uri< to set one.";
98             }
99              
100             my $uri = URI->new_abs( $attr_of{schemaLocation}, $self->get_uri() );
101             my $imported = $parser->parse_uri($uri);
102              
103             # might already be imported - parse_uri just returns in this case
104             return if not defined $imported;
105              
106             $self->_import_namespace_definitions( {
107             importer => $schema,
108             imported => $imported,
109             } );
110              
111             for my $name (qw(type element group attribute attributeGroup)) {
112             $self->_import_children( $name, $imported, $schema,
113             $import_namespace );
114             }
115             }
116              
117             sub wsdl_import {
118             my $self = shift;
119             my $definitions = shift;
120             my $parser = $self->clone();
121             my %attr_of = @_;
122             my $import_namespace = $attr_of{namespace};
123              
124             if ( not $attr_of{location} ) {
125             warn
126             "cannot import document for namespace >$import_namespace< without location";
127             return;
128             }
129              
130             if ( not $self->get_uri ) {
131             die
132             "cannot import document from namespace >$import_namespace< without base uri. Use >parse_uri< or >set_uri< to set one.";
133             }
134              
135             my $uri = URI->new_abs( $attr_of{location}, $self->get_uri() );
136              
137             my $imported = $parser->parse_uri($uri);
138              
139             # might already be imported - parse_uri just returns in this case
140             return if not defined $imported;
141              
142             $self->_import_namespace_definitions( {
143             importer => $definitions,
144             imported => $imported,
145             } );
146              
147             for my $name (qw(types message binding portType service)) {
148             $self->_import_children( $name, $imported, $definitions,
149             $import_namespace );
150             }
151             }
152              
153             sub _initialize {
154             my ( $self, $parser ) = @_;
155              
156             # init object data
157             $self->{parser} = $parser;
158             delete $self->{data};
159              
160             # setup local variables for keeping temp data
161             my $characters = undef;
162             my $current = undef;
163             my $list = []; # node list
164             my $elementFormQualified = 1; # default for WSDLs, schema may override
165              
166             # TODO skip non-XML Schema namespace tags
167             $parser->setHandlers(
168             Start => sub {
169              
170             # handle attrs as list - expat uses dual-vars for looking
171             # up namespace information, and hash keys don't allow dual vars...
172             my ( $parser, $localname, @attrs ) = @_;
173             $characters = q{};
174              
175             my $action =
176             SOAP::WSDL::TypeLookup->lookup( $parser->namespace($localname),
177             $localname );
178              
179             return if not $action;
180              
181             if ( $action->{type} eq 'CLASS' ) {
182             eval "require $action->{ class }";
183             croak $@ if ($@);
184              
185             my $obj = $action->{class}->new( {
186             parent => $current,
187             namespace => $parser->namespace($localname),
188             defined($current)
189             ? ( xmlns => $current->get_xmlns() )
190             : ()} )->init( _fixup_attrs( $parser, @attrs ) );
191              
192             if ($current) {
193             if ( defined $list->[-1]
194             && $list->[-1]->isa('SOAP::WSDL::XSD::Schema') ) {
195             $elementFormQualified =
196             $list->[-1]->get_elementFormDefault() eq
197             'qualified';
198             }
199              
200             # inherit namespace, but don't override
201             if ($elementFormQualified) {
202             $obj->set_targetNamespace(
203             $current->get_targetNamespace() )
204             if not $obj->get_targetNamespace();
205             }
206              
207             # push on parent's element/type list
208             my $method = "push_$localname";
209              
210             no strict qw(refs);
211             $current->$method($obj);
212              
213             # remember element for stepping back
214             push @{$list}, $current;
215             }
216              
217             # set new element (step down)
218             $current = $obj;
219             }
220             elsif ( $action->{type} eq 'PARENT' ) {
221             $current->init( _fixup_attrs( $parser, @attrs ) );
222             }
223             elsif ( $action->{type} eq 'METHOD' ) {
224             my $method = $action->{method};
225              
226             no strict qw(refs);
227              
228             # call method with
229             # - default value ($action->{ value } if defined,
230             # dereferencing lists
231             # - the values of the elements Attributes hash
232             # TODO: add namespaces declared to attributes.
233             # Expat consumes them, so we have to re-add them here.
234             $current->$method(
235             defined $action->{value}
236             ? ref $action->{value}
237             ? @{$action->{value}}
238             : ( $action->{value} )
239             : _fixup_attrs( $parser, @attrs ) );
240             }
241             elsif ( $action->{type} eq 'HANDLER' ) {
242             my $method = $self->can( $action->{method} );
243             $method->( $self, $current, @attrs );
244             }
245             else {
246              
247             # TODO replace by hash lookup of known namespaces.
248             my $namespace = $parser->namespace($localname) || q{};
249             my $part =
250             $namespace eq 'http://schemas.xmlsoap.org/wsdl/'
251             ? 'WSDL 1.1'
252             : 'XML Schema';
253              
254             warn "$part element <$localname> is not implemented yet"
255             if ( $localname !~
256             m{ \A (:? annotation | documentation ) \z }xms );
257             }
258              
259             return;
260             },
261              
262             Char => sub { $characters .= $_[1]; return; },
263              
264             End => sub {
265             my ( $parser, $localname ) = @_;
266              
267             my $action =
268             SOAP::WSDL::TypeLookup->lookup( $parser->namespace($localname),
269             $localname )
270             || {};
271              
272             if ( !defined $list->[-1] ) {
273             $self->{data} = $current;
274             return;
275             }
276              
277              
278             return if not( $action->{type} );
279             if ( $action->{type} eq 'CLASS' ) {
280             $current = pop @{$list};
281             if ( defined $list->[-1] && $list->[-1]->isa('SOAP::WSDL::XSD::Schema') ) {
282             $elementFormQualified = 1;
283             }
284             }
285             elsif ( $action->{type} eq 'CONTENT' ) {
286             my $method = $action->{method};
287              
288             # normalize whitespace
289             $characters =~ s{ ^ \s+ (.+) \s+ $ }{$1}xms;
290             $characters =~ s{ \s+ }{ }xmsg;
291              
292             no strict qw(refs);
293             $current->$method($characters);
294             }
295             return;
296             } );
297             return $parser;
298             }
299              
300             # make attrs SAX style
301             sub _fixup_attrs {
302             my ( $parser, @attrs ) = @_;
303              
304             my @attr_key_from = ();
305             my @attr_value_from = ();
306              
307             while (@attrs) {
308             push @attr_key_from, shift @attrs;
309             push @attr_value_from, shift @attrs;
310             }
311              
312             my @attrs_from;
313              
314             # add xmlns: attrs. expat eats them.
315             #
316             # add namespaces before attributes: Attributes may be namespace-qualified
317             #
318             push @attrs_from, map { {
319             Name => "xmlns:$_",
320             Value => $parser->expand_ns_prefix($_),
321             LocalName => $_
322             }
323             } $parser->new_ns_prefixes();
324              
325             push @attrs_from, map { {
326             Name => defined $parser->namespace($_)
327             ? $parser->namespace($_) . '|' . $_
328             : '|' . $_,
329             Value => shift @attr_value_from, # $attrs_of{ $_ },
330             LocalName => $_
331             }
332             } @attr_key_from;
333              
334             return @attrs_from;
335             }
336              
337             1;
338              
339             =pod
340              
341             =head1 NAME
342              
343             SOAP::WSDL::Expat::WSDLParser - Parse WSDL files into object trees
344              
345             =head1 SYNOPSIS
346              
347             my $parser = SOAP::WSDL::Expat::WSDLParser->new();
348             $parser->parse( $xml );
349             my $obj = $parser->get_data();
350              
351             =head1 DESCRIPTION
352              
353             WSDL parser used by SOAP::WSDL.
354              
355             =head1 AUTHOR
356              
357             Replace the whitespace by @ for E-Mail Address.
358              
359             Martin Kutter Emartin.kutter fen-net.deE
360              
361             =head1 LICENSE AND COPYRIGHT
362              
363             Copyright 2004-2007 Martin Kutter.
364              
365             This file is part of SOAP-WSDL. You may distribute/modify it under
366             the same terms as perl itself
367              
368             =head1 Repository information
369              
370             $Id: WSDLParser.pm 851 2009-05-15 22:45:18Z kutterma $
371              
372             $LastChangedDate: 2009-05-16 00:45:18 +0200 (Sa, 16. Mai 2009) $
373             $LastChangedRevision: 851 $
374             $LastChangedBy: kutterma $
375              
376             $HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/WSDLParser.pm $
377