← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:47 2015

Filename/usr/share/perl5/XML/Simple.pm
StatementsExecuted 10456 statements in 16.3ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
142213.08ms3.82msXML::Simple::::collapseXML::Simple::collapse (recurses: max depth 3, inclusive time 4.49ms)
2112.24ms55.6msXML::Simple::::build_treeXML::Simple::build_tree
1111.45ms1.45msXML::Simple::::BEGIN@1712XML::Simple::BEGIN@1712
478211.05ms1.05msXML::Simple::::charactersXML::Simple::characters
14221620µs620µsXML::Simple::::start_elementXML::Simple::start_element
1411200µs241µsXML::Simple::::array_to_hashXML::Simple::array_to_hash
27841200µs200µsXML::Simple::::CORE:matchXML::Simple::CORE:match (opcode)
211112µs114µsXML::Simple::::handle_optionsXML::Simple::handle_options
14221112µs112µsXML::Simple::::end_elementXML::Simple::end_element
21180µs108µsXML::Simple::::newXML::Simple::new
21147µs59.4msXML::Simple::::build_simple_treeXML::Simple::build_simple_tree
21135µs59.6msXML::Simple::::parse_fileXML::Simple::parse_file
21133µs59.8msXML::Simple::::XMLinXML::Simple::XMLin
262132µs32µsXML::Simple::::new_hashrefXML::Simple::new_hashref
42128µs145µsXML::Simple::::_get_objectXML::Simple::_get_object
21125µs25µsXML::Simple::::_strict_mode_for_callerXML::Simple::_strict_mode_for_caller
21123µs61µsXML::Simple::::find_xml_fileXML::Simple::find_xml_file
11118µs20µsXML::Simple::::importXML::Simple::import
21111µs11µsXML::Simple::::start_documentXML::Simple::start_document
11110µs60µsXML::Simple::::BEGIN@41XML::Simple::BEGIN@41
1119µs9µsXML::Simple::::BEGIN@2XML::Simple::BEGIN@2
2119µs9µsXML::Simple::::CORE:ftisXML::Simple::CORE:ftis (opcode)
1118µs74µsXML::Simple::::BEGIN@49XML::Simple::BEGIN@49
1118µs24µsXML::Simple::::BEGIN@40XML::Simple::BEGIN@40
2118µs8µsXML::Simple::::end_documentXML::Simple::end_document
8215µs5µsXML::Simple::::CORE:substXML::Simple::CORE:subst (opcode)
0000s0sXML::Simple::::XMLoutXML::Simple::XMLout
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::::escape_valueXML::Simple::escape_value
0000s0sXML::Simple::::get_varXML::Simple::get_var
0000s0sXML::Simple::::hash_to_arrayXML::Simple::hash_to_array
0000s0sXML::Simple::::normalise_spaceXML::Simple::normalise_space
0000s0sXML::Simple::::numeric_escapeXML::Simple::numeric_escape
0000s0sXML::Simple::::parse_fhXML::Simple::parse_fh
0000s0sXML::Simple::::parse_stringXML::Simple::parse_string
0000s0sXML::Simple::::set_varXML::Simple::set_var
0000s0sXML::Simple::::sorted_keysXML::Simple::sorted_keys
0000s0sXML::Simple::::storable_filenameXML::Simple::storable_filename
0000s0sXML::Simple::::value_to_xmlXML::Simple::value_to_xml
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 9µs within XML::Simple::BEGIN@2 which was called: # once (9µs+0s) by C4::Context::BEGIN@102 at line 4
BEGIN {
316µs $XML::Simple::VERSION = '2.20';
4140µs19µs}
# spent 9µ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
40227µs241µs
# spent 24µs (8+17) within XML::Simple::BEGIN@40 which was called: # once (8µs+17µs) by C4::Context::BEGIN@102 at line 40
use strict;
# spent 24µs making 1 call to XML::Simple::BEGIN@40 # spent 17µs making 1 call to strict::import
41241µs2111µs
# spent 60µs (10+51) within XML::Simple::BEGIN@41 which was called: # once (10µs+51µs) by C4::Context::BEGIN@102 at line 41
use Carp;
# spent 60µs making 1 call to XML::Simple::BEGIN@41 # spent 51µs making 1 call to Exporter::import
4211µsrequire Exporter;
43
44
45##############################################################################
46# Define some constants
47#
48
4925.76ms2139µs
# spent 74µs (8+66) within XML::Simple::BEGIN@49 which was called: # once (8µs+66µs) by C4::Context::BEGIN@102 at line 49
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);
# spent 74µs making 1 call to XML::Simple::BEGIN@49 # spent 66µs making 1 call to vars::import
50
5117µs@ISA = qw(Exporter);
521700ns@EXPORT = qw(XMLin XMLout);
531300ns@EXPORT_OK = qw(xml_in xml_out);
541300ns$PREFERRED_PARSER = undef;
55
561600nsmy %StrictMode = ();
57
5812µ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
6312µ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
681500nsmy @DefKeyAttr = qw(name key id);
691300nsmy $DefRootName = qq(opt);
701100nsmy $DefContentKey = qq(content);
711100nsmy $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>);
72
731100nsmy $xmlns_ns = 'http://www.w3.org/2000/xmlns/';
7411µsmy $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround
75
76
77##############################################################################
78# Globals for use by caching routines
79#
80
811200nsmy %MemShareCache = ();
821100nsmy %MemCopyCache = ();
83
84
85##############################################################################
86# Wrapper for Exporter - handles ':strict'
87#
88
89
# spent 20µs (18+2) within XML::Simple::import which was called: # once (18µs+2µs) by C4::Context::BEGIN@102 at line 102 of C4/Context.pm
sub import {
90 # Handle the :strict tag
91
9212µs my($calling_package) = caller();
93110µs12µs _strict_mode_for_caller(1) if grep(/^:strict$/, @_);
# spent 2µs making 1 call to XML::Simple::CORE:match
94
95 # Pass everything else to Exporter.pm
96
9714µs1300ns @_ = grep(!/^:strict$/, @_);
# spent 300ns making 1 call to XML::Simple::CORE:match
9816µs136µs goto &Exporter::import;
# spent 36µs making 1 call to Exporter::import
99}
100
101
102##############################################################################
103# Constructor for optional object interface.
104#
105
106
# spent 108µs (80+28) within XML::Simple::new which was called 2 times, avg 54µs/call: # 2 times (80µs+28µs) by XML::Simple::_get_object at line 166, avg 54µs/call
sub new {
10721µs my $class = shift;
108
10922µs if(@_ % 2) {
110 croak "Default options must be name=>value pairs (odd number supplied)";
111 }
112
1132500ns my %known_opt;
114238µs @known_opt{@KnownOptIn, @KnownOptOut} = ();
115
11622µs my %raw_opt = @_;
11726µs225µs $raw_opt{strictmode} = _strict_mode_for_caller()
# spent 25µs making 2 calls to XML::Simple::_strict_mode_for_caller, avg 13µs/call
118 unless exists $raw_opt{strictmode};
1192500ns my %def_opt;
12024µs while(my($key, $val) = each %raw_opt) {
12122µs my $lkey = lc($key);
122210µs23µs $lkey =~ s/_//g;
# spent 3µs making 2 calls to XML::Simple::CORE:subst, avg 1µs/call
12321µs croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
12422µs $def_opt{$lkey} = $val;
125 }
12623µs my $self = { def_opt => \%def_opt };
127
128211µ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 25µs within XML::Simple::_strict_mode_for_caller which was called 2 times, avg 13µs/call: # 2 times (25µs+0s) by XML::Simple::new at line 117, avg 13µs/call
sub _strict_mode_for_caller {
14221µs my $set_mode = @_;
1432600ns my $frame = 1;
144214µs while(my($package) = caller($frame++)) {
14564µs next if $package eq 'XML::Simple';
1462400ns $StrictMode{$package} = 1 if $set_mode;
14728µ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 145µs (28+117) within XML::Simple::_get_object which was called 4 times, avg 36µs/call: # 2 times (19µs+115µs) by XML::Simple::XMLin at line 185, avg 67µs/call # 2 times (9µs+2µs) by XML::Simple::parse_file at line 228, avg 6µs/call
sub _get_object {
1614800ns my $self;
162423µs49µs if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) {
# spent 9µs making 4 calls to UNIVERSAL::isa, avg 2µs/call
163 $self = shift;
164 }
165 else {
16626µs2108µs $self = XML::Simple->new();
# spent 108µs making 2 calls to XML::Simple::new, avg 54µs/call
167 }
168
16948µ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 59.8ms (33µs+59.8) within XML::Simple::XMLin which was called 2 times, avg 29.9ms/call: # 2 times (33µs+59.8ms) by C4::Context::read_config_file at line 262 of C4/Context.pm, avg 29.9ms/call
sub XMLin {
18523µs2134µs my $self = &_get_object; # note, @_ is passed implicitly
# spent 134µs making 2 calls to XML::Simple::_get_object, avg 67µs/call
186
1872900ns my $target = shift;
188
189
190 # Work out whether to parse a string, a file or a filehandle
191
192210µs22µs if(not defined $target) {
# spent 2µs making 2 calls to XML::Simple::CORE:match, avg 800ns/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 {
216218µs259.6ms return $self->parse_file($target, @_);
# spent 59.6ms making 2 calls to XML::Simple::parse_file, avg 29.8ms/call
217 }
218}
219
220
221##############################################################################
222# Sub/Method: parse_file()
223#
224# Same as XMLin, but only parses from a named file.
225#
226
227
# spent 59.6ms (35µs+59.6) within XML::Simple::parse_file which was called 2 times, avg 29.8ms/call: # 2 times (35µs+59.6ms) by XML::Simple::XMLin at line 216, avg 29.8ms/call
sub parse_file {
22822µs211µs my $self = &_get_object; # note, @_ is passed implicitly
# spent 11µs making 2 calls to XML::Simple::_get_object, avg 6µs/call
229
2302600ns my $filename = shift;
231
23226µs2114µs $self->handle_options('in', @_);
# spent 114µs making 2 calls to XML::Simple::handle_options, avg 57µs/call
233
2342600ns $filename = $self->default_config_file if not defined $filename;
235
23625µs261µs $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}});
# spent 61µs making 2 calls to XML::Simple::find_xml_file, avg 30µs/call
237
238 # Check cache for previous parse
239
24022µs 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
24827µs259.4ms my $ref = $self->build_simple_tree($filename, undef);
# spent 59.4ms making 2 calls to XML::Simple::build_simple_tree, avg 29.7ms/call
249
25021µs if($self->{opt}->{cache}) {
251 my $method = 'cache_write_' . $self->{opt}->{cache}->[0];
252 $self->$method($ref, $filename);
253 }
254
25525µs 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
284sub parse_string {
285 my $self = &_get_object; # note, @_ is passed implicitly
286
287 my $string = shift;
288
289 $self->handle_options('in', @_);
290
291 return $self->build_simple_tree(undef, ref $string ? $string : \$string);
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 59.4ms (47µs+59.4) within XML::Simple::build_simple_tree which was called 2 times, avg 29.7ms/call: # 2 times (47µs+59.4ms) by XML::Simple::parse_file at line 248, avg 29.7ms/call
sub build_simple_tree {
3272900ns my $self = shift;
328
32925µs255.6ms my $tree = $self->build_tree(@_);
# spent 55.6ms making 2 calls to XML::Simple::build_tree, avg 27.8ms/call
330
331 return $self->{opt}->{keeproot}
332 ? $self->collapse({}, @$tree)
333241µs23.82ms : $self->collapse(@{$tree->[1]});
# spent 3.82ms making 2 calls to XML::Simple::collapse, avg 1.91ms/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 55.6ms (2.24+53.3) within XML::Simple::build_tree which was called 2 times, avg 27.8ms/call: # 2 times (2.24ms+53.3ms) by XML::Simple::build_simple_tree at line 329, avg 27.8ms/call
sub build_tree {
3562700ns my $self = shift;
3572500ns my $filename = shift;
3582400ns my $string = shift;
359
360
3612900ns my $preferred_parser = $PREFERRED_PARSER;
36222µs unless(defined($preferred_parser)) {
363 $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
364 }
3652900ns if($preferred_parser eq 'XML::Parser') {
366 return($self->build_tree_xml_parser($filename, $string));
367 }
368
36941.30ms eval { require XML::SAX; }; # We didn't need it until now
3702700ns 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
3772600ns $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);
378
379210µs234.0ms my $sp = XML::SAX::ParserFactory->parser(Handler => $self);
# spent 34.0ms making 2 calls to XML::SAX::ParserFactory::parser, avg 17.0ms/call
380
38122µs $self->{nocollapse} = 1;
3822500ns my($tree);
38326µs216.6ms if($filename) {
# spent 16.6ms making 2 calls to XML::SAX::Base::parse_uri, avg 8.30ms/call
384 $tree = $sp->parse_uri($filename);
385 }
386 else {
387 if(ref($string) && ref($string) ne 'SCALAR') {
388 $tree = $sp->parse_file($string);
389 }
390 else {
391 $tree = $sp->parse_string($$string);
392 }
393 }
394
395226µ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
583sub XMLout {
584 my $self = &_get_object; # note, @_ is passed implicitly
585
586 croak "XMLout() requires at least one argument" unless(@_);
587 my $ref = shift;
588
589 $self->handle_options('out', @_);
590
591
592 # If namespace expansion is set, XML::NamespaceSupport is required
593
594 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
603 if(UNIVERSAL::isa($ref, 'ARRAY')) {
604 $ref = { anon => $ref };
605 }
606
607
608 # Extract rootname from top level hash if keeproot enabled
609
610 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 '') {
621 if(UNIVERSAL::isa($ref, 'HASH')) {
622 my $refsave = $ref;
623 $ref = {};
624 foreach (keys(%$refsave)) {
625 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
638 $self->{_ancestors} = [];
639 my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
640 delete $self->{_ancestors};
641
642 if($self->{opt}->{xmldecl}) {
643 $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
644 }
645
646 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 {
671 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 114µs (112+2) within XML::Simple::handle_options which was called 2 times, avg 57µs/call: # 2 times (112µs+2µs) by XML::Simple::parse_file at line 232, avg 57µs/call
sub handle_options {
6932600ns my $self = shift;
6942600ns my $dirn = shift;
695
696
697 # Determine valid options based on context
698
6992300ns my %known_opt;
700212µs if($dirn eq 'in') {
701 @known_opt{@KnownOptIn} = @KnownOptIn;
702 }
703 else {
704 @known_opt{@KnownOptOut} = @KnownOptOut;
705 }
706
707
708 # Store supplied options in hashref and weed out invalid ones
709
71021µs if(@_ % 2) {
711 croak "Options must be name=>value pairs (odd number supplied)";
712 }
71323µs my %raw_opt = @_;
7142900ns my $opt = {};
71522µs $self->{opt} = $opt;
716
71726µs while(my($key, $val) = each %raw_opt) {
71863µs my $lkey = lc($key);
719610µs62µs $lkey =~ s/_//g;
# spent 2µs making 6 calls to XML::Simple::CORE:subst, avg 333ns/call
72062µs croak "Unrecognised option: $key" unless($known_opt{$lkey});
72163µs $opt->{$lkey} = $val;
722 }
723
724
725 # Merge in options passed to constructor
726
72726µs foreach (keys(%known_opt)) {
7283813µ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
73821µs if(exists($opt->{rootname})) {
739 unless(defined($opt->{rootname})) {
740 $opt->{rootname} = '';
741 }
742 }
743 else {
74422µs $opt->{rootname} = $DefRootName;
745 }
746
7472800ns if($opt->{xmldecl} and $opt->{xmldecl} eq '1') {
748 $opt->{xmldecl} = $DefXmlDecl;
749 }
750
75121µs if(exists($opt->{contentkey})) {
752 if($opt->{contentkey} =~ m{^-(.*)$}) {
753 $opt->{contentkey} = $1;
754 $opt->{collapseagain} = 1;
755 }
756 }
757 else {
75821µs $opt->{contentkey} = $DefContentKey;
759 }
760
76122µs unless(exists($opt->{normalisespace})) {
762 $opt->{normalisespace} = $opt->{normalizespace};
763 }
76421µs $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));
765
766 # Cleanups for values assumed to be arrays later
767
76821µs if($opt->{searchpath}) {
769 unless(ref($opt->{searchpath})) {
770 $opt->{searchpath} = [ $opt->{searchpath} ];
771 }
772 }
773 else {
77422µs $opt->{searchpath} = [ ];
775 }
776
7772700ns if($opt->{cache} and !ref($opt->{cache})) {
778 $opt->{cache} = [ $opt->{cache} ];
779 }
7802900ns 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
78922µ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 {
79621µ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
80322µs if(exists($opt->{forcearray})) {
80422µs if(ref($opt->{forcearray}) eq 'Regexp') {
805 $opt->{forcearray} = [ $opt->{forcearray} ];
806 }
807
80822µs if(ref($opt->{forcearray}) eq 'ARRAY') {
80922µs my @force_list = @{$opt->{forcearray}};
81021µs if(@force_list) {
81121µs $opt->{forcearray} = {};
81221µs foreach my $tag (@force_list) {
81362µs if(ref($tag) eq 'Regexp') {
814 push @{$opt->{forcearray}->{_regex}}, $tag;
815 }
816 else {
81763µs $opt->{forcearray}->{$tag} = 1;
818 }
819 }
820 }
821 else {
822 $opt->{forcearray} = 0;
823 }
824 }
825 else {
826 $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
827 }
828 }
829 else {
830 if($opt->{strictmode} and $dirn eq 'in') {
831 croak "No value specified for 'ForceArray' option in call to XML$dirn()";
832 }
833 $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
84022µs if(exists($opt->{keyattr})) {
84122µs if(ref($opt->{keyattr})) {
84221µ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 {
86821µ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
88722µ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
8962900ns 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
90921µs if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
910 croak "Illegal value for 'Variables' option - expected a hashref";
911 }
912
913210µ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
932
# spent 61µs (23+38) within XML::Simple::find_xml_file which was called 2 times, avg 30µs/call: # 2 times (23µs+38µs) by XML::Simple::parse_file at line 236, avg 30µs/call
sub find_xml_file {
9332800ns my $self = shift;
9342600ns my $file = shift;
9352900ns my @search_path = @_;
936
937
93822µs require File::Basename;
93921µs require File::Spec;
940
94124µs230µs my($filename, $filedir) = File::Basename::fileparse($file);
# spent 30µs making 2 calls to File::Basename::fileparse, avg 15µs/call
942
943220µs29µs if($filename ne $file) { # Ignore searchpath if dir component
# spent 9µs making 2 calls to XML::Simple::CORE:ftis, avg 4µs/call
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 3.82ms (3.08+741µs) within XML::Simple::collapse which was called 142 times, avg 27µs/call: # 140 times (2.23ms+-2.23ms) by XML::Simple::collapse at line 1038, avg 0s/call # 2 times (851µs+2.97ms) by XML::Simple::build_simple_tree at line 333, avg 1.91ms/call
sub collapse {
99314217µs my $self = shift;
994
995
996 # Start with the hash of attributes
997
99814212µs my $attr = shift;
99914266µ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
101114222µ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
102114223µs if(!@_ and keys %$attr == 1) {
1022 my($k) = keys %$attr;
1023 if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) {
1024 return $attr->{$k};
1025 }
1026 }
1027
1028
1029 # Add any nested elements
1030
103114211µs my($key, $val);
103214250µs while(@_) {
103341468µs $key = shift;
103441456µs $val = shift;
103541436µs $val = '' if not defined $val;
1036
103741490µs if(ref($val)) {
1038140167µs1400s $val = $self->collapse(@$val);
# spent 4.49ms making 140 calls to XML::Simple::collapse, avg 32µs/call, recursion: max depth 3, sum of overlapping time 4.49ms
103914032µs next if(!defined($val) and $self->{opt}->{suppressempty});
1040 }
1041 elsif($key eq '0') {
10422741.21ms274196µs next if($val =~ m{^\s*$}s); # Skip all whitespace content
# spent 196µs making 274 calls to XML::Simple::CORE:match, avg 717ns/call
1043
104411828µs $val = $self->normalise_space($val)
1045 if($self->{opt}->{normalisespace} == 2);
1046
1047 # do variable substitutions
1048
104911820µ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
105611818µ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
1065118237µs if(!%$attr and !@_) {
1066 return($self->{opt}->{forcecontent} ?
1067 { $self->{opt}->{contentkey} => $val } : $val
1068 );
1069 }
10702812µs $key = $self->{opt}->{contentkey};
1071 }
1072
1073
1074 # Combine duplicate attributes into arrayref if required
1075
1076168471µs168162µs if(exists($attr->{$key})) {
# spent 162µs making 168 calls to UNIVERSAL::isa, avg 963ns/call
1077 if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
1078 push(@{$attr->{$key}}, $val);
1079 }
1080 else {
108165µs $attr->{$key} = [ $attr->{$key}, $val ];
1082 }
1083 }
1084 elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
1085 $attr->{$key} = [ $val ];
1086 }
1087 else {
1088136185µ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 {
110312891µs $attr->{$key} = $val;
1104 }
1105 }
1106
1107 }
1108
1109
1110 # Turn arrayrefs into hashrefs if key fields present
1111
11125279µs if($self->{opt}->{keyattr}) {
1113 while(($key,$val) = each %$attr) {
1114192463µs206382µs if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
# spent 241µs making 14 calls to XML::Simple::array_to_hash, avg 17µs/call # spent 141µs making 192 calls to UNIVERSAL::isa, avg 734ns/call
1115 $attr->{$key} = $self->array_to_hash($key, $val);
1116 }
1117 }
1118 }
1119
1120
1121 # disintermediate grouped tags
1122
11235211µ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
11395212µs my $count = scalar keys %$attr;
1140527µ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
1150528µ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
1161529µ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
11715261µ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
1234
# spent 241µs (200+41) within XML::Simple::array_to_hash which was called 14 times, avg 17µs/call: # 14 times (200µs+41µs) by XML::Simple::collapse at line 1114, avg 17µs/call
sub array_to_hash {
1235143µs my $self = shift;
1236143µs my $name = shift;
1237141µs my $arrayref = shift;
1238
12391410µs1412µs my $hashref = $self->new_hashref;
# spent 12µs making 14 calls to XML::Simple::new_hashref, avg 850ns/call
1240
1241141µs my($i, $key, $val, $flag);
1242
1243
1244 # Handle keyattr => { .... }
1245
1246149µs 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 =
12781423µs join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}});
1279
1280149µs ELEMENT: for($i = 0; $i < @$arrayref; $i++) {
12812055µs208µs return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));
# spent 8µs making 20 calls to UNIVERSAL::isa, avg 420ns/call
1282
1283189µs foreach $key (@{$self->{opt}->{keyattr}}) {
1284189µs if(defined($arrayref->[$i]->{$key})) {
1285123µs $val = $arrayref->[$i]->{$key};
1286121µs 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 }
1291123µs $val = $self->normalise_space($val)
1292 if($self->{opt}->{normalisespace} == 1);
1293122µs $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
1294 if(exists($hashref->{$val}));
12951223µs1220µs $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} );
# spent 20µs making 12 calls to XML::Simple::new_hashref, avg 2µs/call
1296125µs delete $hashref->{$val}->{$key};
1297124µs next ELEMENT;
1298 }
1299 }
1300
1301612µs return($arrayref); # No keyfield matched
1302 }
1303 }
1304
1305 # collapse any hashes which now only have a 'content' key
1306
130762µs if($self->{opt}->{collapseagain}) {
1308 $hashref = $self->collapse_content($hashref);
1309 }
1310
131167µs 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
1343
# spent 32µs within XML::Simple::new_hashref which was called 26 times, avg 1µs/call: # 14 times (12µs+0s) by XML::Simple::array_to_hash at line 1239, avg 850ns/call # 12 times (20µs+0s) by XML::Simple::array_to_hash at line 1295, avg 2µs/call
sub new_hashref {
1344263µs my $self = shift;
1345
13462648µs 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
1404sub value_to_xml {
1405 my $self = shift;;
1406
1407
1408 # Grab the other arguments
1409
1410 my($ref, $name, $indent) = @_;
1411
1412 my $named = (defined($name) and $name ne '' ? 1 : 0);
1413
1414 my $nl = "\n";
1415
1416 my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack!
1417 if($self->{opt}->{noindent}) {
1418 $indent = '';
1419 $nl = '';
1420 }
1421
1422
1423 # Convert to XML
1424
1425 if(ref($ref)) {
1426 croak "circular data structures not supported"
1427 if(grep($_ == $ref, @{$self->{_ancestors}}));
1428 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
1446 if(UNIVERSAL::isa($ref, 'HASH') # It is a hash
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
1455 my @result = ();
1456 my($key, $value);
1457
1458
1459 # Handle hashrefs
1460
1461 if(UNIVERSAL::isa($ref, 'HASH')) {
1462
1463 # Reintermediate grouped values if applicable
1464
1465 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
1479 my $nsdecls = '';
1480 my $default_ns_uri;
1481 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
1534 my @nested = ();
1535 my $text_content = undef;
1536 if($named) {
1537 push @result, $indent, '<', $name, $nsdecls;
1538 }
1539
1540 if(keys %$ref) {
1541 my $first_arg = 1;
1542 foreach my $key ($self->sorted_keys($name, $ref)) {
1543 my $value = $ref->{$key};
1544 next if(substr($key, 0, 1) eq '-');
1545 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
1560 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
1569 if(ref($value) or $self->{opt}->{noattr}) {
1570 push @nested,
1571 $self->value_to_xml($value, $key, "$indent ");
1572 }
1573 else {
1574 $value = $self->escape_value($value) unless($self->{opt}->{noescape});
1575 if($key eq $self->{opt}->{contentkey}) {
1576 $text_content = $value;
1577 }
1578 else {
1579 push @result, "\n$indent " . ' ' x length($name)
1580 if($self->{opt}->{attrindent} and !$first_arg);
1581 push @result, ' ', $key, '="', $value , '"';
1582 $first_arg = 0;
1583 }
1584 }
1585 }
1586 }
1587 else {
1588 $text_content = '';
1589 }
1590
1591 if(@nested or defined($text_content)) {
1592 if($named) {
1593 push @result, ">";
1594 if(defined($text_content)) {
1595 push @result, $text_content;
1596 $nested[0] =~ s/^\s+// if(@nested);
1597 }
1598 else {
1599 push @result, $nl;
1600 }
1601 if(@nested) {
1602 push @result, @nested, $indent;
1603 }
1604 push @result, '</', $name, ">", $nl;
1605 }
1606 else {
1607 push @result, @nested; # Special case if no root elements
1608 }
1609 }
1610 else {
1611 push @result, " />", $nl;
1612 }
1613 $self->{nsup}->pop_context() if($self->{nsup});
1614 }
1615
1616
1617 # Handle arrayrefs
1618
1619 elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
1620 foreach $value (@$ref) {
1621 next if !defined($value) and $self->{opt}->{suppressempty};
1622 if(!ref($value)) {
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
1645 pop @{$self->{_ancestors}} if(ref($ref));
1646
1647 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
1658sub sorted_keys {
1659 my($self, $name, $ref) = @_;
1660
1661 return keys %$ref if $self->{opt}->{nosort};
1662
1663 my %hash = %$ref;
1664 my $keyattr = $self->{opt}->{keyattr};
1665
1666 my @key;
1667
1668 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
1684 return(@key, sort keys %hash);
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
1694sub escape_value {
1695 my($self, $data) = @_;
1696
1697 return '' unless(defined($data));
1698
1699 $data =~ s/&/&amp;/sg;
1700 $data =~ s/</&lt;/sg;
1701 $data =~ s/>/&gt;/sg;
1702 $data =~ s/"/&quot;/sg;
1703
1704 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
171222.19ms21.45ms
# spent 1.45ms (1.45+3µs) within XML::Simple::BEGIN@1712 which was called: # once (1.45ms+3µs) by C4::Context::BEGIN@102 at line 1712
use utf8; # required for 5.6
# spent 1.45ms making 1 call to XML::Simple::BEGIN@1712 # spent 3µ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 11µs within XML::Simple::start_document which was called 2 times, avg 6µs/call: # 2 times (11µs+0s) by XML::SAX::Base::start_document at line 1265 of XML/SAX/Base.pm, avg 6µs/call
sub start_document {
17842700ns my $self = shift;
1785
178621µs $self->handle_options('in') unless($self->{opt});
1787
178821µs $self->{lists} = [];
1789210µs $self->{curlist} = $self->{tree} = [];
1790}
1791
1792
1793
# spent 620µs within XML::Simple::start_element which was called 142 times, avg 4µs/call: # 140 times (603µs+0s) by XML::SAX::Base::__ANON__[/usr/share/perl5/XML/SAX/Base.pm:298] at line 298 of XML/SAX/Base.pm, avg 4µs/call # 2 times (17µs+0s) by XML::SAX::Base::start_element at line 299 of XML/SAX/Base.pm, avg 8µs/call
sub start_element {
179414216µs my $self = shift;
179514211µs my $element = shift;
1796
179714226µs my $name = $element->{Name};
179814232µs if($self->{opt}->{nsexpand}) {
1799 $name = $element->{LocalName} || '';
1800 if($element->{NamespaceURI}) {
1801 $name = '{' . $element->{NamespaceURI} . '}' . $name;
1802 }
1803 }
180414231µs my $attributes = {};
180514244µs if($element->{Attributes}) { # Might be undef
1806142129µs foreach my $attr (values %{$element->{Attributes}}) {
18075630µ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 {
18165635µs $attributes->{$attr->{Name}} = $attr->{Value};
1817 }
1818 }
1819 }
182014248µs my $newlist = [ $attributes ];
182114243µs push @{ $self->{lists} }, $self->{curlist};
182214270µs push @{ $self->{curlist} }, $name => $newlist;
1823142247µs $self->{curlist} = $newlist;
1824}
1825
1826
1827
# spent 1.05ms within XML::Simple::characters which was called 478 times, avg 2µs/call: # 476 times (1.03ms+0s) by XML::SAX::Base::__ANON__[/usr/share/perl5/XML/SAX/Base.pm:206] at line 206 of XML/SAX/Base.pm, avg 2µs/call # 2 times (11µs+0s) by XML::SAX::Base::characters at line 207 of XML/SAX/Base.pm, avg 5µs/call
sub characters {
182847856µs my $self = shift;
182947836µs my $chars = shift;
1830
1831478102µs my $text = $chars->{Data};
183247866µs my $clist = $self->{curlist};
183347894µs my $pos = $#$clist;
1834
18354781.05ms if ($pos > 0 and $clist->[$pos - 1] eq '0') {
1836 $clist->[$pos] .= $text;
1837 }
1838 else {
1839274148µs push @$clist, 0 => $text;
1840 }
1841}
1842
1843
1844
# spent 112µs within XML::Simple::end_element which was called 142 times, avg 788ns/call: # 140 times (108µs+0s) by XML::SAX::Base::__ANON__[/usr/share/perl5/XML/SAX/Base.pm:2207] at line 2207 of XML/SAX/Base.pm, avg 768ns/call # 2 times (4µs+0s) by XML::SAX::Base::end_element at line 2208 of XML/SAX/Base.pm, avg 2µs/call
sub end_element {
184514216µs my $self = shift;
1846
1847142251µs $self->{curlist} = pop @{ $self->{lists} };
1848}
1849
1850
1851
# spent 8µs within XML::Simple::end_document which was called 2 times, avg 4µs/call: # 2 times (8µs+0s) by XML::SAX::Base::end_document at line 1449 of XML/SAX/Base.pm, avg 4µs/call
sub end_document {
18522900ns my $self = shift;
1853
185422µs delete($self->{curlist});
18552700ns delete($self->{lists});
1856
18572600ns my $tree = $self->{tree};
18582400ns delete($self->{tree});
1859
1860
1861 # Return tree as-is to XMLin()
1862
186326µ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
188211µs*xml_in = \&XMLin;
18831200ns*xml_out = \&XMLout;
1884
1885110µs1;
1886
1887__END__
 
# spent 9µs within XML::Simple::CORE:ftis which was called 2 times, avg 4µs/call: # 2 times (9µs+0s) by XML::Simple::find_xml_file at line 943, avg 4µs/call
sub XML::Simple::CORE:ftis; # opcode
# spent 200µs within XML::Simple::CORE:match which was called 278 times, avg 719ns/call: # 274 times (196µs+0s) by XML::Simple::collapse at line 1042, avg 717ns/call # 2 times (2µs+0s) by XML::Simple::XMLin at line 192, avg 800ns/call # once (2µs+0s) by XML::Simple::import at line 93 # once (300ns+0s) by XML::Simple::import at line 97
sub XML::Simple::CORE:match; # opcode
# spent 5µs within XML::Simple::CORE:subst which was called 8 times, avg 575ns/call: # 6 times (2µs+0s) by XML::Simple::handle_options at line 719, avg 333ns/call # 2 times (3µs+0s) by XML::Simple::new at line 122, avg 1µs/call
sub XML::Simple::CORE:subst; # opcode
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.