Profile of XML/Parser.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/x86_64-linux/XML/Parser.pm
Statements | Executed 1157 statements in 1.52ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 2.19ms | 2.51ms | XML::Parser::::BEGIN@17XML::Parser::BEGIN@17
7 | 1 | 1 | 292µs | 70.4s | XML::Parser::::parseXML::Parser::parse
14 | 3 | 1 | 141µs | 141µs | XML::Parser::::setHandlersXML::Parser::setHandlers
7 | 1 | 1 | 82µs | 82µs | XML::Parser::::newXML::Parser::new
1 | 1 | 1 | 10µs | 11µs | XML::Parser::::BEGIN@11XML::Parser::BEGIN@11
1 | 1 | 1 | 4µs | 24µs | XML::Parser::::BEGIN@15XML::Parser::BEGIN@15
0 | 0 | 0 | 0s | 0s | XML::Parser::::file_ext_ent_cleanupXML::Parser::file_ext_ent_cleanup
0 | 0 | 0 | 0s | 0s | XML::Parser::::file_ext_ent_handlerXML::Parser::file_ext_ent_handler
0 | 0 | 0 | 0s | 0s | XML::Parser::::initial_ext_ent_handlerXML::Parser::initial_ext_ent_handler
0 | 0 | 0 | 0s | 0s | XML::Parser::::parse_startXML::Parser::parse_start
0 | 0 | 0 | 0s | 0s | XML::Parser::::parsefileXML::Parser::parsefile
0 | 0 | 0 | 0s | 0s | XML::Parser::::parsestringXML::Parser::parsestring

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | # XML::Parser
2 |  |  |  |  | #
3 |  |  |  |  | # Copyright (c) 1998-2000 Larry Wall and Clark Cooper
4 |  |  |  |  | # All rights reserved.
5 |  |  |  |  | #
6 |  |  |  |  | # This program is free software; you can redistribute it and/or
7 |  |  |  |  | # modify it under the same terms as Perl itself.
8 |  |  |  |  |
9 |  |  |  |  | package XML::Parser;
10 |  |  |  |  |
11 | 2 | 31µs | 2 | 13µs | # spent 11µs (10+2) within XML::Parser::BEGIN@11 which was called: # once (10µs+2µs) by XML::Twig::BEGIN@151 at line 11 use strict; # spent 11µs making 1 call to XML::Parser::BEGIN@11 # spent 2µs making 1 call to strict::import
12 |  |  |  |  |
13 |  |  |  |  | our ( $VERSION, $LWP_load_failed );
14 |  |  |  |  |
15 | 2 | 31µs | 2 | 45µs | # spent 24µs (4+21) within XML::Parser::BEGIN@15 which was called: # once (4µs+21µs) by XML::Twig::BEGIN@151 at line 15 use Carp; # spent 24µs making 1 call to XML::Parser::BEGIN@15 # spent 21µs making 1 call to Exporter::import
16 |  |  |  |  |
17 |  |  |  |  | # spent 2.51ms (2.19+321µs) within XML::Parser::BEGIN@17 which was called: # once (2.19ms+321µs) by XML::Twig::BEGIN@151 at line 22 BEGIN {
18 | 1 | 54µs |  |  | require XML::Parser::Expat;
19 | 1 | 200ns |  |  | $VERSION = '2.47';
20 | 1 | 2µs |  |  | die "Parser.pm and Expat.pm versions don't match"
21 |  |  |  |  | unless $VERSION eq $XML::Parser::Expat::VERSION;
22 | 1 | 888µs | 1 | 2.51ms | } # spent 2.51ms making 1 call to XML::Parser::BEGIN@17
23 |  |  |  |  |
24 | 1 | 200ns |  |  | $LWP_load_failed = 0;
25 |  |  |  |  |
26 |  |  |  |  | # spent 82µs within XML::Parser::new which was called 7 times, avg 12µs/call: # 7 times (82µs+0s) by XML::Twig::new at line 465 of XML/Twig.pm, avg 12µs/call sub new {
27 | 7 | 4µs |  |  | my ( $class, %args ) = @_;
28 | 7 | 2µs |  |  | my $style = $args{Style};
29 |  |  |  |  |
30 | 7 | 4µs |  |  | my $nonexopt = $args{Non_Expat_Options} ||= {};
31 |  |  |  |  |
32 | 7 | 3µs |  |  | $nonexopt->{Style} = 1;
33 | 7 | 2µs |  |  | $nonexopt->{Non_Expat_Options} = 1;
34 | 7 | 2µs |  |  | $nonexopt->{Handlers} = 1;
35 | 7 | 2µs |  |  | $nonexopt->{_HNDL_TYPES} = 1;
36 | 7 | 2µs |  |  | $nonexopt->{NoLWP} = 1;
37 |  |  |  |  |
38 | 7 | 22µs |  |  | $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters};
39 | 7 | 3µs |  |  | $args{_HNDL_TYPES}->{Init} = 1;
40 | 7 | 2µs |  |  | $args{_HNDL_TYPES}->{Final} = 1;
41 |  |  |  |  |
42 | 7 | 4µs |  |  | $args{Handlers} ||= {};
43 | 7 | 1µs |  |  | my $handlers = $args{Handlers};
44 |  |  |  |  |
45 | 7 | 1µs |  |  | if ( defined($style) ) {
46 |  |  |  |  | my $stylepkg = $style;
47 |  |  |  |  |
48 |  |  |  |  | if ( $stylepkg !~ /::/ ) {
49 |  |  |  |  | $stylepkg = "\u$style";
50 |  |  |  |  |
51 |  |  |  |  | eval {
52 |  |  |  |  | my $fullpkg = "XML::Parser::Style::$stylepkg";
53 |  |  |  |  | my $stylefile = $fullpkg;
54 |  |  |  |  | $stylefile =~ s/::/\//g;
55 |  |  |  |  | require "$stylefile.pm";
56 |  |  |  |  | $stylepkg = $fullpkg;
57 |  |  |  |  | };
58 |  |  |  |  | if ($@) {
59 |  |  |  |  |
60 |  |  |  |  | # fallback to old behaviour
61 |  |  |  |  | $stylepkg = "XML::Parser::$stylepkg";
62 |  |  |  |  | }
63 |  |  |  |  | }
64 |  |  |  |  |
65 |  |  |  |  | foreach my $htype ( keys %{ $args{_HNDL_TYPES} } ) {
66 |  |  |  |  |
67 |  |  |  |  | # Handlers explicitly given override
68 |  |  |  |  | # handlers from the Style package
69 |  |  |  |  | unless ( defined( $handlers->{$htype} ) ) {
70 |  |  |  |  |
71 |  |  |  |  | # A handler in the style package must either have
72 |  |  |  |  | # exactly the right case as the type name or a
73 |  |  |  |  | # completely lower case version of it.
74 |  |  |  |  |
75 |  |  |  |  | my $hname = "${stylepkg}::$htype";
76 |  |  |  |  | if ( defined(&$hname) ) {
77 |  |  |  |  | $handlers->{$htype} = \&$hname;
78 |  |  |  |  | next;
79 |  |  |  |  | }
80 |  |  |  |  |
81 |  |  |  |  | $hname = "${stylepkg}::\L$htype";
82 |  |  |  |  | if ( defined(&$hname) ) {
83 |  |  |  |  | $handlers->{$htype} = \&$hname;
84 |  |  |  |  | next;
85 |  |  |  |  | }
86 |  |  |  |  | }
87 |  |  |  |  | }
88 |  |  |  |  | }
89 |  |  |  |  |
90 | 7 | 4µs |  |  | unless ( defined( $handlers->{ExternEnt} )
91 |  |  |  |  | or defined( $handlers->{ExternEntFin} ) ) {
92 |  |  |  |  |
93 | 7 | 3µs |  |  | if ( $args{NoLWP} or $LWP_load_failed ) {
94 |  |  |  |  | $handlers->{ExternEnt} = \&file_ext_ent_handler;
95 |  |  |  |  | $handlers->{ExternEntFin} = \&file_ext_ent_cleanup;
96 |  |  |  |  | }
97 |  |  |  |  | else {
98 |  |  |  |  | # The following just bootstraps the real LWP external entity
99 |  |  |  |  | # handler
100 |  |  |  |  |
101 | 7 | 6µs |  |  | $handlers->{ExternEnt} = \&initial_ext_ent_handler;
102 |  |  |  |  |
103 |  |  |  |  | # No cleanup function available until LWPExternEnt.pl loaded
104 |  |  |  |  | }
105 |  |  |  |  | }
106 |  |  |  |  |
107 | 7 | 5µs |  |  | $args{Pkg} ||= caller;
108 | 7 | 11µs |  |  | bless \%args, $class;
109 |  |  |  |  | } # End of new
110 |  |  |  |  |
111 |  |  |  |  | # spent 141µs within XML::Parser::setHandlers which was called 14 times, avg 10µs/call: # 7 times (22µs+0s) by XML::Twig::new at line 740 of XML/Twig.pm, avg 3µs/call # 6 times (104µs+0s) by XML::Twig::new at line 734 of XML/Twig.pm, avg 17µs/call # once (16µs+0s) by XML::Twig::new at line 731 of XML/Twig.pm sub setHandlers {
112 | 14 | 15µs |  |  | my ( $self, @handler_pairs ) = @_;
113 |  |  |  |  |
114 | 14 | 5µs |  |  | croak('Uneven number of arguments to setHandlers method')
115 |  |  |  |  | if ( int(@handler_pairs) & 1 );
116 |  |  |  |  |
117 | 14 | 1µs |  |  | my @ret;
118 | 14 | 3µs |  |  | while (@handler_pairs) {
119 | 118 | 15µs |  |  | my $type = shift @handler_pairs;
120 | 118 | 10µs |  |  | my $handler = shift @handler_pairs;
121 | 118 | 18µs |  |  | unless ( defined( $self->{_HNDL_TYPES}->{$type} ) ) {
122 |  |  |  |  | my @types = sort keys %{ $self->{_HNDL_TYPES} };
123 |  |  |  |  |
124 |  |  |  |  | croak("Unknown Parser handler type: $type\n Valid types: @types");
125 |  |  |  |  | }
126 | 118 | 26µs |  |  | push( @ret, $type, $self->{Handlers}->{$type} );
127 | 118 | 38µs |  |  | $self->{Handlers}->{$type} = $handler;
128 |  |  |  |  | }
129 |  |  |  |  |
130 | 14 | 18µs |  |  | return @ret;
131 |  |  |  |  | }
132 |  |  |  |  |
133 |  |  |  |  | sub parse_start {
134 |  |  |  |  | my $self = shift;
135 |  |  |  |  | my @expat_options = ();
136 |  |  |  |  |
137 |  |  |  |  | my ( $key, $val );
138 |  |  |  |  | while ( ( $key, $val ) = each %{$self} ) {
139 |  |  |  |  | push( @expat_options, $key, $val )
140 |  |  |  |  | unless exists $self->{Non_Expat_Options}->{$key};
141 |  |  |  |  | }
142 |  |  |  |  |
143 |  |  |  |  | my %handlers = %{ $self->{Handlers} };
144 |  |  |  |  | my $init = delete $handlers{Init};
145 |  |  |  |  | my $final = delete $handlers{Final};
146 |  |  |  |  |
147 |  |  |  |  | my $expatnb = XML::Parser::ExpatNB->new( @expat_options, @_ );
148 |  |  |  |  | $expatnb->setHandlers(%handlers);
149 |  |  |  |  |
150 |  |  |  |  | &$init($expatnb)
151 |  |  |  |  | if defined($init);
152 |  |  |  |  |
153 |  |  |  |  | $expatnb->{_State_} = 1;
154 |  |  |  |  |
155 |  |  |  |  | $expatnb->{FinalHandler} = $final
156 |  |  |  |  | if defined($final);
157 |  |  |  |  |
158 |  |  |  |  | return $expatnb;
159 |  |  |  |  | }
160 |  |  |  |  |
161 |  |  |  |  | # spent 70.4s (292µs+70.4) within XML::Parser::parse which was called 7 times, avg 10.1s/call: # 7 times (292µs+70.4s) by XML::Twig::parse at line 770 of XML/Twig.pm, avg 10.1s/call sub parse {
162 | 7 | 1µs |  |  | my $self = shift;
163 | 7 | 1µs |  |  | my $arg = shift;
164 | 7 | 2µs |  |  | my @expat_options = ();
165 | 7 | 1µs |  |  | my ( $key, $val );
166 | 7 | 7µs |  |  | while ( ( $key, $val ) = each %{$self} ) {
167 |  |  |  |  | push( @expat_options, $key, $val )
168 | 194 | 91µs |  |  | unless exists $self->{Non_Expat_Options}->{$key};
169 |  |  |  |  | }
170 |  |  |  |  |
171 | 7 | 16µs | 7 | 126µs | my $expat = XML::Parser::Expat->new( @expat_options, @_ ); # spent 126µs making 7 calls to XML::Parser::Expat::new, avg 18µs/call
172 | 7 | 21µs |  |  | my %handlers = %{ $self->{Handlers} };
173 | 7 | 3µs |  |  | my $init = delete $handlers{Init};
174 | 7 | 2µs |  |  | my $final = delete $handlers{Final};
175 |  |  |  |  |
176 | 7 | 12µs | 7 | 263µs | $expat->setHandlers(%handlers); # spent 263µs making 7 calls to XML::Parser::Expat::setHandlers, avg 38µs/call
177 |  |  |  |  |
178 | 7 | 2µs |  |  | if ( $self->{Base} ) {
179 |  |  |  |  | $expat->base( $self->{Base} );
180 |  |  |  |  | }
181 |  |  |  |  |
182 | 7 | 6µs | 7 | 44µs | &$init($expat) # spent 44µs making 7 calls to XML::Twig::_twig_init, avg 6µs/call
183 |  |  |  |  | if defined($init);
184 |  |  |  |  |
185 | 7 | 2µs |  |  | my @result = ();
186 | 7 | 700ns |  |  | my $result;
187 | 14 | 25µs | 7 | 70.4s | eval { $result = $expat->parse($arg); }; # spent 70.4s making 7 calls to XML::Parser::Expat::parse, avg 10.1s/call
188 | 7 | 2µs |  |  | my $err = $@;
189 | 7 | 1µs |  |  | if ($err) {
190 |  |  |  |  | $expat->release;
191 |  |  |  |  | die $err;
192 |  |  |  |  | }
193 |  |  |  |  |
194 | 7 | 4µs |  |  | if ( $result and defined($final) ) {
195 |  |  |  |  | if (wantarray) {
196 |  |  |  |  | @result = &$final($expat);
197 |  |  |  |  | }
198 |  |  |  |  | else {
199 | 7 | 7µs | 7 | 88µs | $result = &$final($expat); # spent 88µs making 7 calls to XML::Twig::_twig_final, avg 13µs/call
200 |  |  |  |  | }
201 |  |  |  |  | }
202 |  |  |  |  |
203 | 7 | 7µs | 7 | 18µs | $expat->release; # spent 18µs making 7 calls to XML::Parser::Expat::release, avg 3µs/call
204 |  |  |  |  |
205 | 7 | 2µs |  |  | return unless defined wantarray;
206 | 7 | 58µs | 7 | 632µs | return wantarray ? @result : $result; # spent 632µs making 7 calls to XML::Parser::Expat::DESTROY, avg 90µs/call
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | sub parsestring {
210 |  |  |  |  | my $self = shift;
211 |  |  |  |  | $self->parse(@_);
212 |  |  |  |  | }
213 |  |  |  |  |
214 |  |  |  |  | sub parsefile {
215 |  |  |  |  | my $self = shift;
216 |  |  |  |  | my $file = shift;
217 |  |  |  |  |
218 |  |  |  |  | open( my $fh, '<', $file ) or croak "Couldn't open $file:\n$!";
219 |  |  |  |  | binmode($fh);
220 |  |  |  |  | my @ret;
221 |  |  |  |  | my $ret;
222 |  |  |  |  |
223 |  |  |  |  | $self->{Base} = $file;
224 |  |  |  |  |
225 |  |  |  |  | if (wantarray) {
226 |  |  |  |  | eval { @ret = $self->parse( $fh, @_ ); };
227 |  |  |  |  | }
228 |  |  |  |  | else {
229 |  |  |  |  | eval { $ret = $self->parse( $fh, @_ ); };
230 |  |  |  |  | }
231 |  |  |  |  | my $err = $@;
232 |  |  |  |  | close($fh);
233 |  |  |  |  | die $err if $err;
234 |  |  |  |  |
235 |  |  |  |  | return unless defined wantarray;
236 |  |  |  |  | return wantarray ? @ret : $ret;
237 |  |  |  |  | }
238 |  |  |  |  |
239 |  |  |  |  | sub initial_ext_ent_handler {
240 |  |  |  |  |
241 |  |  |  |  | # This just bootstraps in the real lwp_ext_ent_handler which
242 |  |  |  |  | # also loads the URI and LWP modules.
243 |  |  |  |  |
244 |  |  |  |  | unless ($LWP_load_failed) {
245 |  |  |  |  | local ($^W) = 0;
246 |  |  |  |  |
247 |  |  |  |  | my $stat = eval { require('XML/Parser/LWPExternEnt.pl'); };
248 |  |  |  |  |
249 |  |  |  |  | if ($stat) {
250 |  |  |  |  | $_[0]->setHandlers(
251 |  |  |  |  | ExternEnt => \&lwp_ext_ent_handler,
252 |  |  |  |  | ExternEntFin => \&lwp_ext_ent_cleanup
253 |  |  |  |  | );
254 |  |  |  |  |
255 |  |  |  |  | goto &lwp_ext_ent_handler;
256 |  |  |  |  | }
257 |  |  |  |  |
258 |  |  |  |  | # Failed to load lwp handler, act as if NoLWP
259 |  |  |  |  |
260 |  |  |  |  | $LWP_load_failed = 1;
261 |  |  |  |  |
262 |  |  |  |  | my $cmsg = "Couldn't load LWP based external entity handler\n" . "Switching to file-based external entity handler\n" . " (To avoid this message, use NoLWP option to XML::Parser)\n";
263 |  |  |  |  | warn($cmsg);
264 |  |  |  |  | }
265 |  |  |  |  |
266 |  |  |  |  | $_[0]->setHandlers(
267 |  |  |  |  | ExternEnt => \&file_ext_ent_handler,
268 |  |  |  |  | ExternEntFin => \&file_ext_ent_cleanup
269 |  |  |  |  | );
270 |  |  |  |  | goto &file_ext_ent_handler;
271 |  |  |  |  |
272 |  |  |  |  | }
273 |  |  |  |  |
274 |  |  |  |  | sub file_ext_ent_handler {
275 |  |  |  |  | my ( $xp, $base, $path ) = @_;
276 |  |  |  |  |
277 |  |  |  |  | # Prepend base only for relative paths
278 |  |  |  |  |
279 |  |  |  |  | if ( defined($base)
280 |  |  |  |  | and not( $path =~ m!^(?:[\\/]|\w+:)! ) ) {
281 |  |  |  |  | my $newpath = $base;
282 |  |  |  |  | $newpath =~ s![^\\/:]*$!$path!;
283 |  |  |  |  | $path = $newpath;
284 |  |  |  |  | }
285 |  |  |  |  |
286 |  |  |  |  | if ( $path =~ /^\s*[|>+]/
287 |  |  |  |  | or $path =~ /\|\s*$/ ) {
288 |  |  |  |  | $xp->{ErrorMessage} .= "System ID ($path) contains Perl IO control characters";
289 |  |  |  |  | return undef;
290 |  |  |  |  | }
291 |  |  |  |  |
292 |  |  |  |  | require IO::File;
293 |  |  |  |  | my $fh = IO::File->new($path);
294 |  |  |  |  | unless ( defined $fh ) {
295 |  |  |  |  | $xp->{ErrorMessage} .= "Failed to open $path:\n$!";
296 |  |  |  |  | return undef;
297 |  |  |  |  | }
298 |  |  |  |  |
299 |  |  |  |  | $xp->{_BaseStack} ||= [];
300 |  |  |  |  | $xp->{_FhStack} ||= [];
301 |  |  |  |  |
302 |  |  |  |  | push( @{ $xp->{_BaseStack} }, $base );
303 |  |  |  |  | push( @{ $xp->{_FhStack} }, $fh );
304 |  |  |  |  |
305 |  |  |  |  | $xp->base($path);
306 |  |  |  |  |
307 |  |  |  |  | return $fh;
308 |  |  |  |  | }
309 |  |  |  |  |
310 |  |  |  |  | sub file_ext_ent_cleanup {
311 |  |  |  |  | my ($xp) = @_;
312 |  |  |  |  |
313 |  |  |  |  | my $fh = pop( @{ $xp->{_FhStack} } );
314 |  |  |  |  | $fh->close;
315 |  |  |  |  |
316 |  |  |  |  | my $base = pop( @{ $xp->{_BaseStack} } );
317 |  |  |  |  | $xp->base($base);
318 |  |  |  |  | }
319 |  |  |  |  |
320 | 1 | 2µs |  |  | 1;
321 |  |  |  |  |
322 |  |  |  |  | __END__