File Coverage

blib/lib/Google/Ads/SOAP/Deserializer/MessageParser.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             # Copyright 2012, Google Inc. All Rights Reserved.
2             #
3             # Licensed under the Apache License, Version 2.0 (the "License");
4             # you may not use this file except in compliance with the License.
5             # You may obtain a copy of the License at
6             #
7             # http://www.apache.org/licenses/LICENSE-2.0
8             #
9             # Unless required by applicable law or agreed to in writing, software
10             # distributed under the License is distributed on an "AS IS" BASIS,
11             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12             # See the License for the specific language governing permissions and
13             # limitations under the License.
14             #
15             # Custom MessageParser based on SOAP::WSDL::Expat::MessageParser, with some
16             # overriden methods via inheritance.
17              
18             package Google::Ads::SOAP::Deserializer::MessageParser;
19              
20 2     2   1269 use strict;
  2         5  
  2         60  
21 2     2   12 use warnings;
  2         5  
  2         73  
22 2     2   15 use base qw(SOAP::WSDL::Expat::MessageParser);
  2         4  
  2         256  
23              
24             use Google::Ads::Common::XPathSAXParser;
25              
26             use Carp;
27             use Scalar::Util qw(blessed);
28             use SOAP::WSDL::Expat::Base;
29             use SOAP::WSDL::Expat::MessageParser;
30             use SOAP::WSDL::XSD::Typelib::ComplexType;
31              
32             # PATCH Overriding the SAX Parser initialization to use ours.
33             sub parse_string {
34             my $xml = $_[1];
35             my $parser = $_[0]->_initialize(Google::Ads::Common::XPathSAXParser->new());
36             eval { $parser->parse($xml); };
37             croak($@) if $@;
38             delete $_[0]->{parser};
39             return $_[0]->{data};
40             }
41             # END PATCH
42              
43             sub _initialize {
44             my ($self, $parser) = @_;
45              
46             # Removing potential old results.
47             delete $self->{data};
48             delete $self->{header};
49             my $characters;
50             my $current = undef;
51              
52             # Setting up variables for depth-first tree traversal.
53             my $list = [];
54             my $path = [];
55             my $skip = 0;
56             my $depth = 0;
57              
58             # Executing sanity checks of main SOAP response headers.
59             my %content_check = $self->{strict}
60             ? (
61             0 => sub {
62             die "Bad top node $_[1]" if $_[1] ne "Envelope";
63             die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string()
64             if $_[0]->namespace() ne "http://schemas.xmlsoap.org/soap/envelope/";
65             $depth++;
66             return;
67             },
68             1 => sub {
69             $depth++;
70             if ($_[1] eq "Body") {
71             if (exists $self->{data}) {
72             $self->{header} = $self->{data};
73             delete $self->{data};
74             $list = [];
75             $path = [];
76             undef $current;
77             }
78             }
79             return;
80             })
81             : (
82             0 => sub {
83             $depth++;
84             },
85             1 => sub {
86             $depth++;
87             });
88              
89             # Using "globals" for speed.
90             # PATCH Added global variables to check if a method package exists at
91             # runtime.
92             my ($_prefix, $_add_method, $_add_method_package, $_set_method,
93             $_set_method_package, $_class, $_leaf)
94             = ();
95             # END OF PATCH
96             my $char_handler = sub {
97             # Returning if not a leaf.
98             return if (!$_leaf);
99             $characters .= $_[1];
100             return;
101             };
102             $parser->set_handlers({
103             Start => sub {
104             # PATCH Added more input coming from the SAX parser
105             my ($parser, $element, $attrs, $node) = @_;
106             # END PATCH
107              
108             $_leaf = 1;
109              
110             return &{$content_check{$depth}} if exists $content_check{$depth};
111              
112             # Resolving class of this element.
113             my $typemap = $self->{class_resolver}->get_typemap();
114             my $name = "";
115              
116             # PATCH Checking if the xsi:type attribute is set hence generating a
117             # different path to look in the typemap.
118             if (not $attrs->{"type"}) {
119             $name = $_[1];
120             } else {
121             my $attr_type = $attrs->{"type"};
122             $attr_type =~ s/(.*:)?(.*)/$2/;
123             $name = $_[1] . "[$attr_type]";
124             }
125             # END PATCH
126              
127             # Adding one more entry to the path
128             push @{$path}, $name;
129              
130             # Skipping the element if is marked __SKIP__.
131             return if $skip;
132              
133             $_class = $typemap->{join("/", @{$path})};
134              
135             if (!defined($_class) and $self->{strict}) {
136             die "Cannot resolve class for " . $name . " path " .
137             join("/", @{$path}) . " via " . $self->{class_resolver};
138             }
139             if (!defined($_class) or ($_class eq "__SKIP__")) {
140             $skip = join("/", @{$path});
141             $_[0]->setHandlers(Char => undef);
142             return;
143             }
144              
145             # Stepping down, adding $current to the list element of the current
146             # branch being visited.
147             push @$list, $current;
148              
149             # Cleaning up current. Mainly to help profilers find the real hot spots.
150             undef $current;
151              
152             $characters = q{};
153              
154             no warnings "once";
155             $current =
156             pop @{$SOAP::WSDL::Expat::MessageParser::OBJECT_CACHE_REF->{$_class}};
157             if (not defined $current) {
158             my $o = Class::Std::Fast::ID();
159             $current = bless \$o, $_class;
160             }
161              
162             # PATCH Creating a double link between the SOAP Object and the parser
163             # node, so it can be later use for XPath searches.
164             Google::Ads::Common::XPathSAXParser::link_object_to_node($current,
165             $node);
166             # END PATCH
167              
168             # Setting attributes if there are any.
169             if ($attrs && $current->can("attr")) {
170             $current->attr($attrs);
171             }
172             $depth++;
173             return;
174             },
175             Char => $char_handler,
176             End => sub {
177             # End of the element stepping up in the current branch path.
178             pop @{$path};
179              
180             # Checking if element need to be skipped __SKIP__.
181             if ($skip) {
182             return if $skip ne join "/", @{$path}, $_[1];
183             $skip = 0;
184             $_[0]->setHandlers(Char => $char_handler);
185             return;
186             }
187             $depth--;
188              
189             # Setting character values only if a leaf.
190             if ($_leaf) {
191             $SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType::___value->
192             {$$current} = $characters
193             if defined $characters && defined $current;
194             }
195              
196             $characters = q{};
197             $_leaf = 0;
198              
199             # Finishing if at the top of the tree of elements, no more parents.
200             if (not defined $list->[-1]) {
201             $self->{data} = $current if (not exists $self->{data});
202             return;
203             }
204              
205             # Method to be called in the parent to add the current object to it.
206             $_add_method = "add_$_[1]";
207              
208             # Fixing up XML names for Perl names.
209             $_add_method =~ s{\.}{__}xg;
210             $_add_method =~ s{\-}{_}xg;
211              
212             # PATCH Adding the element if the method to add is defined in the
213             # parent.
214             eval('use ' . ref($list->[-1]));
215             eval { $list->[-1]->$_add_method($current); };
216             if ($@) {
217             warn("Couldn't find a setter $_add_method for object of type " .
218             ref($current) . " in object of type " .
219             ref($list->[-1]) . " method " . $_add_method);
220             }
221             # END PATCH
222              
223             #Stepping up in the current object hierarchy.
224             $current = pop @$list;
225             return;
226             }
227             });
228             return $parser;
229             }
230              
231             return 1;