← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:22 2013

Filename/usr/share/perl5/XML/Simple.pm
StatementsExecuted 41 statements in 7.49ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
33362µs72µsXML::Simple::::importXML::Simple::import
11129µs37µsXML::Simple::::BEGIN@1687XML::Simple::BEGIN@1687
11121µs123µsXML::Simple::::BEGIN@51XML::Simple::BEGIN@51
11120µs28µsXML::Simple::::BEGIN@42XML::Simple::BEGIN@42
11114µs92µsXML::Simple::::BEGIN@43XML::Simple::BEGIN@43
62110µs10µsXML::Simple::::CORE:matchXML::Simple::CORE:match (opcode)
0000s0sXML::Simple::::XMLinXML::Simple::XMLin
0000s0sXML::Simple::::XMLoutXML::Simple::XMLout
0000s0sXML::Simple::::_get_objectXML::Simple::_get_object
0000s0sXML::Simple::::array_to_hashXML::Simple::array_to_hash
0000s0sXML::Simple::::build_simple_treeXML::Simple::build_simple_tree
0000s0sXML::Simple::::build_treeXML::Simple::build_tree
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::::charactersXML::Simple::characters
0000s0sXML::Simple::::collapseXML::Simple::collapse
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::::end_documentXML::Simple::end_document
0000s0sXML::Simple::::end_elementXML::Simple::end_element
0000s0sXML::Simple::::escape_valueXML::Simple::escape_value
0000s0sXML::Simple::::find_xml_fileXML::Simple::find_xml_file
0000s0sXML::Simple::::get_varXML::Simple::get_var
0000s0sXML::Simple::::handle_optionsXML::Simple::handle_options
0000s0sXML::Simple::::hash_to_arrayXML::Simple::hash_to_array
0000s0sXML::Simple::::newXML::Simple::new
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::::parse_stringXML::Simple::parse_string
0000s0sXML::Simple::::set_varXML::Simple::set_var
0000s0sXML::Simple::::sorted_keysXML::Simple::sorted_keys
0000s0sXML::Simple::::start_documentXML::Simple::start_document
0000s0sXML::Simple::::start_elementXML::Simple::start_element
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
1# $Id: Simple.pm,v 1.40 2007/08/15 10:36:48 grantm Exp $
2
3package XML::Simple;
4
5=head1 NAME
6
- -
37# See after __END__ for more POD documentation
38
39
40# Load essentials here, other modules loaded on demand later
41
42337µs237µs
# spent 28µs (20+8) within XML::Simple::BEGIN@42 which was called: # once (20µs+8µs) by C4::Context::BEGIN@103 at line 42
use strict;
# spent 28µs making 1 call to XML::Simple::BEGIN@42 # spent 8µs making 1 call to strict::import
43374µs2169µs
# spent 92µs (14+78) within XML::Simple::BEGIN@43 which was called: # once (14µs+78µs) by C4::Context::BEGIN@103 at line 43
use Carp;
# spent 92µs making 1 call to XML::Simple::BEGIN@43 # spent 78µs making 1 call to Exporter::import
4412µsrequire Exporter;
45
46
47##############################################################################
48# Define some constants
49#
50
5136.34ms2225µs
# spent 123µs (21+102) within XML::Simple::BEGIN@51 which was called: # once (21µs+102µs) by C4::Context::BEGIN@103 at line 51
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);
# spent 123µs making 1 call to XML::Simple::BEGIN@51 # spent 102µs making 1 call to vars::import
52
53118µs@ISA = qw(Exporter);
5411µs@EXPORT = qw(XMLin XMLout);
5511µs@EXPORT_OK = qw(xml_in xml_out);
561600ns$VERSION = '2.18';
571600ns$PREFERRED_PARSER = undef;
58
591900nsmy $StrictMode = 0;
60
6115µsmy @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr
62 searchpath forcearray cache suppressempty parseropts
63 grouptags nsexpand datahandler varattr variables
64 normalisespace normalizespace valueattr);
65
6615µsmy @KnownOptOut = qw(keyattr keeproot contentkey noattr
67 rootname xmldecl outputfile noescape suppressempty
68 grouptags nsexpand handler noindent attrindent nosort
69 valueattr numericescape);
70
7111µsmy @DefKeyAttr = qw(name key id);
721500nsmy $DefRootName = qq(opt);
731500nsmy $DefContentKey = qq(content);
741400nsmy $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>);
75
761300nsmy $xmlns_ns = 'http://www.w3.org/2000/xmlns/';
7712µsmy $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround
78
79
80##############################################################################
81# Globals for use by caching routines
82#
83
841800nsmy %MemShareCache = ();
851300nsmy %MemCopyCache = ();
86
87
88##############################################################################
89# Wrapper for Exporter - handles ':strict'
90#
91
92
# spent 72µs (62+10) within XML::Simple::import which was called 3 times, avg 24µs/call: # once (22µs+4µs) by C4::Search::PazPar2::BEGIN@26 at line 26 of /usr/share/koha/lib/C4/Search/PazPar2.pm # once (22µs+3µs) by C4::Context::BEGIN@103 at line 103 of /usr/share/koha/lib/C4/Context.pm # once (18µs+3µs) by C4::Search::BEGIN@26 at line 26 of /usr/share/koha/lib/C4/Search.pm
sub import {
93 # Handle the :strict tag
94
95990µs37µs $StrictMode = 1 if grep(/^:strict$/, @_);
# spent 7µs making 3 calls to XML::Simple::CORE:match, avg 2µs/call
96
97 # Pass everything else to Exporter.pm
98
9933µs @_ = grep(!/^:strict$/, @_);
# spent 3µs making 3 calls to XML::Simple::CORE:match, avg 900ns/call
1003209µs goto &Exporter::import;
# spent 209µs making 3 calls to Exporter::import, avg 70µs/call
101}
102
103
104##############################################################################
105# Constructor for optional object interface.
106#
107
108sub new {
109 my $class = shift;
110
111 if(@_ % 2) {
112 croak "Default options must be name=>value pairs (odd number supplied)";
113 }
114
115 my %known_opt;
116 @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100;
117
118 my %raw_opt = @_;
119 my %def_opt;
120 while(my($key, $val) = each %raw_opt) {
121 my $lkey = lc($key);
122 $lkey =~ s/_//g;
123 croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
124 $def_opt{$lkey} = $val;
125 }
126 my $self = { def_opt => \%def_opt };
127
128 return(bless($self, $class));
129}
130
131
132##############################################################################
133# Sub: _get_object()
134#
135# Helper routine called from XMLin() and XMLout() to create an object if none
136# was provided. Note, this routine does mess with the caller's @_ array.
137#
138
139sub _get_object {
140 my $self;
141 if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) {
142 $self = shift;
143 }
144 else {
145 $self = XML::Simple->new();
146 }
147
148 return $self;
149}
150
151
152##############################################################################
153# Sub/Method: XMLin()
154#
155# Exported routine for slurping XML into a hashref - see pod for info.
156#
157# May be called as object method or as a plain function.
158#
159# Expects one arg for the source XML, optionally followed by a number of
160# name => value option pairs.
161#
162
163sub XMLin {
164 my $self = &_get_object; # note, @_ is passed implicitly
165
166 my $target = shift;
167
168
169 # Work out whether to parse a string, a file or a filehandle
170
171 if(not defined $target) {
172 return $self->parse_file(undef, @_);
173 }
174
175 elsif($target eq '-') {
176 local($/) = undef;
177 $target = <STDIN>;
178 return $self->parse_string(\$target, @_);
179 }
180
181 elsif(my $type = ref($target)) {
182 if($type eq 'SCALAR') {
183 return $self->parse_string($target, @_);
184 }
185 else {
186 return $self->parse_fh($target, @_);
187 }
188 }
189
190 elsif($target =~ m{<.*?>}s) {
191 return $self->parse_string(\$target, @_);
192 }
193
194 else {
195 return $self->parse_file($target, @_);
196 }
197}
198
199
200##############################################################################
201# Sub/Method: parse_file()
202#
203# Same as XMLin, but only parses from a named file.
204#
205
206sub parse_file {
207 my $self = &_get_object; # note, @_ is passed implicitly
208
209 my $filename = shift;
210
211 $self->handle_options('in', @_);
212
213 $filename = $self->default_config_file if not defined $filename;
214
215 $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}});
216
217 # Check cache for previous parse
218
219 if($self->{opt}->{cache}) {
220 foreach my $scheme (@{$self->{opt}->{cache}}) {
221 my $method = 'cache_read_' . $scheme;
222 my $opt = $self->$method($filename);
223 return($opt) if($opt);
224 }
225 }
226
227 my $ref = $self->build_simple_tree($filename, undef);
228
229 if($self->{opt}->{cache}) {
230 my $method = 'cache_write_' . $self->{opt}->{cache}->[0];
231 $self->$method($ref, $filename);
232 }
233
234 return $ref;
235}
236
237
238##############################################################################
239# Sub/Method: parse_fh()
240#
241# Same as XMLin, but only parses from a filehandle.
242#
243
244sub parse_fh {
245 my $self = &_get_object; # note, @_ is passed implicitly
246
247 my $fh = shift;
248 croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') .
249 " as a filehandle" unless ref $fh;
250
251 $self->handle_options('in', @_);
252
253 return $self->build_simple_tree(undef, $fh);
254}
255
256
257##############################################################################
258# Sub/Method: parse_string()
259#
260# Same as XMLin, but only parses from a string or a reference to a string.
261#
262
263sub parse_string {
264 my $self = &_get_object; # note, @_ is passed implicitly
265
266 my $string = shift;
267
268 $self->handle_options('in', @_);
269
270 return $self->build_simple_tree(undef, ref $string ? $string : \$string);
271}
272
273
274##############################################################################
275# Method: default_config_file()
276#
277# Returns the name of the XML file to parse if no filename (or XML string)
278# was provided.
279#
280
281sub default_config_file {
282 my $self = shift;
283
284 require File::Basename;
285
286 my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+');
287
288 # Add script directory to searchpath
289
290 if($script_dir) {
291 unshift(@{$self->{opt}->{searchpath}}, $script_dir);
292 }
293
294 return $basename . '.xml';
295}
296
297
298##############################################################################
299# Method: build_simple_tree()
300#
301# Builds a 'tree' data structure as provided by XML::Parser and then
302# 'simplifies' it as specified by the various options in effect.
303#
304
305sub build_simple_tree {
306 my $self = shift;
307
308 my $tree = $self->build_tree(@_);
309
310 return $self->{opt}->{keeproot}
311 ? $self->collapse({}, @$tree)
312 : $self->collapse(@{$tree->[1]});
313}
314
315
316##############################################################################
317# Method: build_tree()
318#
319# This routine will be called if there is no suitable pre-parsed tree in a
320# cache. It parses the XML and returns an XML::Parser 'Tree' style data
321# structure (summarised in the comments for the collapse() routine below).
322#
323# XML::Simple requires the services of another module that knows how to parse
324# XML. If XML::SAX is installed, the default SAX parser will be used,
325# otherwise XML::Parser will be used.
326#
327# This routine expects to be passed a filename as argument 1 or a 'string' as
328# argument 2. The 'string' might be a string of XML (passed by reference to
329# save memory) or it might be a reference to an IO::Handle. (This
330# non-intuitive mess results in part from the way XML::Parser works but that's
331# really no excuse).
332#
333
334sub build_tree {
335 my $self = shift;
336 my $filename = shift;
337 my $string = shift;
338
339
340 my $preferred_parser = $PREFERRED_PARSER;
341 unless(defined($preferred_parser)) {
342 $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
343 }
344 if($preferred_parser eq 'XML::Parser') {
345 return($self->build_tree_xml_parser($filename, $string));
346 }
347
348 eval { require XML::SAX; }; # We didn't need it until now
349 if($@) { # No XML::SAX - fall back to XML::Parser
350 if($preferred_parser) { # unless a SAX parser was expressly requested
351 croak "XMLin() could not load XML::SAX";
352 }
353 return($self->build_tree_xml_parser($filename, $string));
354 }
355
356 $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);
357
358 my $sp = XML::SAX::ParserFactory->parser(Handler => $self);
359
360 $self->{nocollapse} = 1;
361 my($tree);
362 if($filename) {
363 $tree = $sp->parse_uri($filename);
364 }
365 else {
366 if(ref($string) && ref($string) ne 'SCALAR') {
367 $tree = $sp->parse_file($string);
368 }
369 else {
370 $tree = $sp->parse_string($$string);
371 }
372 }
373
374 return($tree);
375}
376
377
378##############################################################################
379# Method: build_tree_xml_parser()
380#
381# This routine will be called if XML::SAX is not installed, or if XML::Parser
382# was specifically requested. It takes the same arguments as build_tree() and
383# returns the same data structure (XML::Parser 'Tree' style).
384#
385
386sub build_tree_xml_parser {
387 my $self = shift;
388 my $filename = shift;
389 my $string = shift;
390
391
392 eval {
393 local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load()
394 require XML::Parser; # We didn't need it until now
395 };
396 if($@) {
397 croak "XMLin() requires either XML::SAX or XML::Parser";
398 }
399
400 if($self->{opt}->{nsexpand}) {
401 carp "'nsexpand' option requires XML::SAX";
402 }
403
404 my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}});
405 my($tree);
406 if($filename) {
407 # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl
408 local(*XML_FILE);
409 open(XML_FILE, '<', $filename) || croak qq($filename - $!);
410 $tree = $xp->parse(*XML_FILE);
411 close(XML_FILE);
412 }
413 else {
414 $tree = $xp->parse($$string);
415 }
416
417 return($tree);
418}
419
420
421##############################################################################
422# Method: cache_write_storable()
423#
424# Wrapper routine for invoking Storable::nstore() to cache a parsed data
425# structure.
426#
427
428sub cache_write_storable {
429 my($self, $data, $filename) = @_;
430
431 my $cachefile = $self->storable_filename($filename);
432
433 require Storable; # We didn't need it until now
434
435 if ('VMS' eq $^O) {
436 Storable::nstore($data, $cachefile);
437 }
438 else {
439 # If the following line fails for you, your Storable.pm is old - upgrade
440 Storable::lock_nstore($data, $cachefile);
441 }
442
443}
444
445
446##############################################################################
447# Method: cache_read_storable()
448#
449# Wrapper routine for invoking Storable::retrieve() to read a cached parsed
450# data structure. Only returns cached data if the cache file exists and is
451# newer than the source XML file.
452#
453
454sub cache_read_storable {
455 my($self, $filename) = @_;
456
457 my $cachefile = $self->storable_filename($filename);
458
459 return unless(-r $cachefile);
460 return unless((stat($cachefile))[9] > (stat($filename))[9]);
461
462 require Storable; # We didn't need it until now
463
464 if ('VMS' eq $^O) {
465 return(Storable::retrieve($cachefile));
466 }
467 else {
468 return(Storable::lock_retrieve($cachefile));
469 }
470
471}
472
473
474##############################################################################
475# Method: storable_filename()
476#
477# Translates the supplied source XML filename into a filename for the storable
478# cached data. A '.stor' suffix is added after stripping an optional '.xml'
479# suffix.
480#
481
482sub storable_filename {
483 my($self, $cachefile) = @_;
484
485 $cachefile =~ s{(\.xml)?$}{.stor};
486 return $cachefile;
487}
488
489
490##############################################################################
491# Method: cache_write_memshare()
492#
493# Takes the supplied data structure reference and stores it away in a global
494# hash structure.
495#
496
497sub cache_write_memshare {
498 my($self, $data, $filename) = @_;
499
500 $MemShareCache{$filename} = [time(), $data];
501}
502
503
504##############################################################################
505# Method: cache_read_memshare()
506#
507# Takes a filename and looks in a global hash for a cached parsed version.
508#
509
510sub cache_read_memshare {
511 my($self, $filename) = @_;
512
513 return unless($MemShareCache{$filename});
514 return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);
515
516 return($MemShareCache{$filename}->[1]);
517
518}
519
520
521##############################################################################
522# Method: cache_write_memcopy()
523#
524# Takes the supplied data structure and stores a copy of it in a global hash
525# structure.
526#
527
528sub cache_write_memcopy {
529 my($self, $data, $filename) = @_;
530
531 require Storable; # We didn't need it until now
532
533 $MemCopyCache{$filename} = [time(), Storable::dclone($data)];
534}
535
536
537##############################################################################
538# Method: cache_read_memcopy()
539#
540# Takes a filename and looks in a global hash for a cached parsed version.
541# Returns a reference to a copy of that data structure.
542#
543
544sub cache_read_memcopy {
545 my($self, $filename) = @_;
546
547 return unless($MemCopyCache{$filename});
548 return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);
549
550 return(Storable::dclone($MemCopyCache{$filename}->[1]));
551
552}
553
554
555##############################################################################
556# Sub/Method: XMLout()
557#
558# Exported routine for 'unslurping' a data structure out to XML.
559#
560# Expects a reference to a data structure and an optional list of option
561# name => value pairs.
562#
563
564sub XMLout {
565 my $self = &_get_object; # note, @_ is passed implicitly
566
567 croak "XMLout() requires at least one argument" unless(@_);
568 my $ref = shift;
569
570 $self->handle_options('out', @_);
571
572
573 # If namespace expansion is set, XML::NamespaceSupport is required
574
575 if($self->{opt}->{nsexpand}) {
576 require XML::NamespaceSupport;
577 $self->{nsup} = XML::NamespaceSupport->new();
578 $self->{ns_prefix} = 'aaa';
579 }
580
581
582 # Wrap top level arrayref in a hash
583
584 if(UNIVERSAL::isa($ref, 'ARRAY')) {
585 $ref = { anon => $ref };
586 }
587
588
589 # Extract rootname from top level hash if keeproot enabled
590
591 if($self->{opt}->{keeproot}) {
592 my(@keys) = keys(%$ref);
593 if(@keys == 1) {
594 $ref = $ref->{$keys[0]};
595 $self->{opt}->{rootname} = $keys[0];
596 }
597 }
598
599 # Ensure there are no top level attributes if we're not adding root elements
600
601 elsif($self->{opt}->{rootname} eq '') {
602 if(UNIVERSAL::isa($ref, 'HASH')) {
603 my $refsave = $ref;
604 $ref = {};
605 foreach (keys(%$refsave)) {
606 if(ref($refsave->{$_})) {
607 $ref->{$_} = $refsave->{$_};
608 }
609 else {
610 $ref->{$_} = [ $refsave->{$_} ];
611 }
612 }
613 }
614 }
615
616
617 # Encode the hashref and write to file if necessary
618
619 $self->{_ancestors} = [];
620 my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
621 delete $self->{_ancestors};
622
623 if($self->{opt}->{xmldecl}) {
624 $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
625 }
626
627 if($self->{opt}->{outputfile}) {
628 if(ref($self->{opt}->{outputfile})) {
629 my $fh = $self->{opt}->{outputfile};
630 if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) {
631 eval { require IO::Handle; };
632 croak $@ if $@;
633 }
634 return($fh->print($xml));
635 }
636 else {
637 local(*OUT);
638 open(OUT, '>', "$self->{opt}->{outputfile}") ||
639 croak "open($self->{opt}->{outputfile}): $!";
640 binmode(OUT, ':utf8') if($] >= 5.008);
641 print OUT $xml || croak "print: $!";
642 close(OUT);
643 }
644 }
645 elsif($self->{opt}->{handler}) {
646 require XML::SAX;
647 my $sp = XML::SAX::ParserFactory->parser(
648 Handler => $self->{opt}->{handler}
649 );
650 return($sp->parse_string($xml));
651 }
652 else {
653 return($xml);
654 }
655}
656
657
658##############################################################################
659# Method: handle_options()
660#
661# Helper routine for both XMLin() and XMLout(). Both routines handle their
662# first argument and assume all other args are options handled by this routine.
663# Saves a hash of options in $self->{opt}.
664#
665# If default options were passed to the constructor, they will be retrieved
666# here and merged with options supplied to the method call.
667#
668# First argument should be the string 'in' or the string 'out'.
669#
670# Remaining arguments should be name=>value pairs. Sets up default values
671# for options not supplied. Unrecognised options are a fatal error.
672#
673
674sub handle_options {
675 my $self = shift;
676 my $dirn = shift;
677
678
679 # Determine valid options based on context
680
681 my %known_opt;
682 if($dirn eq 'in') {
683 @known_opt{@KnownOptIn} = @KnownOptIn;
684 }
685 else {
686 @known_opt{@KnownOptOut} = @KnownOptOut;
687 }
688
689
690 # Store supplied options in hashref and weed out invalid ones
691
692 if(@_ % 2) {
693 croak "Options must be name=>value pairs (odd number supplied)";
694 }
695 my %raw_opt = @_;
696 my $opt = {};
697 $self->{opt} = $opt;
698
699 while(my($key, $val) = each %raw_opt) {
700 my $lkey = lc($key);
701 $lkey =~ s/_//g;
702 croak "Unrecognised option: $key" unless($known_opt{$lkey});
703 $opt->{$lkey} = $val;
704 }
705
706
707 # Merge in options passed to constructor
708
709 foreach (keys(%known_opt)) {
710 unless(exists($opt->{$_})) {
711 if(exists($self->{def_opt}->{$_})) {
712 $opt->{$_} = $self->{def_opt}->{$_};
713 }
714 }
715 }
716
717
718 # Set sensible defaults if not supplied
719
720 if(exists($opt->{rootname})) {
721 unless(defined($opt->{rootname})) {
722 $opt->{rootname} = '';
723 }
724 }
725 else {
726 $opt->{rootname} = $DefRootName;
727 }
728
729 if($opt->{xmldecl} and $opt->{xmldecl} eq '1') {
730 $opt->{xmldecl} = $DefXmlDecl;
731 }
732
733 if(exists($opt->{contentkey})) {
734 if($opt->{contentkey} =~ m{^-(.*)$}) {
735 $opt->{contentkey} = $1;
736 $opt->{collapseagain} = 1;
737 }
738 }
739 else {
740 $opt->{contentkey} = $DefContentKey;
741 }
742
743 unless(exists($opt->{normalisespace})) {
744 $opt->{normalisespace} = $opt->{normalizespace};
745 }
746 $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));
747
748 # Cleanups for values assumed to be arrays later
749
750 if($opt->{searchpath}) {
751 unless(ref($opt->{searchpath})) {
752 $opt->{searchpath} = [ $opt->{searchpath} ];
753 }
754 }
755 else {
756 $opt->{searchpath} = [ ];
757 }
758
759 if($opt->{cache} and !ref($opt->{cache})) {
760 $opt->{cache} = [ $opt->{cache} ];
761 }
762 if($opt->{cache}) {
763 $_ = lc($_) foreach (@{$opt->{cache}});
764 foreach my $scheme (@{$opt->{cache}}) {
765 my $method = 'cache_read_' . $scheme;
766 croak "Unsupported caching scheme: $scheme"
767 unless($self->can($method));
768 }
769 }
770
771 if(exists($opt->{parseropts})) {
772 if($^W) {
773 carp "Warning: " .
774 "'ParserOpts' is deprecated, contact the author if you need it";
775 }
776 }
777 else {
778 $opt->{parseropts} = [ ];
779 }
780
781
782 # Special cleanup for {forcearray} which could be regex, arrayref or boolean
783 # or left to default to 0
784
785 if(exists($opt->{forcearray})) {
786 if(ref($opt->{forcearray}) eq 'Regexp') {
787 $opt->{forcearray} = [ $opt->{forcearray} ];
788 }
789
790 if(ref($opt->{forcearray}) eq 'ARRAY') {
791 my @force_list = @{$opt->{forcearray}};
792 if(@force_list) {
793 $opt->{forcearray} = {};
794 foreach my $tag (@force_list) {
795 if(ref($tag) eq 'Regexp') {
796 push @{$opt->{forcearray}->{_regex}}, $tag;
797 }
798 else {
799 $opt->{forcearray}->{$tag} = 1;
800 }
801 }
802 }
803 else {
804 $opt->{forcearray} = 0;
805 }
806 }
807 else {
808 $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
809 }
810 }
811 else {
812 if($StrictMode and $dirn eq 'in') {
813 croak "No value specified for 'ForceArray' option in call to XML$dirn()";
814 }
815 $opt->{forcearray} = 0;
816 }
817
818
819 # Special cleanup for {keyattr} which could be arrayref or hashref or left
820 # to default to arrayref
821
822 if(exists($opt->{keyattr})) {
823 if(ref($opt->{keyattr})) {
824 if(ref($opt->{keyattr}) eq 'HASH') {
825
826 # Make a copy so we can mess with it
827
828 $opt->{keyattr} = { %{$opt->{keyattr}} };
829
830
831 # Convert keyattr => { elem => '+attr' }
832 # to keyattr => { elem => [ 'attr', '+' ] }
833
834 foreach my $el (keys(%{$opt->{keyattr}})) {
835 if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {
836 $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];
837 if($StrictMode and $dirn eq 'in') {
838 next if($opt->{forcearray} == 1);
839 next if(ref($opt->{forcearray}) eq 'HASH'
840 and $opt->{forcearray}->{$el});
841 croak "<$el> set in KeyAttr but not in ForceArray";
842 }
843 }
844 else {
845 delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)
846 }
847 }
848 }
849 else {
850 if(@{$opt->{keyattr}} == 0) {
851 delete($opt->{keyattr});
852 }
853 }
854 }
855 else {
856 $opt->{keyattr} = [ $opt->{keyattr} ];
857 }
858 }
859 else {
860 if($StrictMode) {
861 croak "No value specified for 'KeyAttr' option in call to XML$dirn()";
862 }
863 $opt->{keyattr} = [ @DefKeyAttr ];
864 }
865
866
867 # Special cleanup for {valueattr} which could be arrayref or hashref
868
869 if(exists($opt->{valueattr})) {
870 if(ref($opt->{valueattr}) eq 'ARRAY') {
871 $opt->{valueattrlist} = {};
872 $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });
873 }
874 }
875
876 # make sure there's nothing weird in {grouptags}
877
878 if($opt->{grouptags}) {
879 croak "Illegal value for 'GroupTags' option - expected a hashref"
880 unless UNIVERSAL::isa($opt->{grouptags}, 'HASH');
881
882 while(my($key, $val) = each %{$opt->{grouptags}}) {
883 next if $key ne $val;
884 croak "Bad value in GroupTags: '$key' => '$val'";
885 }
886 }
887
888
889 # Check the {variables} option is valid and initialise variables hash
890
891 if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
892 croak "Illegal value for 'Variables' option - expected a hashref";
893 }
894
895 if($opt->{variables}) {
896 $self->{_var_values} = { %{$opt->{variables}} };
897 }
898 elsif($opt->{varattr}) {
899 $self->{_var_values} = {};
900 }
901
902}
903
904
905##############################################################################
906# Method: find_xml_file()
907#
908# Helper routine for XMLin().
909# Takes a filename, and a list of directories, attempts to locate the file in
910# the directories listed.
911# Returns a full pathname on success; croaks on failure.
912#
913
914sub find_xml_file {
915 my $self = shift;
916 my $file = shift;
917 my @search_path = @_;
918
919
920 require File::Basename;
921 require File::Spec;
922
923 my($filename, $filedir) = File::Basename::fileparse($file);
924
925 if($filename ne $file) { # Ignore searchpath if dir component
926 return($file) if(-e $file);
927 }
928 else {
929 my($path);
930 foreach $path (@search_path) {
931 my $fullpath = File::Spec->catfile($path, $file);
932 return($fullpath) if(-e $fullpath);
933 }
934 }
935
936 # If user did not supply a search path, default to current directory
937
938 if(!@search_path) {
939 return($file) if(-e $file);
940 croak "File does not exist: $file";
941 }
942
943 croak "Could not find $file in ", join(':', @search_path);
944}
945
946
947##############################################################################
948# Method: collapse()
949#
950# Helper routine for XMLin(). This routine really comprises the 'smarts' (or
951# value add) of this module.
952#
953# Takes the parse tree that XML::Parser produced from the supplied XML and
954# recurses through it 'collapsing' unnecessary levels of indirection (nested
955# arrays etc) to produce a data structure that is easier to work with.
956#
957# Elements in the original parser tree are represented as an element name
958# followed by an arrayref. The first element of the array is a hashref
959# containing the attributes. The rest of the array contains a list of any
960# nested elements as name+arrayref pairs:
961#
962# <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ]
963#
964# The special element name '0' (zero) flags text content.
965#
966# This routine cuts down the noise by discarding any text content consisting of
967# only whitespace and then moves the nested elements into the attribute hash
968# using the name of the nested element as the hash key and the collapsed
969# version of the nested element as the value. Multiple nested elements with
970# the same name will initially be represented as an arrayref, but this may be
971# 'folded' into a hashref depending on the value of the keyattr option.
972#
973
974sub collapse {
975 my $self = shift;
976
977
978 # Start with the hash of attributes
979
980 my $attr = shift;
981 if($self->{opt}->{noattr}) { # Discard if 'noattr' set
982 $attr = {};
983 }
984 elsif($self->{opt}->{normalisespace} == 2) {
985 while(my($key, $value) = each %$attr) {
986 $attr->{$key} = $self->normalise_space($value)
987 }
988 }
989
990
991 # Do variable substitutions
992
993 if(my $var = $self->{_var_values}) {
994 while(my($key, $val) = each(%$attr)) {
995 $val =~ s{\$\{([\w.]+)\}}{ $self->get_var($1) }ge;
996 $attr->{$key} = $val;
997 }
998 }
999
1000
1001 # Roll up 'value' attributes (but only if no nested elements)
1002
1003 if(!@_ and keys %$attr == 1) {
1004 my($k) = keys %$attr;
1005 if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) {
1006 return $attr->{$k};
1007 }
1008 }
1009
1010
1011 # Add any nested elements
1012
1013 my($key, $val);
1014 while(@_) {
1015 $key = shift;
1016 $val = shift;
1017
1018 if(ref($val)) {
1019 $val = $self->collapse(@$val);
1020 next if(!defined($val) and $self->{opt}->{suppressempty});
1021 }
1022 elsif($key eq '0') {
1023 next if($val =~ m{^\s*$}s); # Skip all whitespace content
1024
1025 $val = $self->normalise_space($val)
1026 if($self->{opt}->{normalisespace} == 2);
1027
1028 # do variable substitutions
1029
1030 if(my $var = $self->{_var_values}) {
1031 $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;
1032 }
1033
1034
1035 # look for variable definitions
1036
1037 if(my $var = $self->{opt}->{varattr}) {
1038 if(exists $attr->{$var}) {
1039 $self->set_var($attr->{$var}, $val);
1040 }
1041 }
1042
1043
1044 # Collapse text content in element with no attributes to a string
1045
1046 if(!%$attr and !@_) {
1047 return($self->{opt}->{forcecontent} ?
1048 { $self->{opt}->{contentkey} => $val } : $val
1049 );
1050 }
1051 $key = $self->{opt}->{contentkey};
1052 }
1053
1054
1055 # Combine duplicate attributes into arrayref if required
1056
1057 if(exists($attr->{$key})) {
1058 if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
1059 push(@{$attr->{$key}}, $val);
1060 }
1061 else {
1062 $attr->{$key} = [ $attr->{$key}, $val ];
1063 }
1064 }
1065 elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
1066 $attr->{$key} = [ $val ];
1067 }
1068 else {
1069 if( $key ne $self->{opt}->{contentkey}
1070 and (
1071 ($self->{opt}->{forcearray} == 1)
1072 or (
1073 (ref($self->{opt}->{forcearray}) eq 'HASH')
1074 and (
1075 $self->{opt}->{forcearray}->{$key}
1076 or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})
1077 )
1078 )
1079 )
1080 ) {
1081 $attr->{$key} = [ $val ];
1082 }
1083 else {
1084 $attr->{$key} = $val;
1085 }
1086 }
1087
1088 }
1089
1090
1091 # Turn arrayrefs into hashrefs if key fields present
1092
1093 if($self->{opt}->{keyattr}) {
1094 while(($key,$val) = each %$attr) {
1095 if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) {
1096 $attr->{$key} = $self->array_to_hash($key, $val);
1097 }
1098 }
1099 }
1100
1101
1102 # disintermediate grouped tags
1103
1104 if($self->{opt}->{grouptags}) {
1105 while(my($key, $val) = each(%$attr)) {
1106 next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
1107 next unless(exists($self->{opt}->{grouptags}->{$key}));
1108
1109 my($child_key, $child_val) = %$val;
1110
1111 if($self->{opt}->{grouptags}->{$key} eq $child_key) {
1112 $attr->{$key}= $child_val;
1113 }
1114 }
1115 }
1116
1117
1118 # Fold hashes containing a single anonymous array up into just the array
1119
1120 my $count = scalar keys %$attr;
1121 if($count == 1
1122 and exists $attr->{anon}
1123 and UNIVERSAL::isa($attr->{anon}, 'ARRAY')
1124 ) {
1125 return($attr->{anon});
1126 }
1127
1128
1129 # Do the right thing if hash is empty, otherwise just return it
1130
1131 if(!%$attr and exists($self->{opt}->{suppressempty})) {
1132 if(defined($self->{opt}->{suppressempty}) and
1133 $self->{opt}->{suppressempty} eq '') {
1134 return('');
1135 }
1136 return(undef);
1137 }
1138
1139
1140 # Roll up named elements with named nested 'value' attributes
1141
1142 if($self->{opt}->{valueattr}) {
1143 while(my($key, $val) = each(%$attr)) {
1144 next unless($self->{opt}->{valueattr}->{$key});
1145 next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
1146 my($k) = keys %$val;
1147 next unless($k eq $self->{opt}->{valueattr}->{$key});
1148 $attr->{$key} = $val->{$k};
1149 }
1150 }
1151
1152 return($attr)
1153
1154}
1155
1156
1157##############################################################################
1158# Method: set_var()
1159#
1160# Called when a variable definition is encountered in the XML. (A variable
1161# definition looks like <element attrname="name">value</element> where attrname
1162# matches the varattr setting).
1163#
1164
1165sub set_var {
1166 my($self, $name, $value) = @_;
1167
1168 $self->{_var_values}->{$name} = $value;
1169}
1170
1171
1172##############################################################################
1173# Method: get_var()
1174#
1175# Called during variable substitution to get the value for the named variable.
1176#
1177
1178sub get_var {
1179 my($self, $name) = @_;
1180
1181 my $value = $self->{_var_values}->{$name};
1182 return $value if(defined($value));
1183
1184 return '${' . $name . '}';
1185}
1186
1187
1188##############################################################################
1189# Method: normalise_space()
1190#
1191# Strips leading and trailing whitespace and collapses sequences of whitespace
1192# characters to a single space.
1193#
1194
1195sub normalise_space {
1196 my($self, $text) = @_;
1197
1198 $text =~ s/^\s+//s;
1199 $text =~ s/\s+$//s;
1200 $text =~ s/\s\s+/ /sg;
1201
1202 return $text;
1203}
1204
1205
1206##############################################################################
1207# Method: array_to_hash()
1208#
1209# Helper routine for collapse().
1210# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a
1211# reference to the hash on success or the original array if folding is
1212# not possible. Behaviour is controlled by 'keyattr' option.
1213#
1214
1215sub array_to_hash {
1216 my $self = shift;
1217 my $name = shift;
1218 my $arrayref = shift;
1219
1220 my $hashref = $self->new_hashref;
1221
1222 my($i, $key, $val, $flag);
1223
1224
1225 # Handle keyattr => { .... }
1226
1227 if(ref($self->{opt}->{keyattr}) eq 'HASH') {
1228 return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
1229 ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}};
1230 for($i = 0; $i < @$arrayref; $i++) {
1231 if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and
1232 exists($arrayref->[$i]->{$key})
1233 ) {
1234 $val = $arrayref->[$i]->{$key};
1235 if(ref($val)) {
1236 $self->die_or_warn("<$name> element has non-scalar '$key' key attribute");
1237 return($arrayref);
1238 }
1239 $val = $self->normalise_space($val)
1240 if($self->{opt}->{normalisespace} == 1);
1241 $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
1242 if(exists($hashref->{$val}));
1243 $hashref->{$val} = { %{$arrayref->[$i]} };
1244 $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');
1245 delete $hashref->{$val}->{$key} unless($flag eq '+');
1246 }
1247 else {
1248 $self->die_or_warn("<$name> element has no '$key' key attribute");
1249 return($arrayref);
1250 }
1251 }
1252 }
1253
1254
1255 # Or assume keyattr => [ .... ]
1256
1257 else {
1258 my $default_keys =
1259 join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}});
1260
1261 ELEMENT: for($i = 0; $i < @$arrayref; $i++) {
1262 return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));
1263
1264 foreach $key (@{$self->{opt}->{keyattr}}) {
1265 if(defined($arrayref->[$i]->{$key})) {
1266 $val = $arrayref->[$i]->{$key};
1267 if(ref($val)) {
1268 $self->die_or_warn("<$name> element has non-scalar '$key' key attribute")
1269 if not $default_keys;
1270 return($arrayref);
1271 }
1272 $val = $self->normalise_space($val)
1273 if($self->{opt}->{normalisespace} == 1);
1274 $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
1275 if(exists($hashref->{$val}));
1276 $hashref->{$val} = { %{$arrayref->[$i]} };
1277 delete $hashref->{$val}->{$key};
1278 next ELEMENT;
1279 }
1280 }
1281
1282 return($arrayref); # No keyfield matched
1283 }
1284 }
1285
1286 # collapse any hashes which now only have a 'content' key
1287
1288 if($self->{opt}->{collapseagain}) {
1289 $hashref = $self->collapse_content($hashref);
1290 }
1291
1292 return($hashref);
1293}
1294
1295
1296##############################################################################
1297# Method: die_or_warn()
1298#
1299# Takes a diagnostic message and does one of three things:
1300# 1. dies if strict mode is enabled
1301# 2. warns if warnings are enabled but strict mode is not
1302# 3. ignores message and resturns silently if neither strict mode nor warnings
1303# are enabled
1304#
1305
1306sub die_or_warn {
1307 my $self = shift;
1308 my $msg = shift;
1309
1310 croak $msg if($StrictMode);
1311 carp "Warning: $msg" if($^W);
1312}
1313
1314
1315##############################################################################
1316# Method: new_hashref()
1317#
1318# This is a hook routine for overriding in a sub-class. Some people believe
1319# that using Tie::IxHash here will solve order-loss problems.
1320#
1321
1322sub new_hashref {
1323 my $self = shift;
1324
1325 return { @_ };
1326}
1327
1328
1329##############################################################################
1330# Method: collapse_content()
1331#
1332# Helper routine for array_to_hash
1333#
1334# Arguments expected are:
1335# - an XML::Simple object
1336# - a hasref
1337# the hashref is a former array, turned into a hash by array_to_hash because
1338# of the presence of key attributes
1339# at this point collapse_content avoids over-complicated structures like
1340# dir => { libexecdir => { content => '$exec_prefix/libexec' },
1341# localstatedir => { content => '$prefix' },
1342# }
1343# into
1344# dir => { libexecdir => '$exec_prefix/libexec',
1345# localstatedir => '$prefix',
1346# }
1347
1348sub collapse_content {
1349 my $self = shift;
1350 my $hashref = shift;
1351
1352 my $contentkey = $self->{opt}->{contentkey};
1353
1354 # first go through the values,checking that they are fit to collapse
1355 foreach my $val (values %$hashref) {
1356 return $hashref unless ( (ref($val) eq 'HASH')
1357 and (keys %$val == 1)
1358 and (exists $val->{$contentkey})
1359 );
1360 }
1361
1362 # now collapse them
1363 foreach my $key (keys %$hashref) {
1364 $hashref->{$key}= $hashref->{$key}->{$contentkey};
1365 }
1366
1367 return $hashref;
1368}
1369
1370
1371##############################################################################
1372# Method: value_to_xml()
1373#
1374# Helper routine for XMLout() - recurses through a data structure building up
1375# and returning an XML representation of that structure as a string.
1376#
1377# Arguments expected are:
1378# - the data structure to be encoded (usually a reference)
1379# - the XML tag name to use for this item
1380# - a string of spaces for use as the current indent level
1381#
1382
1383sub value_to_xml {
1384 my $self = shift;;
1385
1386
1387 # Grab the other arguments
1388
1389 my($ref, $name, $indent) = @_;
1390
1391 my $named = (defined($name) and $name ne '' ? 1 : 0);
1392
1393 my $nl = "\n";
1394
1395 my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack!
1396 if($self->{opt}->{noindent}) {
1397 $indent = '';
1398 $nl = '';
1399 }
1400
1401
1402 # Convert to XML
1403
1404 if(ref($ref)) {
1405 croak "circular data structures not supported"
1406 if(grep($_ == $ref, @{$self->{_ancestors}}));
1407 push @{$self->{_ancestors}}, $ref;
1408 }
1409 else {
1410 if($named) {
1411 return(join('',
1412 $indent, '<', $name, '>',
1413 ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
1414 '</', $name, ">", $nl
1415 ));
1416 }
1417 else {
1418 return("$ref$nl");
1419 }
1420 }
1421
1422
1423 # Unfold hash to array if possible
1424
1425 if(UNIVERSAL::isa($ref, 'HASH') # It is a hash
1426 and keys %$ref # and it's not empty
1427 and $self->{opt}->{keyattr} # and folding is enabled
1428 and !$is_root # and its not the root element
1429 ) {
1430 $ref = $self->hash_to_array($name, $ref);
1431 }
1432
1433
1434 my @result = ();
1435 my($key, $value);
1436
1437
1438 # Handle hashrefs
1439
1440 if(UNIVERSAL::isa($ref, 'HASH')) {
1441
1442 # Reintermediate grouped values if applicable
1443
1444 if($self->{opt}->{grouptags}) {
1445 $ref = $self->copy_hash($ref);
1446 while(my($key, $val) = each %$ref) {
1447 if($self->{opt}->{grouptags}->{$key}) {
1448 $ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val };
1449 }
1450 }
1451 }
1452
1453
1454 # Scan for namespace declaration attributes
1455
1456 my $nsdecls = '';
1457 my $default_ns_uri;
1458 if($self->{nsup}) {
1459 $ref = $self->copy_hash($ref);
1460 $self->{nsup}->push_context();
1461
1462 # Look for default namespace declaration first
1463
1464 if(exists($ref->{xmlns})) {
1465 $self->{nsup}->declare_prefix('', $ref->{xmlns});
1466 $nsdecls .= qq( xmlns="$ref->{xmlns}");
1467 delete($ref->{xmlns});
1468 }
1469 $default_ns_uri = $self->{nsup}->get_uri('');
1470
1471
1472 # Then check all the other keys
1473
1474 foreach my $qname (keys(%$ref)) {
1475 my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
1476 if($uri) {
1477 if($uri eq $xmlns_ns) {
1478 $self->{nsup}->declare_prefix($lname, $ref->{$qname});
1479 $nsdecls .= qq( xmlns:$lname="$ref->{$qname}");
1480 delete($ref->{$qname});
1481 }
1482 }
1483 }
1484
1485 # Translate any remaining Clarkian names
1486
1487 foreach my $qname (keys(%$ref)) {
1488 my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
1489 if($uri) {
1490 if($default_ns_uri and $uri eq $default_ns_uri) {
1491 $ref->{$lname} = $ref->{$qname};
1492 delete($ref->{$qname});
1493 }
1494 else {
1495 my $prefix = $self->{nsup}->get_prefix($uri);
1496 unless($prefix) {
1497 # $self->{nsup}->declare_prefix(undef, $uri);
1498 # $prefix = $self->{nsup}->get_prefix($uri);
1499 $prefix = $self->{ns_prefix}++;
1500 $self->{nsup}->declare_prefix($prefix, $uri);
1501 $nsdecls .= qq( xmlns:$prefix="$uri");
1502 }
1503 $ref->{"$prefix:$lname"} = $ref->{$qname};
1504 delete($ref->{$qname});
1505 }
1506 }
1507 }
1508 }
1509
1510
1511 my @nested = ();
1512 my $text_content = undef;
1513 if($named) {
1514 push @result, $indent, '<', $name, $nsdecls;
1515 }
1516
1517 if(keys %$ref) {
1518 my $first_arg = 1;
1519 foreach my $key ($self->sorted_keys($name, $ref)) {
1520 my $value = $ref->{$key};
1521 next if(substr($key, 0, 1) eq '-');
1522 if(!defined($value)) {
1523 next if $self->{opt}->{suppressempty};
1524 unless(exists($self->{opt}->{suppressempty})
1525 and !defined($self->{opt}->{suppressempty})
1526 ) {
1527 carp 'Use of uninitialized value' if($^W);
1528 }
1529 if($key eq $self->{opt}->{contentkey}) {
1530 $text_content = '';
1531 }
1532 else {
1533 $value = exists($self->{opt}->{suppressempty}) ? {} : '';
1534 }
1535 }
1536
1537 if(!ref($value)
1538 and $self->{opt}->{valueattr}
1539 and $self->{opt}->{valueattr}->{$key}
1540 ) {
1541 $value = { $self->{opt}->{valueattr}->{$key} => $value };
1542 }
1543
1544 if(ref($value) or $self->{opt}->{noattr}) {
1545 push @nested,
1546 $self->value_to_xml($value, $key, "$indent ");
1547 }
1548 else {
1549 $value = $self->escape_value($value) unless($self->{opt}->{noescape});
1550 if($key eq $self->{opt}->{contentkey}) {
1551 $text_content = $value;
1552 }
1553 else {
1554 push @result, "\n$indent " . ' ' x length($name)
1555 if($self->{opt}->{attrindent} and !$first_arg);
1556 push @result, ' ', $key, '="', $value , '"';
1557 $first_arg = 0;
1558 }
1559 }
1560 }
1561 }
1562 else {
1563 $text_content = '';
1564 }
1565
1566 if(@nested or defined($text_content)) {
1567 if($named) {
1568 push @result, ">";
1569 if(defined($text_content)) {
1570 push @result, $text_content;
1571 $nested[0] =~ s/^\s+// if(@nested);
1572 }
1573 else {
1574 push @result, $nl;
1575 }
1576 if(@nested) {
1577 push @result, @nested, $indent;
1578 }
1579 push @result, '</', $name, ">", $nl;
1580 }
1581 else {
1582 push @result, @nested; # Special case if no root elements
1583 }
1584 }
1585 else {
1586 push @result, " />", $nl;
1587 }
1588 $self->{nsup}->pop_context() if($self->{nsup});
1589 }
1590
1591
1592 # Handle arrayrefs
1593
1594 elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
1595 foreach $value (@$ref) {
1596 next if !defined($value) and $self->{opt}->{suppressempty};
1597 if(!ref($value)) {
1598 push @result,
1599 $indent, '<', $name, '>',
1600 ($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
1601 '</', $name, ">$nl";
1602 }
1603 elsif(UNIVERSAL::isa($value, 'HASH')) {
1604 push @result, $self->value_to_xml($value, $name, $indent);
1605 }
1606 else {
1607 push @result,
1608 $indent, '<', $name, ">$nl",
1609 $self->value_to_xml($value, 'anon', "$indent "),
1610 $indent, '</', $name, ">$nl";
1611 }
1612 }
1613 }
1614
1615 else {
1616 croak "Can't encode a value of type: " . ref($ref);
1617 }
1618
1619
1620 pop @{$self->{_ancestors}} if(ref($ref));
1621
1622 return(join('', @result));
1623}
1624
1625
1626##############################################################################
1627# Method: sorted_keys()
1628#
1629# Returns the keys of the referenced hash sorted into alphabetical order, but
1630# with the 'key' key (as in KeyAttr) first, if there is one.
1631#
1632
1633sub sorted_keys {
1634 my($self, $name, $ref) = @_;
1635
1636 return keys %$ref if $self->{opt}->{nosort};
1637
1638 my %hash = %$ref;
1639 my $keyattr = $self->{opt}->{keyattr};
1640
1641 my @key;
1642
1643 if(ref $keyattr eq 'HASH') {
1644 if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) {
1645 push @key, $keyattr->{$name}->[0];
1646 delete $hash{$keyattr->{$name}->[0]};
1647 }
1648 }
1649 elsif(ref $keyattr eq 'ARRAY') {
1650 foreach (@{$keyattr}) {
1651 if(exists $hash{$_}) {
1652 push @key, $_;
1653 delete $hash{$_};
1654 last;
1655 }
1656 }
1657 }
1658
1659 return(@key, sort keys %hash);
1660}
1661
1662##############################################################################
1663# Method: escape_value()
1664#
1665# Helper routine for automatically escaping values for XMLout().
1666# Expects a scalar data value. Returns escaped version.
1667#
1668
1669sub escape_value {
1670 my($self, $data) = @_;
1671
1672 return '' unless(defined($data));
1673
1674 $data =~ s/&/&amp;/sg;
1675 $data =~ s/</&lt;/sg;
1676 $data =~ s/>/&gt;/sg;
1677 $data =~ s/"/&quot;/sg;
1678
1679 my $level = $self->{opt}->{numericescape} or return $data;
1680
1681 return $self->numeric_escape($data, $level);
1682}
1683
1684sub numeric_escape {
1685 my($self, $data, $level) = @_;
1686
16873894µs246µs
# spent 37µs (29+9) within XML::Simple::BEGIN@1687 which was called: # once (29µs+9µs) by C4::Context::BEGIN@103 at line 1687
use utf8; # required for 5.6
# spent 37µs making 1 call to XML::Simple::BEGIN@1687 # spent 9µs making 1 call to utf8::import
1688
1689 if($self->{opt}->{numericescape} eq '2') {
1690 $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse;
1691 }
1692 else {
1693 $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse;
1694 }
1695
1696 return $data;
1697}
1698
1699
1700##############################################################################
1701# Method: hash_to_array()
1702#
1703# Helper routine for value_to_xml().
1704# Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a
1705# reference to the array on success or the original hash if unfolding is
1706# not possible.
1707#
1708
1709sub hash_to_array {
1710 my $self = shift;
1711 my $parent = shift;
1712 my $hashref = shift;
1713
1714 my $arrayref = [];
1715
1716 my($key, $value);
1717
1718 my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref;
1719 foreach $key (@keys) {
1720 $value = $hashref->{$key};
1721 return($hashref) unless(UNIVERSAL::isa($value, 'HASH'));
1722
1723 if(ref($self->{opt}->{keyattr}) eq 'HASH') {
1724 return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent}));
1725 push @$arrayref, $self->copy_hash(
1726 $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key
1727 );
1728 }
1729 else {
1730 push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
1731 }
1732 }
1733
1734 return($arrayref);
1735}
1736
1737
1738##############################################################################
1739# Method: copy_hash()
1740#
1741# Helper routine for hash_to_array(). When unfolding a hash of hashes into
1742# an array of hashes, we need to copy the key from the outer hash into the
1743# inner hash. This routine makes a copy of the original hash so we don't
1744# destroy the original data structure. You might wish to override this
1745# method if you're using tied hashes and don't want them to get untied.
1746#
1747
1748sub copy_hash {
1749 my($self, $orig, @extra) = @_;
1750
1751 return { @extra, %$orig };
1752}
1753
1754##############################################################################
1755# Methods required for building trees from SAX events
1756##############################################################################
1757
1758sub start_document {
1759 my $self = shift;
1760
1761 $self->handle_options('in') unless($self->{opt});
1762
1763 $self->{lists} = [];
1764 $self->{curlist} = $self->{tree} = [];
1765}
1766
1767
1768sub start_element {
1769 my $self = shift;
1770 my $element = shift;
1771
1772 my $name = $element->{Name};
1773 if($self->{opt}->{nsexpand}) {
1774 $name = $element->{LocalName} || '';
1775 if($element->{NamespaceURI}) {
1776 $name = '{' . $element->{NamespaceURI} . '}' . $name;
1777 }
1778 }
1779 my $attributes = {};
1780 if($element->{Attributes}) { # Might be undef
1781 foreach my $attr (values %{$element->{Attributes}}) {
1782 if($self->{opt}->{nsexpand}) {
1783 my $name = $attr->{LocalName} || '';
1784 if($attr->{NamespaceURI}) {
1785 $name = '{' . $attr->{NamespaceURI} . '}' . $name
1786 }
1787 $name = 'xmlns' if($name eq $bad_def_ns_jcn);
1788 $attributes->{$name} = $attr->{Value};
1789 }
1790 else {
1791 $attributes->{$attr->{Name}} = $attr->{Value};
1792 }
1793 }
1794 }
1795 my $newlist = [ $attributes ];
1796 push @{ $self->{lists} }, $self->{curlist};
1797 push @{ $self->{curlist} }, $name => $newlist;
1798 $self->{curlist} = $newlist;
1799}
1800
1801
1802sub characters {
1803 my $self = shift;
1804 my $chars = shift;
1805
1806 my $text = $chars->{Data};
1807 my $clist = $self->{curlist};
1808 my $pos = $#$clist;
1809
1810 if ($pos > 0 and $clist->[$pos - 1] eq '0') {
1811 $clist->[$pos] .= $text;
1812 }
1813 else {
1814 push @$clist, 0 => $text;
1815 }
1816}
1817
1818
1819sub end_element {
1820 my $self = shift;
1821
1822 $self->{curlist} = pop @{ $self->{lists} };
1823}
1824
1825
1826sub end_document {
1827 my $self = shift;
1828
1829 delete($self->{curlist});
1830 delete($self->{lists});
1831
1832 my $tree = $self->{tree};
1833 delete($self->{tree});
1834
1835
1836 # Return tree as-is to XMLin()
1837
1838 return($tree) if($self->{nocollapse});
1839
1840
1841 # Or collapse it before returning it to SAX parser class
1842
1843 if($self->{opt}->{keeproot}) {
1844 $tree = $self->collapse({}, @$tree);
1845 }
1846 else {
1847 $tree = $self->collapse(@{$tree->[1]});
1848 }
1849
1850 if($self->{opt}->{datahandler}) {
1851 return($self->{opt}->{datahandler}->($self, $tree));
1852 }
1853
1854 return($tree);
1855}
1856
185713µs*xml_in = \&XMLin;
18581700ns*xml_out = \&XMLout;
1859
1860119µs1;
1861
1862__END__
 
# spent 10µs within XML::Simple::CORE:match which was called 6 times, avg 2µs/call: # 3 times (7µs+0s) by XML::Simple::import at line 95, avg 2µs/call # 3 times (3µs+0s) by XML::Simple::import at line 99, avg 900ns/call
sub XML::Simple::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.