← Index
NYTProf Performance Profile   « line view »
For webmerge/scripts/webmerge.pl
  Run on Mon Oct 7 02:42:42 2013
Reported on Mon Oct 7 03:03:27 2013

Filename/usr/lib64/perl5/vendor_perl/5.16.0/XML/Simple.pm
StatementsExecuted 9533 statements in 93.9ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1322116.2ms19.6msXML::Simple::::collapseXML::Simple::collapse (recurses: max depth 3, inclusive time 32.4ms)
2117.77ms466msXML::Simple::::build_treeXML::Simple::build_tree
32317.45ms12.1msXML::Simple::::value_to_xmlXML::Simple::value_to_xml (recurses: max depth 5, inclusive time 39.2ms)
291217.16ms7.16msXML::Simple::::charactersXML::Simple::characters
132216.94ms6.94msXML::Simple::::start_elementXML::Simple::start_element
50212.83ms3.33msXML::Simple::::escape_valueXML::Simple::escape_value
235411.60ms2.44msXML::Simple::::CORE:matchXML::Simple::CORE:match (opcode)
132211.58ms1.58msXML::Simple::::end_elementXML::Simple::end_element
321973µs989µsXML::Simple::::handle_optionsXML::Simple::handle_options
811616µs686µsXML::Simple::::sorted_keysXML::Simple::sorted_keys
311575µs854µsXML::Simple::::newXML::Simple::new
20961538µs538µsXML::Simple::::CORE:substXML::Simple::CORE:subst (opcode)
211378µs486msXML::Simple::::build_simple_treeXML::Simple::build_simple_tree
111299µs13.0msXML::Simple::::XMLoutXML::Simple::XMLout
311261µs261µsXML::Simple::::_strict_mode_for_callerXML::Simple::_strict_mode_for_caller
531229µs1.31msXML::Simple::::_get_objectXML::Simple::_get_object
221215µs488msXML::Simple::::XMLinXML::Simple::XMLin
211161µs487msXML::Simple::::parse_stringXML::Simple::parse_string
111109µs117µsXML::Simple::::importXML::Simple::import
11178µs98µsXML::Simple::::BEGIN@1712XML::Simple::BEGIN@1712
81170µs70µsXML::Simple::::CORE:sortXML::Simple::CORE:sort (opcode)
21165µs65µsXML::Simple::::end_documentXML::Simple::end_document
21161µs61µsXML::Simple::::start_documentXML::Simple::start_document
11156µs323µsXML::Simple::::BEGIN@41XML::Simple::BEGIN@41
11153µs490µsXML::Simple::::BEGIN@49XML::Simple::BEGIN@49
11153µs53µsXML::Simple::::BEGIN@2XML::Simple::BEGIN@2
11152µs148µsXML::Simple::::BEGIN@40XML::Simple::BEGIN@40
0000s0sXML::Simple::::array_to_hashXML::Simple::array_to_hash
0000s0sXML::Simple::::build_tree_xml_parserXML::Simple::build_tree_xml_parser
0000s0sXML::Simple::::cache_read_memcopyXML::Simple::cache_read_memcopy
0000s0sXML::Simple::::cache_read_memshareXML::Simple::cache_read_memshare
0000s0sXML::Simple::::cache_read_storableXML::Simple::cache_read_storable
0000s0sXML::Simple::::cache_write_memcopyXML::Simple::cache_write_memcopy
0000s0sXML::Simple::::cache_write_memshareXML::Simple::cache_write_memshare
0000s0sXML::Simple::::cache_write_storableXML::Simple::cache_write_storable
0000s0sXML::Simple::::collapse_contentXML::Simple::collapse_content
0000s0sXML::Simple::::copy_hashXML::Simple::copy_hash
0000s0sXML::Simple::::default_config_fileXML::Simple::default_config_file
0000s0sXML::Simple::::die_or_warnXML::Simple::die_or_warn
0000s0sXML::Simple::::find_xml_fileXML::Simple::find_xml_file
0000s0sXML::Simple::::get_varXML::Simple::get_var
0000s0sXML::Simple::::hash_to_arrayXML::Simple::hash_to_array
0000s0sXML::Simple::::new_hashrefXML::Simple::new_hashref
0000s0sXML::Simple::::normalise_spaceXML::Simple::normalise_space
0000s0sXML::Simple::::numeric_escapeXML::Simple::numeric_escape
0000s0sXML::Simple::::parse_fhXML::Simple::parse_fh
0000s0sXML::Simple::::parse_fileXML::Simple::parse_file
0000s0sXML::Simple::::set_varXML::Simple::set_var
0000s0sXML::Simple::::storable_filenameXML::Simple::storable_filename
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package XML::Simple;
2
# spent 53µs within XML::Simple::BEGIN@2 which was called: # once (53µs+0s) by main::BEGIN@235 at line 4
BEGIN {
3136µs $XML::Simple::VERSION = '2.20';
41187µs153µs}
# spent 53µs making 1 call to XML::Simple::BEGIN@2
5
6=head1 NAME
7
8XML::Simple - Easily read/write XML (esp config files)
9
10=head1 SYNOPSIS
11
12 use XML::Simple qw(:strict);
13
14 my $ref = XMLin([<xml file or string>] [, <options>]);
15
16 my $xml = XMLout($hashref [, <options>]);
17
18Or the object oriented way:
19
20 require XML::Simple qw(:strict);
21
22 my $xs = XML::Simple->new([<options>]);
23
24 my $ref = $xs->XMLin([<xml file or string>] [, <options>]);
25
26 my $xml = $xs->XMLout($hashref [, <options>]);
27
28(or see L<"SAX SUPPORT"> for 'the SAX way').
29
30Note, in these examples, the square brackets are used to denote optional items
31not to imply items should be supplied in arrayrefs.
32
33=cut
34
35# See after __END__ for more POD documentation
36
37
38# Load essentials here, other modules loaded on demand later
39
402144µs2243µs
# spent 148µs (52+96) within XML::Simple::BEGIN@40 which was called: # once (52µs+96µs) by main::BEGIN@235 at line 40
use strict;
# spent 148µs making 1 call to XML::Simple::BEGIN@40 # spent 96µs making 1 call to strict::import
412222µs2590µs
# spent 323µs (56+267) within XML::Simple::BEGIN@41 which was called: # once (56µs+267µs) by main::BEGIN@235 at line 41
use Carp;
# spent 323µs making 1 call to XML::Simple::BEGIN@41 # spent 267µs making 1 call to Exporter::import
4214µsrequire Exporter;
43
44
45##############################################################################
46# Define some constants
47#
48
49233.8ms2928µs
# spent 490µs (53+437) within XML::Simple::BEGIN@49 which was called: # once (53µs+437µs) by main::BEGIN@235 at line 49
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);
# spent 490µs making 1 call to XML::Simple::BEGIN@49 # spent 437µs making 1 call to vars::import
50
51139µs@ISA = qw(Exporter);
5217µs@EXPORT = qw(XMLin XMLout);
5314µs@EXPORT_OK = qw(xml_in xml_out);
5412µs$PREFERRED_PARSER = undef;
55
5615µsmy %StrictMode = ();
57
58116µsmy @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr
59 searchpath forcearray cache suppressempty parseropts
60 grouptags nsexpand datahandler varattr variables
61 normalisespace normalizespace valueattr strictmode);
62
63113µsmy @KnownOptOut = qw(keyattr keeproot contentkey noattr
64 rootname xmldecl outputfile noescape suppressempty
65 grouptags nsexpand handler noindent attrindent nosort
66 valueattr numericescape strictmode);
67
6814µsmy @DefKeyAttr = qw(name key id);
6912µsmy $DefRootName = qq(opt);
7011µsmy $DefContentKey = qq(content);
7111µsmy $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>);
72
7311µsmy $xmlns_ns = 'http://www.w3.org/2000/xmlns/';
7417µsmy $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround
75
76
77##############################################################################
78# Globals for use by caching routines
79#
80
8112µsmy %MemShareCache = ();
8211µsmy %MemCopyCache = ();
83
84
85##############################################################################
86# Wrapper for Exporter - handles ':strict'
87#
88
89
# spent 117µs (109+9) within XML::Simple::import which was called: # once (109µs+9µs) by main::BEGIN@235 at line 235 of webmerge/scripts/webmerge.pl
sub import {
90 # Handle the :strict tag
91
9218µs my($calling_package) = caller();
93157µs16µs _strict_mode_for_caller(1) if grep(/^:strict$/, @_);
# spent 6µs making 1 call to XML::Simple::CORE:match
94
95 # Pass everything else to Exporter.pm
96
97130µs12µs @_ = grep(!/^:strict$/, @_);
# spent 2µs making 1 call to XML::Simple::CORE:match
98139µs1197µs goto &Exporter::import;
# spent 197µs making 1 call to Exporter::import
99}
100
101
102##############################################################################
103# Constructor for optional object interface.
104#
105
106
# spent 854µs (575+278) within XML::Simple::new which was called 3 times, avg 285µs/call: # 3 times (575µs+278µs) by XML::Simple::_get_object at line 166, avg 285µs/call
sub new {
10739µs my $class = shift;
108
109312µs if(@_ % 2) {
110 croak "Default options must be name=>value pairs (odd number supplied)";
111 }
112
11334µs my %known_opt;
1143124µs @known_opt{@KnownOptIn, @KnownOptOut} = ();
115
116315µs my %raw_opt = @_;
117351µs3261µs $raw_opt{strictmode} = _strict_mode_for_caller()
# spent 261µs making 3 calls to XML::Simple::_strict_mode_for_caller, avg 87µs/call
118 unless exists $raw_opt{strictmode};
11933µs my %def_opt;
1203103µs while(my($key, $val) = each %raw_opt) {
121312µs my $lkey = lc($key);
122375µs317µs $lkey =~ s/_//g;
# spent 17µs making 3 calls to XML::Simple::CORE:subst, avg 6µs/call
12337µs croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
124316µs $def_opt{$lkey} = $val;
125 }
126324µs my $self = { def_opt => \%def_opt };
127
1283135µs return(bless($self, $class));
129}
130
131
132##############################################################################
133# Sub: _strict_mode_for_caller()
134#
135# Gets or sets the XML::Simple :strict mode flag for the calling namespace.
136# Walks back through call stack to find the calling namespace and sets the
137# :strict mode flag for that namespace if an argument was supplied and returns
138# the flag value if not.
139#
140
141
# spent 261µs within XML::Simple::_strict_mode_for_caller which was called 3 times, avg 87µs/call: # 3 times (261µs+0s) by XML::Simple::new at line 117, avg 87µs/call
sub _strict_mode_for_caller {
14239µs my $set_mode = @_;
14333µs my $frame = 1;
1443159µs while(my($package) = caller($frame++)) {
145947µs next if $package eq 'XML::Simple';
14632µs $StrictMode{$package} = 1 if $set_mode;
147370µs return $StrictMode{$package};
148 }
149 return(0);
150}
151
152
153##############################################################################
154# Sub: _get_object()
155#
156# Helper routine called from XMLin() and XMLout() to create an object if none
157# was provided. Note, this routine does mess with the caller's @_ array.
158#
159
160
# spent 1.31ms (229µs+1.08) within XML::Simple::_get_object which was called 5 times, avg 262µs/call: # 2 times (127µs+820µs) by XML::Simple::XMLin at line 185, avg 473µs/call # 2 times (49µs+19µs) by XML::Simple::parse_string at line 285, avg 34µs/call # once (53µs+242µs) by XML::Simple::XMLout at line 584
sub _get_object {
16156µs my $self;
1625327µs5227µs if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) {
# spent 227µs making 5 calls to UNIVERSAL::isa, avg 45µs/call
163 $self = shift;
164 }
165 else {
166363µs3854µs $self = XML::Simple->new();
# spent 854µs making 3 calls to XML::Simple::new, avg 285µs/call
167 }
168
169586µs return $self;
170}
171
172
173##############################################################################
174# Sub/Method: XMLin()
175#
176# Exported routine for slurping XML into a hashref - see pod for info.
177#
178# May be called as object method or as a plain function.
179#
180# Expects one arg for the source XML, optionally followed by a number of
181# name => value option pairs.
182#
183
184
# spent 488ms (215µs+488) within XML::Simple::XMLin which was called 2 times, avg 244ms/call: # once (125µs+395ms) by main::get_xml at line 289 of webmerge/scripts/webmerge.pl # once (90µs+92.9ms) by main::read_xml at line 319 of webmerge/scripts/webmerge.pl
sub XMLin {
185218µs2947µs my $self = &_get_object; # note, @_ is passed implicitly
# spent 947µs making 2 calls to XML::Simple::_get_object, avg 473µs/call
186
187218µs my $target = shift;
188
189
190 # Work out whether to parse a string, a file or a filehandle
191
1922225µs4487ms if(not defined $target) {
# spent 487ms making 2 calls to XML::Simple::parse_string, avg 244ms/call # spent 48µs making 2 calls to XML::Simple::CORE:match, avg 24µs/call
193 return $self->parse_file(undef, @_);
194 }
195
196 elsif($target eq '-') {
197 local($/) = undef;
198 $target = <STDIN>;
199 return $self->parse_string(\$target, @_);
200 }
201
202 elsif(my $type = ref($target)) {
203 if($type eq 'SCALAR') {
204 return $self->parse_string($target, @_);
205 }
206 else {
207 return $self->parse_fh($target, @_);
208 }
209 }
210
211 elsif($target =~ m{<.*?>}s) {
212 return $self->parse_string(\$target, @_);
213 }
214
215 else {
216 return $self->parse_file($target, @_);
217 }
218}
219
220
221##############################################################################
222# Sub/Method: parse_file()
223#
224# Same as XMLin, but only parses from a named file.
225#
226
227sub parse_file {
228 my $self = &_get_object; # note, @_ is passed implicitly
229
230 my $filename = shift;
231
232 $self->handle_options('in', @_);
233
234 $filename = $self->default_config_file if not defined $filename;
235
236 $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}});
237
238 # Check cache for previous parse
239
240 if($self->{opt}->{cache}) {
241 foreach my $scheme (@{$self->{opt}->{cache}}) {
242 my $method = 'cache_read_' . $scheme;
243 my $opt = $self->$method($filename);
244 return($opt) if($opt);
245 }
246 }
247
248 my $ref = $self->build_simple_tree($filename, undef);
249
250 if($self->{opt}->{cache}) {
251 my $method = 'cache_write_' . $self->{opt}->{cache}->[0];
252 $self->$method($ref, $filename);
253 }
254
255 return $ref;
256}
257
258
259##############################################################################
260# Sub/Method: parse_fh()
261#
262# Same as XMLin, but only parses from a filehandle.
263#
264
265sub parse_fh {
266 my $self = &_get_object; # note, @_ is passed implicitly
267
268 my $fh = shift;
269 croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') .
270 " as a filehandle" unless ref $fh;
271
272 $self->handle_options('in', @_);
273
274 return $self->build_simple_tree(undef, $fh);
275}
276
277
278##############################################################################
279# Sub/Method: parse_string()
280#
281# Same as XMLin, but only parses from a string or a reference to a string.
282#
283
284
# spent 487ms (161µs+487) within XML::Simple::parse_string which was called 2 times, avg 244ms/call: # 2 times (161µs+487ms) by XML::Simple::XMLin at line 192, avg 244ms/call
sub parse_string {
285215µs268µs my $self = &_get_object; # note, @_ is passed implicitly
# spent 68µs making 2 calls to XML::Simple::_get_object, avg 34µs/call
286
28723µs my $string = shift;
288
289225µs2690µs $self->handle_options('in', @_);
# spent 690µs making 2 calls to XML::Simple::handle_options, avg 345µs/call
290
291269µs2486ms return $self->build_simple_tree(undef, ref $string ? $string : \$string);
# spent 486ms making 2 calls to XML::Simple::build_simple_tree, avg 243ms/call
292}
293
294
295##############################################################################
296# Method: default_config_file()
297#
298# Returns the name of the XML file to parse if no filename (or XML string)
299# was provided.
300#
301
302sub default_config_file {
303 my $self = shift;
304
305 require File::Basename;
306
307 my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+');
308
309 # Add script directory to searchpath
310
311 if($script_dir) {
312 unshift(@{$self->{opt}->{searchpath}}, $script_dir);
313 }
314
315 return $basename . '.xml';
316}
317
318
319##############################################################################
320# Method: build_simple_tree()
321#
322# Builds a 'tree' data structure as provided by XML::Parser and then
323# 'simplifies' it as specified by the various options in effect.
324#
325
326
# spent 486ms (378µs+486) within XML::Simple::build_simple_tree which was called 2 times, avg 243ms/call: # 2 times (378µs+486ms) by XML::Simple::parse_string at line 291, avg 243ms/call
sub build_simple_tree {
32727µs my $self = shift;
328
329224µs2466ms my $tree = $self->build_tree(@_);
# spent 466ms making 2 calls to XML::Simple::build_tree, avg 233ms/call
330
331 return $self->{opt}->{keeproot}
332 ? $self->collapse({}, @$tree)
3332346µs219.6ms : $self->collapse(@{$tree->[1]});
# spent 19.6ms making 2 calls to XML::Simple::collapse, avg 9.81ms/call
334}
335
336
337##############################################################################
338# Method: build_tree()
339#
340# This routine will be called if there is no suitable pre-parsed tree in a
341# cache. It parses the XML and returns an XML::Parser 'Tree' style data
342# structure (summarised in the comments for the collapse() routine below).
343#
344# XML::Simple requires the services of another module that knows how to parse
345# XML. If XML::SAX is installed, the default SAX parser will be used,
346# otherwise XML::Parser will be used.
347#
348# This routine expects to be passed a filename as argument 1 or a 'string' as
349# argument 2. The 'string' might be a string of XML (passed by reference to
350# save memory) or it might be a reference to an IO::Handle. (This
351# non-intuitive mess results in part from the way XML::Parser works but that's
352# really no excuse).
353#
354
355
# spent 466ms (7.77+458) within XML::Simple::build_tree which was called 2 times, avg 233ms/call: # 2 times (7.77ms+458ms) by XML::Simple::build_simple_tree at line 329, avg 233ms/call
sub build_tree {
35624µs my $self = shift;
35722µs my $filename = shift;
35822µs my $string = shift;
359
360
36122µs my $preferred_parser = $PREFERRED_PARSER;
362212µs unless(defined($preferred_parser)) {
363 $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
364 }
36522µs if($preferred_parser eq 'XML::Parser') {
366 return($self->build_tree_xml_parser($filename, $string));
367 }
368
3694528µs eval { require XML::SAX; }; # We didn't need it until now
37022µs if($@) { # No XML::SAX - fall back to XML::Parser
371 if($preferred_parser) { # unless a SAX parser was expressly requested
372 croak "XMLin() could not load XML::SAX";
373 }
374 return($self->build_tree_xml_parser($filename, $string));
375 }
376
37722µs $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);
378
379254µs2313ms my $sp = XML::SAX::ParserFactory->parser(Handler => $self);
# spent 313ms making 2 calls to XML::SAX::ParserFactory::parser, avg 157ms/call
380
381210µs $self->{nocollapse} = 1;
38222µs my($tree);
38329µs if($filename) {
384 $tree = $sp->parse_uri($filename);
385 }
386 else {
387216µs if(ref($string) && ref($string) ne 'SCALAR') {
388 $tree = $sp->parse_file($string);
389 }
390 else {
391242µs2135ms $tree = $sp->parse_string($$string);
# spent 135ms making 2 calls to XML::SAX::Base::parse_string, avg 67.4ms/call
392 }
393 }
394
3952151µs return($tree);
396}
397
398
399##############################################################################
400# Method: build_tree_xml_parser()
401#
402# This routine will be called if XML::SAX is not installed, or if XML::Parser
403# was specifically requested. It takes the same arguments as build_tree() and
404# returns the same data structure (XML::Parser 'Tree' style).
405#
406
407sub build_tree_xml_parser {
408 my $self = shift;
409 my $filename = shift;
410 my $string = shift;
411
412
413 eval {
414 local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load()
415 require XML::Parser; # We didn't need it until now
416 };
417 if($@) {
418 croak "XMLin() requires either XML::SAX or XML::Parser";
419 }
420
421 if($self->{opt}->{nsexpand}) {
422 carp "'nsexpand' option requires XML::SAX";
423 }
424
425 my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}});
426 my($tree);
427 if($filename) {
428 # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl
429 open(my $xfh, '<', $filename) || croak qq($filename - $!);
430 $tree = $xp->parse($xfh);
431 }
432 else {
433 $tree = $xp->parse($$string);
434 }
435
436 return($tree);
437}
438
439
440##############################################################################
441# Method: cache_write_storable()
442#
443# Wrapper routine for invoking Storable::nstore() to cache a parsed data
444# structure.
445#
446
447sub cache_write_storable {
448 my($self, $data, $filename) = @_;
449
450 my $cachefile = $self->storable_filename($filename);
451
452 require Storable; # We didn't need it until now
453
454 if ('VMS' eq $^O) {
455 Storable::nstore($data, $cachefile);
456 }
457 else {
458 # If the following line fails for you, your Storable.pm is old - upgrade
459 Storable::lock_nstore($data, $cachefile);
460 }
461
462}
463
464
465##############################################################################
466# Method: cache_read_storable()
467#
468# Wrapper routine for invoking Storable::retrieve() to read a cached parsed
469# data structure. Only returns cached data if the cache file exists and is
470# newer than the source XML file.
471#
472
473sub cache_read_storable {
474 my($self, $filename) = @_;
475
476 my $cachefile = $self->storable_filename($filename);
477
478 return unless(-r $cachefile);
479 return unless((stat($cachefile))[9] > (stat($filename))[9]);
480
481 require Storable; # We didn't need it until now
482
483 if ('VMS' eq $^O) {
484 return(Storable::retrieve($cachefile));
485 }
486 else {
487 return(Storable::lock_retrieve($cachefile));
488 }
489
490}
491
492
493##############################################################################
494# Method: storable_filename()
495#
496# Translates the supplied source XML filename into a filename for the storable
497# cached data. A '.stor' suffix is added after stripping an optional '.xml'
498# suffix.
499#
500
501sub storable_filename {
502 my($self, $cachefile) = @_;
503
504 $cachefile =~ s{(\.xml)?$}{.stor};
505 return $cachefile;
506}
507
508
509##############################################################################
510# Method: cache_write_memshare()
511#
512# Takes the supplied data structure reference and stores it away in a global
513# hash structure.
514#
515
516sub cache_write_memshare {
517 my($self, $data, $filename) = @_;
518
519 $MemShareCache{$filename} = [time(), $data];
520}
521
522
523##############################################################################
524# Method: cache_read_memshare()
525#
526# Takes a filename and looks in a global hash for a cached parsed version.
527#
528
529sub cache_read_memshare {
530 my($self, $filename) = @_;
531
532 return unless($MemShareCache{$filename});
533 return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);
534
535 return($MemShareCache{$filename}->[1]);
536
537}
538
539
540##############################################################################
541# Method: cache_write_memcopy()
542#
543# Takes the supplied data structure and stores a copy of it in a global hash
544# structure.
545#
546
547sub cache_write_memcopy {
548 my($self, $data, $filename) = @_;
549
550 require Storable; # We didn't need it until now
551
552 $MemCopyCache{$filename} = [time(), Storable::dclone($data)];
553}
554
555
556##############################################################################
557# Method: cache_read_memcopy()
558#
559# Takes a filename and looks in a global hash for a cached parsed version.
560# Returns a reference to a copy of that data structure.
561#
562
563sub cache_read_memcopy {
564 my($self, $filename) = @_;
565
566 return unless($MemCopyCache{$filename});
567 return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);
568
569 return(Storable::dclone($MemCopyCache{$filename}->[1]));
570
571}
572
573
574##############################################################################
575# Sub/Method: XMLout()
576#
577# Exported routine for 'unslurping' a data structure out to XML.
578#
579# Expects a reference to a data structure and an optional list of option
580# name => value pairs.
581#
582
583
# spent 13.0ms (299µs+12.7) within XML::Simple::XMLout which was called: # once (299µs+12.7ms) by main::get_xml at line 292 of webmerge/scripts/webmerge.pl
sub XMLout {
58419µs1295µs my $self = &_get_object; # note, @_ is passed implicitly
# spent 295µs making 1 call to XML::Simple::_get_object
585
58612µs croak "XMLout() requires at least one argument" unless(@_);
58712µs my $ref = shift;
588
589112µs1299µs $self->handle_options('out', @_);
# spent 299µs making 1 call to XML::Simple::handle_options
590
591
592 # If namespace expansion is set, XML::NamespaceSupport is required
593
59414µs if($self->{opt}->{nsexpand}) {
595 require XML::NamespaceSupport;
596 $self->{nsup} = XML::NamespaceSupport->new();
597 $self->{ns_prefix} = 'aaa';
598 }
599
600
601 # Wrap top level arrayref in a hash
602
603186µs18µs if(UNIVERSAL::isa($ref, 'ARRAY')) {
# spent 8µs making 1 call to UNIVERSAL::isa
604 $ref = { anon => $ref };
605 }
606
607
608 # Extract rootname from top level hash if keeproot enabled
609
610110µs if($self->{opt}->{keeproot}) {
611 my(@keys) = keys(%$ref);
612 if(@keys == 1) {
613 $ref = $ref->{$keys[0]};
614 $self->{opt}->{rootname} = $keys[0];
615 }
616 }
617
618 # Ensure there are no top level attributes if we're not adding root elements
619
620 elsif($self->{opt}->{rootname} eq '') {
621128µs17µs if(UNIVERSAL::isa($ref, 'HASH')) {
# spent 7µs making 1 call to UNIVERSAL::isa
62212µs my $refsave = $ref;
62313µs $ref = {};
624112µs foreach (keys(%$refsave)) {
625225µs if(ref($refsave->{$_})) {
626 $ref->{$_} = $refsave->{$_};
627 }
628 else {
629 $ref->{$_} = [ $refsave->{$_} ];
630 }
631 }
632 }
633 }
634
635
636 # Encode the hashref and write to file if necessary
637
63815µs $self->{_ancestors} = [];
639116µs112.1ms my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
# spent 12.1ms making 1 call to XML::Simple::value_to_xml
64017µs delete $self->{_ancestors};
641
64213µs if($self->{opt}->{xmldecl}) {
643 $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
644 }
645
64616µs if($self->{opt}->{outputfile}) {
647 if(ref($self->{opt}->{outputfile})) {
648 my $fh = $self->{opt}->{outputfile};
649 if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) {
650 eval { require IO::Handle; };
651 croak $@ if $@;
652 }
653 return($fh->print($xml));
654 }
655 else {
656 open(my $out, '>', "$self->{opt}->{outputfile}") ||
657 croak "open($self->{opt}->{outputfile}): $!";
658 binmode($out, ':utf8') if($] >= 5.008);
659 print $out $xml or croak "print: $!";
660 close $out or croak "close: $!";
661 }
662 }
663 elsif($self->{opt}->{handler}) {
664 require XML::SAX;
665 my $sp = XML::SAX::ParserFactory->parser(
666 Handler => $self->{opt}->{handler}
667 );
668 return($sp->parse_string($xml));
669 }
670 else {
671151µs return($xml);
672 }
673}
674
675
676##############################################################################
677# Method: handle_options()
678#
679# Helper routine for both XMLin() and XMLout(). Both routines handle their
680# first argument and assume all other args are options handled by this routine.
681# Saves a hash of options in $self->{opt}.
682#
683# If default options were passed to the constructor, they will be retrieved
684# here and merged with options supplied to the method call.
685#
686# First argument should be the string 'in' or the string 'out'.
687#
688# Remaining arguments should be name=>value pairs. Sets up default values
689# for options not supplied. Unrecognised options are a fatal error.
690#
691
692
# spent 989µs (973+16) within XML::Simple::handle_options which was called 3 times, avg 330µs/call: # 2 times (679µs+11µs) by XML::Simple::parse_string at line 289, avg 345µs/call # once (294µs+5µs) by XML::Simple::XMLout at line 589
sub handle_options {
69335µs my $self = shift;
69435µs my $dirn = shift;
695
696
697 # Determine valid options based on context
698
69933µs my %known_opt;
700399µs if($dirn eq 'in') {
701 @known_opt{@KnownOptIn} = @KnownOptIn;
702 }
703 else {
704132µs @known_opt{@KnownOptOut} = @KnownOptOut;
705 }
706
707
708 # Store supplied options in hashref and weed out invalid ones
709
71039µs if(@_ % 2) {
711 croak "Options must be name=>value pairs (odd number supplied)";
712 }
713325µs my %raw_opt = @_;
714310µs my $opt = {};
715311µs $self->{opt} = $opt;
716
717376µs while(my($key, $val) = each %raw_opt) {
718613µs my $lkey = lc($key);
719691µs616µs $lkey =~ s/_//g;
# spent 16µs making 6 calls to XML::Simple::CORE:subst, avg 3µs/call
720612µs croak "Unrecognised option: $key" unless($known_opt{$lkey});
721632µs $opt->{$lkey} = $val;
722 }
723
724
725 # Merge in options passed to constructor
726
727357µs foreach (keys(%known_opt)) {
72856184µs unless(exists($opt->{$_})) {
729 if(exists($self->{def_opt}->{$_})) {
730 $opt->{$_} = $self->{def_opt}->{$_};
731 }
732 }
733 }
734
735
736 # Set sensible defaults if not supplied
737
738314µs if(exists($opt->{rootname})) {
739 unless(defined($opt->{rootname})) {
740 $opt->{rootname} = '';
741 }
742 }
743 else {
744211µs $opt->{rootname} = $DefRootName;
745 }
746
74736µs if($opt->{xmldecl} and $opt->{xmldecl} eq '1') {
748 $opt->{xmldecl} = $DefXmlDecl;
749 }
750
75137µs if(exists($opt->{contentkey})) {
752 if($opt->{contentkey} =~ m{^-(.*)$}) {
753 $opt->{contentkey} = $1;
754 $opt->{collapseagain} = 1;
755 }
756 }
757 else {
758313µs $opt->{contentkey} = $DefContentKey;
759 }
760
761315µs unless(exists($opt->{normalisespace})) {
762 $opt->{normalisespace} = $opt->{normalizespace};
763 }
76439µs $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));
765
766 # Cleanups for values assumed to be arrays later
767
768312µs if($opt->{searchpath}) {
769 unless(ref($opt->{searchpath})) {
770 $opt->{searchpath} = [ $opt->{searchpath} ];
771 }
772 }
773 else {
774316µs $opt->{searchpath} = [ ];
775 }
776
77735µs if($opt->{cache} and !ref($opt->{cache})) {
778 $opt->{cache} = [ $opt->{cache} ];
779 }
78034µs if($opt->{cache}) {
781 $_ = lc($_) foreach (@{$opt->{cache}});
782 foreach my $scheme (@{$opt->{cache}}) {
783 my $method = 'cache_read_' . $scheme;
784 croak "Unsupported caching scheme: $scheme"
785 unless($self->can($method));
786 }
787 }
788
78939µs if(exists($opt->{parseropts})) {
790 if($^W) {
791 carp "Warning: " .
792 "'ParserOpts' is deprecated, contact the author if you need it";
793 }
794 }
795 else {
796313µs $opt->{parseropts} = [ ];
797 }
798
799
800 # Special cleanup for {forcearray} which could be regex, arrayref or boolean
801 # or left to default to 0
802
80339µs if(exists($opt->{forcearray})) {
80424µs if(ref($opt->{forcearray}) eq 'Regexp') {
805 $opt->{forcearray} = [ $opt->{forcearray} ];
806 }
807
80826µs if(ref($opt->{forcearray}) eq 'ARRAY') {
809 my @force_list = @{$opt->{forcearray}};
810 if(@force_list) {
811 $opt->{forcearray} = {};
812 foreach my $tag (@force_list) {
813 if(ref($tag) eq 'Regexp') {
814 push @{$opt->{forcearray}->{_regex}}, $tag;
815 }
816 else {
817 $opt->{forcearray}->{$tag} = 1;
818 }
819 }
820 }
821 else {
822 $opt->{forcearray} = 0;
823 }
824 }
825 else {
82625µs $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
827 }
828 }
829 else {
83012µs if($opt->{strictmode} and $dirn eq 'in') {
831 croak "No value specified for 'ForceArray' option in call to XML$dirn()";
832 }
83319µs $opt->{forcearray} = 0;
834 }
835
836
837 # Special cleanup for {keyattr} which could be arrayref or hashref or left
838 # to default to arrayref
839
840310µs if(exists($opt->{keyattr})) {
841315µs if(ref($opt->{keyattr})) {
842314µs if(ref($opt->{keyattr}) eq 'HASH') {
843
844 # Make a copy so we can mess with it
845
846 $opt->{keyattr} = { %{$opt->{keyattr}} };
847
848
849 # Convert keyattr => { elem => '+attr' }
850 # to keyattr => { elem => [ 'attr', '+' ] }
851
852 foreach my $el (keys(%{$opt->{keyattr}})) {
853 if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {
854 $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];
855 if($opt->{strictmode} and $dirn eq 'in') {
856 next if($opt->{forcearray} == 1);
857 next if(ref($opt->{forcearray}) eq 'HASH'
858 and $opt->{forcearray}->{$el});
859 croak "<$el> set in KeyAttr but not in ForceArray";
860 }
861 }
862 else {
863 delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)
864 }
865 }
866 }
867 else {
868324µs if(@{$opt->{keyattr}} == 0) {
869 delete($opt->{keyattr});
870 }
871 }
872 }
873 else {
874 $opt->{keyattr} = [ $opt->{keyattr} ];
875 }
876 }
877 else {
878 if($opt->{strictmode}) {
879 croak "No value specified for 'KeyAttr' option in call to XML$dirn()";
880 }
881 $opt->{keyattr} = [ @DefKeyAttr ];
882 }
883
884
885 # Special cleanup for {valueattr} which could be arrayref or hashref
886
88737µs if(exists($opt->{valueattr})) {
888 if(ref($opt->{valueattr}) eq 'ARRAY') {
889 $opt->{valueattrlist} = {};
890 $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });
891 }
892 }
893
894 # make sure there's nothing weird in {grouptags}
895
89635µs if($opt->{grouptags}) {
897 croak "Illegal value for 'GroupTags' option - expected a hashref"
898 unless UNIVERSAL::isa($opt->{grouptags}, 'HASH');
899
900 while(my($key, $val) = each %{$opt->{grouptags}}) {
901 next if $key ne $val;
902 croak "Bad value in GroupTags: '$key' => '$val'";
903 }
904 }
905
906
907 # Check the {variables} option is valid and initialise variables hash
908
90935µs if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
910 croak "Illegal value for 'Variables' option - expected a hashref";
911 }
912
9133110µs if($opt->{variables}) {
914 $self->{_var_values} = { %{$opt->{variables}} };
915 }
916 elsif($opt->{varattr}) {
917 $self->{_var_values} = {};
918 }
919
920}
921
922
923##############################################################################
924# Method: find_xml_file()
925#
926# Helper routine for XMLin().
927# Takes a filename, and a list of directories, attempts to locate the file in
928# the directories listed.
929# Returns a full pathname on success; croaks on failure.
930#
931
932sub find_xml_file {
933 my $self = shift;
934 my $file = shift;
935 my @search_path = @_;
936
937
938 require File::Basename;
939 require File::Spec;
940
941 my($filename, $filedir) = File::Basename::fileparse($file);
942
943 if($filename ne $file) { # Ignore searchpath if dir component
944 return($file) if(-e $file);
945 }
946 else {
947 my($path);
948 foreach $path (@search_path) {
949 my $fullpath = File::Spec->catfile($path, $file);
950 return($fullpath) if(-e $fullpath);
951 }
952 }
953
954 # If user did not supply a search path, default to current directory
955
956 if(!@search_path) {
957 return($file) if(-e $file);
958 croak "File does not exist: $file";
959 }
960
961 croak "Could not find $file in ", join(':', @search_path);
962}
963
964
965##############################################################################
966# Method: collapse()
967#
968# Helper routine for XMLin(). This routine really comprises the 'smarts' (or
969# value add) of this module.
970#
971# Takes the parse tree that XML::Parser produced from the supplied XML and
972# recurses through it 'collapsing' unnecessary levels of indirection (nested
973# arrays etc) to produce a data structure that is easier to work with.
974#
975# Elements in the original parser tree are represented as an element name
976# followed by an arrayref. The first element of the array is a hashref
977# containing the attributes. The rest of the array contains a list of any
978# nested elements as name+arrayref pairs:
979#
980# <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ]
981#
982# The special element name '0' (zero) flags text content.
983#
984# This routine cuts down the noise by discarding any text content consisting of
985# only whitespace and then moves the nested elements into the attribute hash
986# using the name of the nested element as the hash key and the collapsed
987# version of the nested element as the value. Multiple nested elements with
988# the same name will initially be represented as an arrayref, but this may be
989# 'folded' into a hashref depending on the value of the keyattr option.
990#
991
992
# spent 19.6ms (16.2+3.38) within XML::Simple::collapse which was called 132 times, avg 149µs/call: # 130 times (15.1ms+-15.1ms) by XML::Simple::collapse at line 1038, avg 0s/call # 2 times (1.18ms+18.4ms) by XML::Simple::build_simple_tree at line 333, avg 9.81ms/call
sub collapse {
993132199µs my $self = shift;
994
995
996 # Start with the hash of attributes
997
998132100µs my $attr = shift;
999132476µs if($self->{opt}->{noattr}) { # Discard if 'noattr' set
1000 $attr = $self->new_hashref;
1001 }
1002 elsif($self->{opt}->{normalisespace} == 2) {
1003 while(my($key, $value) = each %$attr) {
1004 $attr->{$key} = $self->normalise_space($value)
1005 }
1006 }
1007
1008
1009 # Do variable substitutions
1010
1011132169µs if(my $var = $self->{_var_values}) {
1012 while(my($key, $val) = each(%$attr)) {
1013 $val =~ s{\$\{([\w.]+)\}}{ $self->get_var($1) }ge;
1014 $attr->{$key} = $val;
1015 }
1016 }
1017
1018
1019 # Roll up 'value' attributes (but only if no nested elements)
1020
1021132287µs if(!@_ and keys %$attr == 1) {
1022647µs my($k) = keys %$attr;
1023620µs if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) {
1024 return $attr->{$k};
1025 }
1026 }
1027
1028
1029 # Add any nested elements
1030
1031132128µs my($key, $val);
1032132548µs while(@_) {
1033361576µs $key = shift;
1034361537µs $val = shift;
1035361282µs $val = '' if not defined $val;
1036
10373611.05ms if(ref($val)) {
10381301.67ms1300s $val = $self->collapse(@$val);
# spent 32.4ms making 130 calls to XML::Simple::collapse, avg 249µs/call, recursion: max depth 3, sum of overlapping time 32.4ms
1039130270µs next if(!defined($val) and $self->{opt}->{suppressempty});
1040 }
1041 elsif($key eq '0') {
10422314.34ms2323.22ms next if($val =~ m{^\s*$}s); # Skip all whitespace content
# spent 2.38ms making 231 calls to XML::Simple::CORE:match, avg 10µs/call # spent 836µs making 1 call to utf8::SWASHNEW
1043
104474186µs $val = $self->normalise_space($val)
1045 if($self->{opt}->{normalisespace} == 2);
1046
1047 # do variable substitutions
1048
104974139µs if(my $var = $self->{_var_values}) {
1050 $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;
1051 }
1052
1053
1054 # look for variable definitions
1055
105674115µs if(my $var = $self->{opt}->{varattr}) {
1057 if(exists $attr->{$var}) {
1058 $self->set_var($attr->{$var}, $val);
1059 }
1060 }
1061
1062
1063 # Collapse text content in element with no attributes to a string
1064
1065741.52ms if(!%$attr and !@_) {
1066 return($self->{opt}->{forcecontent} ?
1067 { $self->{opt}->{contentkey} => $val } : $val
1068 );
1069 }
1070 $key = $self->{opt}->{contentkey};
1071 }
1072
1073
1074 # Combine duplicate attributes into arrayref if required
1075
10761303.70ms1301000µs if(exists($attr->{$key})) {
# spent 1000µs making 130 calls to UNIVERSAL::isa, avg 8µs/call
1077 if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
1078 push(@{$attr->{$key}}, $val);
1079 }
1080 else {
1081 $attr->{$key} = [ $attr->{$key}, $val ];
1082 }
1083 }
1084 elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
1085 $attr->{$key} = [ $val ];
1086 }
1087 else {
108872996µs if( $key ne $self->{opt}->{contentkey}
1089 and (
1090 ($self->{opt}->{forcearray} == 1)
1091 or (
1092 (ref($self->{opt}->{forcearray}) eq 'HASH')
1093 and (
1094 $self->{opt}->{forcearray}->{$key}
1095 or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})
1096 )
1097 )
1098 )
1099 ) {
1100 $attr->{$key} = [ $val ];
1101 }
1102 else {
1103 $attr->{$key} = $val;
1104 }
1105 }
1106
1107 }
1108
1109
1110 # Turn arrayrefs into hashrefs if key fields present
1111
111258129µs if($self->{opt}->{keyattr}) {
1113 while(($key,$val) = each %$attr) {
1114 if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
1115 $attr->{$key} = $self->array_to_hash($key, $val);
1116 }
1117 }
1118 }
1119
1120
1121 # disintermediate grouped tags
1122
11235876µs if($self->{opt}->{grouptags}) {
1124 while(my($key, $val) = each(%$attr)) {
1125 next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
1126 next unless(exists($self->{opt}->{grouptags}->{$key}));
1127
1128 my($child_key, $child_val) = %$val;
1129
1130 if($self->{opt}->{grouptags}->{$key} eq $child_key) {
1131 $attr->{$key}= $child_val;
1132 }
1133 }
1134 }
1135
1136
1137 # Fold hashes containing a single anonymous array up into just the array
1138
113958182µs my $count = scalar keys %$attr;
11405846µs if($count == 1
1141 and exists $attr->{anon}
1142 and UNIVERSAL::isa($attr->{anon}, 'ARRAY')
1143 ) {
1144 return($attr->{anon});
1145 }
1146
1147
1148 # Do the right thing if hash is empty, otherwise just return it
1149
11505867µs if(!%$attr and exists($self->{opt}->{suppressempty})) {
1151 if(defined($self->{opt}->{suppressempty}) and
1152 $self->{opt}->{suppressempty} eq '') {
1153 return('');
1154 }
1155 return(undef);
1156 }
1157
1158
1159 # Roll up named elements with named nested 'value' attributes
1160
11615889µs if($self->{opt}->{valueattr}) {
1162 while(my($key, $val) = each(%$attr)) {
1163 next unless($self->{opt}->{valueattr}->{$key});
1164 next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
1165 my($k) = keys %$val;
1166 next unless($k eq $self->{opt}->{valueattr}->{$key});
1167 $attr->{$key} = $val->{$k};
1168 }
1169 }
1170
117158823µs return($attr)
1172
1173}
1174
1175
1176##############################################################################
1177# Method: set_var()
1178#
1179# Called when a variable definition is encountered in the XML. (A variable
1180# definition looks like <element attrname="name">value</element> where attrname
1181# matches the varattr setting).
1182#
1183
1184sub set_var {
1185 my($self, $name, $value) = @_;
1186
1187 $self->{_var_values}->{$name} = $value;
1188}
1189
1190
1191##############################################################################
1192# Method: get_var()
1193#
1194# Called during variable substitution to get the value for the named variable.
1195#
1196
1197sub get_var {
1198 my($self, $name) = @_;
1199
1200 my $value = $self->{_var_values}->{$name};
1201 return $value if(defined($value));
1202
1203 return '${' . $name . '}';
1204}
1205
1206
1207##############################################################################
1208# Method: normalise_space()
1209#
1210# Strips leading and trailing whitespace and collapses sequences of whitespace
1211# characters to a single space.
1212#
1213
1214sub normalise_space {
1215 my($self, $text) = @_;
1216
1217 $text =~ s/^\s+//s;
1218 $text =~ s/\s+$//s;
1219 $text =~ s/\s\s+/ /sg;
1220
1221 return $text;
1222}
1223
1224
1225##############################################################################
1226# Method: array_to_hash()
1227#
1228# Helper routine for collapse().
1229# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a
1230# reference to the hash on success or the original array if folding is
1231# not possible. Behaviour is controlled by 'keyattr' option.
1232#
1233
1234sub array_to_hash {
1235 my $self = shift;
1236 my $name = shift;
1237 my $arrayref = shift;
1238
1239 my $hashref = $self->new_hashref;
1240
1241 my($i, $key, $val, $flag);
1242
1243
1244 # Handle keyattr => { .... }
1245
1246 if(ref($self->{opt}->{keyattr}) eq 'HASH') {
1247 return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
1248 ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}};
1249 for($i = 0; $i < @$arrayref; $i++) {
1250 if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and
1251 exists($arrayref->[$i]->{$key})
1252 ) {
1253 $val = $arrayref->[$i]->{$key};
1254 if(ref($val)) {
1255 $self->die_or_warn("<$name> element has non-scalar '$key' key attribute");
1256 return($arrayref);
1257 }
1258 $val = $self->normalise_space($val)
1259 if($self->{opt}->{normalisespace} == 1);
1260 $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
1261 if(exists($hashref->{$val}));
1262 $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} );
1263 $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');
1264 delete $hashref->{$val}->{$key} unless($flag eq '+');
1265 }
1266 else {
1267 $self->die_or_warn("<$name> element has no '$key' key attribute");
1268 return($arrayref);
1269 }
1270 }
1271 }
1272
1273
1274 # Or assume keyattr => [ .... ]
1275
1276 else {
1277 my $default_keys =
1278 join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}});
1279
1280 ELEMENT: for($i = 0; $i < @$arrayref; $i++) {
1281 return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));
1282
1283 foreach $key (@{$self->{opt}->{keyattr}}) {
1284 if(defined($arrayref->[$i]->{$key})) {
1285 $val = $arrayref->[$i]->{$key};
1286 if(ref($val)) {
1287 $self->die_or_warn("<$name> element has non-scalar '$key' key attribute")
1288 if not $default_keys;
1289 return($arrayref);
1290 }
1291 $val = $self->normalise_space($val)
1292 if($self->{opt}->{normalisespace} == 1);
1293 $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
1294 if(exists($hashref->{$val}));
1295 $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} );
1296 delete $hashref->{$val}->{$key};
1297 next ELEMENT;
1298 }
1299 }
1300
1301 return($arrayref); # No keyfield matched
1302 }
1303 }
1304
1305 # collapse any hashes which now only have a 'content' key
1306
1307 if($self->{opt}->{collapseagain}) {
1308 $hashref = $self->collapse_content($hashref);
1309 }
1310
1311 return($hashref);
1312}
1313
1314
1315##############################################################################
1316# Method: die_or_warn()
1317#
1318# Takes a diagnostic message and does one of three things:
1319# 1. dies if strict mode is enabled
1320# 2. warns if warnings are enabled but strict mode is not
1321# 3. ignores message and returns silently if neither strict mode nor warnings
1322# are enabled
1323#
1324# Option 2 looks at the global warnings variable $^W - which is not really
1325# appropriate in the modern world of lexical warnings - TODO: Fix
1326
1327sub die_or_warn {
1328 my $self = shift;
1329 my $msg = shift;
1330
1331 croak $msg if($self->{opt}->{strictmode});
1332 carp "Warning: $msg" if($^W);
1333}
1334
1335
1336##############################################################################
1337# Method: new_hashref()
1338#
1339# This is a hook routine for overriding in a sub-class. Some people believe
1340# that using Tie::IxHash here will solve order-loss problems.
1341#
1342
1343sub new_hashref {
1344 my $self = shift;
1345
1346 return { @_ };
1347}
1348
1349
1350##############################################################################
1351# Method: collapse_content()
1352#
1353# Helper routine for array_to_hash
1354#
1355# Arguments expected are:
1356# - an XML::Simple object
1357# - a hasref
1358# the hashref is a former array, turned into a hash by array_to_hash because
1359# of the presence of key attributes
1360# at this point collapse_content avoids over-complicated structures like
1361# dir => { libexecdir => { content => '$exec_prefix/libexec' },
1362# localstatedir => { content => '$prefix' },
1363# }
1364# into
1365# dir => { libexecdir => '$exec_prefix/libexec',
1366# localstatedir => '$prefix',
1367# }
1368
1369sub collapse_content {
1370 my $self = shift;
1371 my $hashref = shift;
1372
1373 my $contentkey = $self->{opt}->{contentkey};
1374
1375 # first go through the values,checking that they are fit to collapse
1376 foreach my $val (values %$hashref) {
1377 return $hashref unless ( (ref($val) eq 'HASH')
1378 and (keys %$val == 1)
1379 and (exists $val->{$contentkey})
1380 );
1381 }
1382
1383 # now collapse them
1384 foreach my $key (keys %$hashref) {
1385 $hashref->{$key}= $hashref->{$key}->{$contentkey};
1386 }
1387
1388 return $hashref;
1389}
1390
1391
1392##############################################################################
1393# Method: value_to_xml()
1394#
1395# Helper routine for XMLout() - recurses through a data structure building up
1396# and returning an XML representation of that structure as a string.
1397#
1398# Arguments expected are:
1399# - the data structure to be encoded (usually a reference)
1400# - the XML tag name to use for this item
1401# - a string of spaces for use as the current indent level
1402#
1403
1404
# spent 12.1ms (7.45+4.61) within XML::Simple::value_to_xml which was called 32 times, avg 377µs/call: # 24 times (3.95ms+-3.95ms) by XML::Simple::value_to_xml at line 1569, avg 0s/call # 7 times (3.23ms+-3.23ms) by XML::Simple::value_to_xml at line 1622, avg 0s/call # once (274µs+11.8ms) by XML::Simple::XMLout at line 639
sub value_to_xml {
14053259µs my $self = shift;;
1406
1407
1408 # Grab the other arguments
1409
141032132µs my($ref, $name, $indent) = @_;
1411
14123269µs my $named = (defined($name) and $name ne '' ? 1 : 0);
1413
14143238µs my $nl = "\n";
1415
14163237µs my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack!
14173280µs if($self->{opt}->{noindent}) {
1418 $indent = '';
1419 $nl = '';
1420 }
1421
1422
1423 # Convert to XML
1424
142532112µs if(ref($ref)) {
1426 croak "circular data structures not supported"
142732326µs if(grep($_ == $ref, @{$self->{_ancestors}}));
142832126µs push @{$self->{_ancestors}}, $ref;
1429 }
1430 else {
1431 if($named) {
1432 return(join('',
1433 $indent, '<', $name, '>',
1434 ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
1435 '</', $name, ">", $nl
1436 ));
1437 }
1438 else {
1439 return("$ref$nl");
1440 }
1441 }
1442
1443
1444 # Unfold hash to array if possible
1445
144632717µs32220µs if(UNIVERSAL::isa($ref, 'HASH') # It is a hash
# spent 220µs making 32 calls to UNIVERSAL::isa, avg 7µs/call
1447 and keys %$ref # and it's not empty
1448 and $self->{opt}->{keyattr} # and folding is enabled
1449 and !$is_root # and its not the root element
1450 ) {
1451 $ref = $self->hash_to_array($name, $ref);
1452 }
1453
1454
14553298µs my @result = ();
14563231µs my($key, $value);
1457
1458
1459 # Handle hashrefs
1460
1461321000µs56328µs if(UNIVERSAL::isa($ref, 'HASH')) {
# spent 328µs making 56 calls to UNIVERSAL::isa, avg 6µs/call
1462
1463 # Reintermediate grouped values if applicable
1464
1465825µs if($self->{opt}->{grouptags}) {
1466 $ref = $self->copy_hash($ref);
1467 while(my($key, $val) = each %$ref) {
1468 if($self->{opt}->{grouptags}->{$key}) {
1469 $ref->{$key} = $self->new_hashref(
1470 $self->{opt}->{grouptags}->{$key} => $val
1471 );
1472 }
1473 }
1474 }
1475
1476
1477 # Scan for namespace declaration attributes
1478
1479818µs my $nsdecls = '';
148085µs my $default_ns_uri;
148189µs if($self->{nsup}) {
1482 $ref = $self->copy_hash($ref);
1483 $self->{nsup}->push_context();
1484
1485 # Look for default namespace declaration first
1486
1487 if(exists($ref->{xmlns})) {
1488 $self->{nsup}->declare_prefix('', $ref->{xmlns});
1489 $nsdecls .= qq( xmlns="$ref->{xmlns}");
1490 delete($ref->{xmlns});
1491 }
1492 $default_ns_uri = $self->{nsup}->get_uri('');
1493
1494
1495 # Then check all the other keys
1496
1497 foreach my $qname (keys(%$ref)) {
1498 my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
1499 if($uri) {
1500 if($uri eq $xmlns_ns) {
1501 $self->{nsup}->declare_prefix($lname, $ref->{$qname});
1502 $nsdecls .= qq( xmlns:$lname="$ref->{$qname}");
1503 delete($ref->{$qname});
1504 }
1505 }
1506 }
1507
1508 # Translate any remaining Clarkian names
1509
1510 foreach my $qname (keys(%$ref)) {
1511 my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
1512 if($uri) {
1513 if($default_ns_uri and $uri eq $default_ns_uri) {
1514 $ref->{$lname} = $ref->{$qname};
1515 delete($ref->{$qname});
1516 }
1517 else {
1518 my $prefix = $self->{nsup}->get_prefix($uri);
1519 unless($prefix) {
1520 # $self->{nsup}->declare_prefix(undef, $uri);
1521 # $prefix = $self->{nsup}->get_prefix($uri);
1522 $prefix = $self->{ns_prefix}++;
1523 $self->{nsup}->declare_prefix($prefix, $uri);
1524 $nsdecls .= qq( xmlns:$prefix="$uri");
1525 }
1526 $ref->{"$prefix:$lname"} = $ref->{$qname};
1527 delete($ref->{$qname});
1528 }
1529 }
1530 }
1531 }
1532
1533
1534819µs my @nested = ();
153588µs my $text_content = undef;
1536842µs if($named) {
1537 push @result, $indent, '<', $name, $nsdecls;
1538 }
1539
1540883µs if(keys %$ref) {
154189µs my $first_arg = 1;
15428112µs8686µs foreach my $key ($self->sorted_keys($name, $ref)) {
# spent 686µs making 8 calls to XML::Simple::sorted_keys, avg 86µs/call
154340207µs my $value = $ref->{$key};
154440253µs next if(substr($key, 0, 1) eq '-');
15454039µs if(!defined($value)) {
1546 next if $self->{opt}->{suppressempty};
1547 unless(exists($self->{opt}->{suppressempty})
1548 and !defined($self->{opt}->{suppressempty})
1549 ) {
1550 carp 'Use of uninitialized value' if($^W);
1551 }
1552 if($key eq $self->{opt}->{contentkey}) {
1553 $text_content = '';
1554 }
1555 else {
1556 $value = exists($self->{opt}->{suppressempty}) ? {} : '';
1557 }
1558 }
1559
15604099µs if(!ref($value)
1561 and $self->{opt}->{valueattr}
1562 and $self->{opt}->{valueattr}->{$key}
1563 ) {
1564 $value = $self->new_hashref(
1565 $self->{opt}->{valueattr}->{$key} => $value
1566 );
1567 }
1568
156940812µs240s if(ref($value) or $self->{opt}->{noattr}) {
# spent 22.9ms making 24 calls to XML::Simple::value_to_xml, avg 956µs/call, recursion: max depth 5, sum of overlapping time 22.9ms
1570 push @nested,
1571 $self->value_to_xml($value, $key, "$indent ");
1572 }
1573 else {
157416218µs161.06ms $value = $self->escape_value($value) unless($self->{opt}->{noescape});
# spent 1.06ms making 16 calls to XML::Simple::escape_value, avg 66µs/call
15751693µs if($key eq $self->{opt}->{contentkey}) {
1576 $text_content = $value;
1577 }
1578 else {
15791629µs push @result, "\n$indent " . ' ' x length($name)
1580 if($self->{opt}->{attrindent} and !$first_arg);
158116128µs push @result, ' ', $key, '="', $value , '"';
15821629µs $first_arg = 0;
1583 }
1584 }
1585 }
1586 }
1587 else {
1588 $text_content = '';
1589 }
1590
1591827µs if(@nested or defined($text_content)) {
1592815µs if($named) {
1593723µs push @result, ">";
1594713µs if(defined($text_content)) {
1595 push @result, $text_content;
1596 $nested[0] =~ s/^\s+// if(@nested);
1597 }
1598 else {
1599720µs push @result, $nl;
1600 }
1601749µs if(@nested) {
1602 push @result, @nested, $indent;
1603 }
1604735µs push @result, '</', $name, ">", $nl;
1605 }
1606 else {
1607110µs push @result, @nested; # Special case if no root elements
1608 }
1609 }
1610 else {
1611 push @result, " />", $nl;
1612 }
1613843µs $self->{nsup}->pop_context() if($self->{nsup});
1614 }
1615
1616
1617 # Handle arrayrefs
1618
1619 elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
16202489µs foreach $value (@$ref) {
16214140µs next if !defined($value) and $self->{opt}->{suppressempty};
1622411.26ms482.32ms if(!ref($value)) {
# spent 2.27ms making 34 calls to XML::Simple::escape_value, avg 67µs/call # spent 44µs making 7 calls to UNIVERSAL::isa, avg 6µs/call # spent 16.2ms making 7 calls to XML::Simple::value_to_xml, avg 2.32ms/call, recursion: max depth 4, sum of overlapping time 16.2ms
1623 push @result,
1624 $indent, '<', $name, '>',
1625 ($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
1626 '</', $name, ">$nl";
1627 }
1628 elsif(UNIVERSAL::isa($value, 'HASH')) {
1629 push @result, $self->value_to_xml($value, $name, $indent);
1630 }
1631 else {
1632 push @result,
1633 $indent, '<', $name, ">$nl",
1634 $self->value_to_xml($value, 'anon', "$indent "),
1635 $indent, '</', $name, ">$nl";
1636 }
1637 }
1638 }
1639
1640 else {
1641 croak "Can't encode a value of type: " . ref($ref);
1642 }
1643
1644
164532151µs pop @{$self->{_ancestors}} if(ref($ref));
1646
164732966µs return(join('', @result));
1648}
1649
1650
1651##############################################################################
1652# Method: sorted_keys()
1653#
1654# Returns the keys of the referenced hash sorted into alphabetical order, but
1655# with the 'key' key (as in KeyAttr) first, if there is one.
1656#
1657
1658
# spent 686µs (616+70) within XML::Simple::sorted_keys which was called 8 times, avg 86µs/call: # 8 times (616µs+70µs) by XML::Simple::value_to_xml at line 1542, avg 86µs/call
sub sorted_keys {
1659827µs my($self, $name, $ref) = @_;
1660
1661819µs return keys %$ref if $self->{opt}->{nosort};
1662
16638206µs my %hash = %$ref;
1664822µs my $keyattr = $self->{opt}->{keyattr};
1665
166686µs my @key;
1667
1668819µs if(ref $keyattr eq 'HASH') {
1669 if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) {
1670 push @key, $keyattr->{$name}->[0];
1671 delete $hash{$keyattr->{$name}->[0]};
1672 }
1673 }
1674 elsif(ref $keyattr eq 'ARRAY') {
1675 foreach (@{$keyattr}) {
1676 if(exists $hash{$_}) {
1677 push @key, $_;
1678 delete $hash{$_};
1679 last;
1680 }
1681 }
1682 }
1683
16848431µs870µs return(@key, sort keys %hash);
# spent 70µs making 8 calls to XML::Simple::CORE:sort, avg 9µs/call
1685}
1686
1687##############################################################################
1688# Method: escape_value()
1689#
1690# Helper routine for automatically escaping values for XMLout().
1691# Expects a scalar data value. Returns escaped version.
1692#
1693
1694
# spent 3.33ms (2.83+504µs) within XML::Simple::escape_value which was called 50 times, avg 67µs/call: # 34 times (1.92ms+350µs) by XML::Simple::value_to_xml at line 1622, avg 67µs/call # 16 times (904µs+154µs) by XML::Simple::value_to_xml at line 1574, avg 66µs/call
sub escape_value {
169550160µs my($self, $data) = @_;
1696
16975039µs return '' unless(defined($data));
1698
169950773µs50165µs $data =~ s/&/&amp;/sg;
# spent 165µs making 50 calls to XML::Simple::CORE:subst, avg 3µs/call
170050558µs50115µs $data =~ s/</&lt;/sg;
# spent 115µs making 50 calls to XML::Simple::CORE:subst, avg 2µs/call
170150530µs50112µs $data =~ s/>/&gt;/sg;
# spent 112µs making 50 calls to XML::Simple::CORE:subst, avg 2µs/call
170250540µs50111µs $data =~ s/"/&quot;/sg;
# spent 111µs making 50 calls to XML::Simple::CORE:subst, avg 2µs/call
1703
170450947µs my $level = $self->{opt}->{numericescape} or return $data;
1705
1706 return $self->numeric_escape($data, $level);
1707}
1708
1709sub numeric_escape {
1710 my($self, $data, $level) = @_;
1711
171224.05ms2118µs
# spent 98µs (78+20) within XML::Simple::BEGIN@1712 which was called: # once (78µs+20µs) by main::BEGIN@235 at line 1712
use utf8; # required for 5.6
# spent 98µs making 1 call to XML::Simple::BEGIN@1712 # spent 20µs making 1 call to utf8::import
1713
1714 if($self->{opt}->{numericescape} eq '2') {
1715 $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse;
1716 }
1717 else {
1718 $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse;
1719 }
1720
1721 return $data;
1722}
1723
1724
1725##############################################################################
1726# Method: hash_to_array()
1727#
1728# Helper routine for value_to_xml().
1729# Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a
1730# reference to the array on success or the original hash if unfolding is
1731# not possible.
1732#
1733
1734sub hash_to_array {
1735 my $self = shift;
1736 my $parent = shift;
1737 my $hashref = shift;
1738
1739 my $arrayref = [];
1740
1741 my($key, $value);
1742
1743 my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref;
1744 foreach $key (@keys) {
1745 $value = $hashref->{$key};
1746 return($hashref) unless(UNIVERSAL::isa($value, 'HASH'));
1747
1748 if(ref($self->{opt}->{keyattr}) eq 'HASH') {
1749 return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent}));
1750 push @$arrayref, $self->copy_hash(
1751 $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key
1752 );
1753 }
1754 else {
1755 push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
1756 }
1757 }
1758
1759 return($arrayref);
1760}
1761
1762
1763##############################################################################
1764# Method: copy_hash()
1765#
1766# Helper routine for hash_to_array(). When unfolding a hash of hashes into
1767# an array of hashes, we need to copy the key from the outer hash into the
1768# inner hash. This routine makes a copy of the original hash so we don't
1769# destroy the original data structure. You might wish to override this
1770# method if you're using tied hashes and don't want them to get untied.
1771#
1772
1773sub copy_hash {
1774 my($self, $orig, @extra) = @_;
1775
1776 return { @extra, %$orig };
1777}
1778
1779##############################################################################
1780# Methods required for building trees from SAX events
1781##############################################################################
1782
1783
# spent 61µs within XML::Simple::start_document which was called 2 times, avg 31µs/call: # 2 times (61µs+0s) by XML::SAX::Base::start_document at line 1266 of XML/SAX/Base.pm, avg 31µs/call
sub start_document {
178424µs my $self = shift;
1785
178627µs $self->handle_options('in') unless($self->{opt});
1787
1788218µs $self->{lists} = [];
1789249µs $self->{curlist} = $self->{tree} = [];
1790}
1791
1792
1793
# spent 6.94ms within XML::Simple::start_element which was called 132 times, avg 53µs/call: # 130 times (6.83ms+0s) by XML::SAX::Base::__ANON__[/usr/lib64/perl5/vendor_perl/5.16.0/XML/SAX/Base.pm:299] at line 299 of XML/SAX/Base.pm, avg 53µs/call # 2 times (111µs+0s) by XML::SAX::Base::start_element at line 300 of XML/SAX/Base.pm, avg 55µs/call
sub start_element {
1794132204µs my $self = shift;
179513295µs my $element = shift;
1796
1797132306µs my $name = $element->{Name};
1798132251µs if($self->{opt}->{nsexpand}) {
1799 $name = $element->{LocalName} || '';
1800 if($element->{NamespaceURI}) {
1801 $name = '{' . $element->{NamespaceURI} . '}' . $name;
1802 }
1803 }
1804132374µs my $attributes = {};
1805132433µs if($element->{Attributes}) { # Might be undef
18061321.13ms foreach my $attr (values %{$element->{Attributes}}) {
1807130653µs if($self->{opt}->{nsexpand}) {
1808 my $name = $attr->{LocalName} || '';
1809 if($attr->{NamespaceURI}) {
1810 $name = '{' . $attr->{NamespaceURI} . '}' . $name
1811 }
1812 $name = 'xmlns' if($name eq $bad_def_ns_jcn);
1813 $attributes->{$name} = $attr->{Value};
1814 }
1815 else {
1816130880µs $attributes->{$attr->{Name}} = $attr->{Value};
1817 }
1818 }
1819 }
1820132530µs my $newlist = [ $attributes ];
1821132432µs push @{ $self->{lists} }, $self->{curlist};
1822132458µs push @{ $self->{curlist} }, $name => $newlist;
18231322.18ms $self->{curlist} = $newlist;
1824}
1825
1826
1827
# spent 7.16ms within XML::Simple::characters which was called 291 times, avg 25µs/call: # 289 times (7.09ms+0s) by XML::SAX::Base::__ANON__[/usr/lib64/perl5/vendor_perl/5.16.0/XML/SAX/Base.pm:207] at line 207 of XML/SAX/Base.pm, avg 25µs/call # 2 times (65µs+0s) by XML::SAX::Base::characters at line 208 of XML/SAX/Base.pm, avg 33µs/call
sub characters {
1828291449µs my $self = shift;
1829291215µs my $chars = shift;
1830
1831291623µs my $text = $chars->{Data};
1832291350µs my $clist = $self->{curlist};
1833291782µs my $pos = $#$clist;
1834
18352915.56ms if ($pos > 0 and $clist->[$pos - 1] eq '0') {
1836 $clist->[$pos] .= $text;
1837 }
1838 else {
18392311.47ms push @$clist, 0 => $text;
1840 }
1841}
1842
1843
1844
# spent 1.58ms within XML::Simple::end_element which was called 132 times, avg 12µs/call: # 130 times (1.55ms+0s) by XML::SAX::Base::__ANON__[/usr/lib64/perl5/vendor_perl/5.16.0/XML/SAX/Base.pm:2208] at line 2208 of XML/SAX/Base.pm, avg 12µs/call # 2 times (31µs+0s) by XML::SAX::Base::end_element at line 2209 of XML/SAX/Base.pm, avg 16µs/call
sub end_element {
1845132214µs my $self = shift;
1846
18471322.37ms $self->{curlist} = pop @{ $self->{lists} };
1848}
1849
1850
1851
# spent 65µs within XML::Simple::end_document which was called 2 times, avg 32µs/call: # 2 times (65µs+0s) by XML::SAX::Base::end_document at line 1450 of XML/SAX/Base.pm, avg 32µs/call
sub end_document {
185225µs my $self = shift;
1853
1854211µs delete($self->{curlist});
185528µs delete($self->{lists});
1856
185727µs my $tree = $self->{tree};
185826µs delete($self->{tree});
1859
1860
1861 # Return tree as-is to XMLin()
1862
1863244µs return($tree) if($self->{nocollapse});
1864
1865
1866 # Or collapse it before returning it to SAX parser class
1867
1868 if($self->{opt}->{keeproot}) {
1869 $tree = $self->collapse({}, @$tree);
1870 }
1871 else {
1872 $tree = $self->collapse(@{$tree->[1]});
1873 }
1874
1875 if($self->{opt}->{datahandler}) {
1876 return($self->{opt}->{datahandler}->($self, $tree));
1877 }
1878
1879 return($tree);
1880}
1881
188218µs*xml_in = \&XMLin;
188313µs*xml_out = \&XMLout;
1884
1885155µs1;
1886
1887__END__
 
# spent 2.44ms (1.60+836µs) within XML::Simple::CORE:match which was called 235 times, avg 10µs/call: # 231 times (1.54ms+836µs) by XML::Simple::collapse at line 1042, avg 10µs/call # 2 times (48µs+0s) by XML::Simple::XMLin at line 192, avg 24µs/call # once (6µs+0s) by XML::Simple::import at line 93 # once (2µs+0s) by XML::Simple::import at line 97
sub XML::Simple::CORE:match; # opcode
# spent 70µs within XML::Simple::CORE:sort which was called 8 times, avg 9µs/call: # 8 times (70µs+0s) by XML::Simple::sorted_keys at line 1684, avg 9µs/call
sub XML::Simple::CORE:sort; # opcode
# spent 538µs within XML::Simple::CORE:subst which was called 209 times, avg 3µs/call: # 50 times (165µs+0s) by XML::Simple::escape_value at line 1699, avg 3µs/call # 50 times (115µs+0s) by XML::Simple::escape_value at line 1700, avg 2µs/call # 50 times (112µs+0s) by XML::Simple::escape_value at line 1701, avg 2µs/call # 50 times (111µs+0s) by XML::Simple::escape_value at line 1702, avg 2µs/call # 6 times (16µs+0s) by XML::Simple::handle_options at line 719, avg 3µs/call # 3 times (17µs+0s) by XML::Simple::new at line 122, avg 6µs/call
sub XML::Simple::CORE:subst; # opcode
Report produced by the NYTProf 5.05 Perl profiler, developed by Tim Bunce and Adam Kaplan.