From bb0e2113705fd7f25353765a18fb3a752d6fae8f Mon Sep 17 00:00:00 2001 From: Anas Nashif Date: Thu, 27 Dec 2012 19:04:28 -0800 Subject: [PATCH] Imported Upstream version 2.18 --- Changes | 266 ++++ MANIFEST | 26 + META.yml | 13 + Makefile.PL | 94 ++ README | 76 ++ lib/XML/Simple.pm | 3284 ++++++++++++++++++++++++++++++++++++++++++++++++ lib/XML/Simple/FAQ.pod | 646 ++++++++++ maketest | 92 ++ t/0_Config.t | 64 + t/1_XMLin.t | 1509 ++++++++++++++++++++++ t/1_XMLin.xml | 1 + t/2_XMLout.t | 1214 ++++++++++++++++++ t/3_Storable.t | 238 ++++ t/4_MemShare.t | 154 +++ t/5_MemCopy.t | 162 +++ t/6_ObjIntf.t | 383 ++++++ t/7_SaxStuff.t | 282 +++++ t/8_Namespaces.t | 230 ++++ t/9_Strict.t | 341 +++++ t/A_XMLParser.t | 128 ++ t/B_Hooks.t | 136 ++ t/desertnet.src | 13 + t/lib/TagsToUpper.pm | 38 + t/srt.xml | 72 ++ t/subdir/test2.xml | 1 + t/test1.xml | 1 + 26 files changed, 9464 insertions(+) create mode 100644 Changes create mode 100644 MANIFEST create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/XML/Simple.pm create mode 100644 lib/XML/Simple/FAQ.pod create mode 100644 maketest create mode 100644 t/0_Config.t create mode 100644 t/1_XMLin.t create mode 100644 t/1_XMLin.xml create mode 100644 t/2_XMLout.t create mode 100644 t/3_Storable.t create mode 100644 t/4_MemShare.t create mode 100644 t/5_MemCopy.t create mode 100644 t/6_ObjIntf.t create mode 100644 t/7_SaxStuff.t create mode 100644 t/8_Namespaces.t create mode 100644 t/9_Strict.t create mode 100644 t/A_XMLParser.t create mode 100644 t/B_Hooks.t create mode 100644 t/desertnet.src create mode 100755 t/lib/TagsToUpper.pm create mode 100644 t/srt.xml create mode 100644 t/subdir/test2.xml create mode 100644 t/test1.xml diff --git a/Changes b/Changes new file mode 100644 index 0000000..2632e51 --- /dev/null +++ b/Changes @@ -0,0 +1,266 @@ +Revision history for Perl module XML::Simple + +2.18 Aug 15 2007 + - Non-unique key attribute values now trigger a warning (or a fatal + error in strict mode) rather than silently discarding data (patch + from Daniel Baysinger) + +2.17 Aug 02 2007 + - Added parse_string(), parse_file() and parse_fh() methods + - Added default_config_file(), and build_simple_tree() hook methods + - Tweak to implementation of exporting (patch from Stuart Moore) + - Documented hook methods + - Fixed test suite race condition (RT#28603 from Andreas J. König) + +2.16 Oct 30 2006 + - Added test/fix for bad GroupTags option (report from Lee Goddard) + - Added new_hashref() hook method + - refactored cache save/restore methods for easier overriding + +2.15 Oct 03 2006 + - Makefile.PL changes: reject known-bad PurePerl and RTF parser modules; + default to XML::SAX::Expat if no parser installed + - allow '.' characters in variable names (suggested by Cosimo Streppone) + - fix output of undefs in arrayrefs with SuppressEmpty (reported by + かんな - Kanna) + - tidy up code and docs around lexical filehandle passed to OutputFile + (report from Helge Sauer) + - reduce memory usage by passing XML strings by reference (patch from + Dan Sully) + +2.14 Jan 29 2005 + - unlink and lock fixes for VMS (patch from Peter (Stig) Edwards) + +2.13 Nov 17 2004 + - Fixed bug where NoIndent broke KeyAttr (reported by David Haas) + - Added copy_hash helper method which may be overridden to avoid + tied hashes becoming untied during XMLout (patch from Jan Sundberg) + - Fixed bug where GroupTags corrupted source hashref in XMLout + (reported by Bram) + - Tweaks to SuppressEmpty for undef with XMLout (report from jamesb), + behaviour now matches docs and additional behaviour of setting + option to 1 will skip undefined values altogether + +2.12 Apr 05 2004 + - added NumericEscape option + - added ValueAttr option (patch from Anton Berezin) + - suppress 'wide character in print' warning (reported by Dawei Lin) + +2.11 Mar 02 2004 + - Fixed hash ordering assumption in a new test (reported by Jost Krieger) + +2.10 Feb 29 2004 + - Added AttrIndent option (patch from Volker Moell) + - Hash keys are now sorted alphabetically by default; enable the + new NoSort option if you don't want this (patch from Volker Moell) + - Fixed bug where disabling array folding broke anonymous array handling + - Fixed bug when unfolding a tied hash + - SuppressEmpty patch from Douglas Wilson + - Numerous test improvements - Devel::Cover rocks! + - POD update re XMLin(XMLout($data)) caveats (bug report from Slaven + Rezic) + +2.09 Sep 09 2003 + - Makefile.PL makeover contributed by Joshua Keroes + - fixed hash ordering assumption in test script (reported by Michel + Rodriguez) + - POD updates + - updated link to Perl XML FAQ + +2.08 Jun 13 2003 + - fixed variable expansion not happening in attributes (patch from Paul + Bussé) + +2.07 May 20 2003 + - added test to catch old versions of Storable which lack locking support + - removed new-style loop which broke on 5.005_03 + - suppress more uninitialised variable warnings + +2.06 May 18 2003 + - fixed strict mode requiring ForceArray on output (fix from Igor Román + Mariño) + - fixed warnings about uninitialised values + - minor POD update (link to FAQ) + +2.05 Apr 16 2003 + - fixed warnings when NormaliseSpace undefined (reported by Peter + Scott and others) + - added support for specifying ForceArray using regular expressions + (patch from Jim Cromie) + - added check to escape_value to guard against undefined argument + (reported by Henrik Gemal) + - added NoIndent option (requested by Afroze Husain Zubairi) + +2.04 Apr 10 2003 + - integrated a patch from Michel Rodriguez + + new facility for removing extra levels of indirection (using + the new 'GroupTags' option) + + new facility for rolling the dreaded 'content' hash up into a + scalar if there are no keys left after array folding (using the + '-' prefix mode on the ContentKey option) + + new facility for doing variable substitution in the XML; variables + can be defined in Perl (using the new 'Variables' option) or in + the XML document (using the new 'VarAttr' option) + - added 'NormaliseSpace' option for tidying up hash keys and other + text content if required (feature requested by Alex Manoussakis) + - option names are now case-insensitive and can include underscores + - XMLin() and XMLout() are now aliased to xml_in() and xml_out() when + called as methods or imported explicitly + - option names passed to XML::Simple->new() are now validated + +2.03 Jan 20 2003 + - fixed circular reference check which was incorrectly catching + 'parallel' references (patch from Theo Lengyel) + +2.02 Dec 15 2002 + - changed Storable calls to use locking (reported by Randal Schwarz) + +2.01 Dec 11 2002 + - fixed bug whereby :strict mode required forcearray on + XMLout() (reported by Ville Skytta) + +2.00 Dec 08 2002 + - first production release with SAX support + - added support for 'strict mode' using :strict import tag + - removed locking code (as it was incompatible with iThreads) + - integrated patch for test failures from Sean Campbell + - fixed stringification of references during folding (reported + by Trond Michelsen) + - fixed incompatability with Tie::IxHash (reported by + Venkataramana Mokkapati) + - POD: alphabetised options (patch from John Borwick) + - POD: updated suppressempty (patch from Kjetil Kjernsmo) + - added FAQ.pod to distribution and added new questions + +1.08_01 Feb 14 2002 - beta release for testing SAX support + - fixed errors with default namespace handling + - minor POD updates + +1.08 Feb 09 2002 + - re-release of 1.06 (stable) with minor updates ... + - searchpath option now defaults to current directory if not set + - fix to Storable test routine for test failures on Win32 + - removed obselete 'convert' script from distribution + +1.07b Feb 05 2002 - beta release for testing SAX support + - added SAX support including: + + using SAX parsers + + acting as a SAX handler + + generating SAX events from XMLout() with new Handler option + + acting as a SAX filter (via new DataHandler option) + - added $ENV{XML_SIMPLE_PREFERRED_PARSER} and + $XML::Simple::PREFERRED_PARSER for selecting a parser module + - added namespace support (SAX only) with nsexpand option for both + XMLin() and XMLout() + - searchpath now defaults to current directory + - parseropts option now officially deprecated + - removed obselete 'convert' script from distribution + - many POD updates (more to come) + +1.06 Nov 19 2001 + - fixed version number in default xmldecl (thanks to Matt Sergeant for + bug report and patch) + - updated contact email address for author + + +1.05 Aug 31 2000 + - code re-org to make internals all OO for easier extending + - added 'noattr' option to tell XMLout() not to use attributes (only + nested elements) and XMLin() to discard attributes + - added 'suppressempty' option to tell XMLin what to do with elements + with no attributes and no content + - added 'parseropts' option for specifying options which should be + passed to the underlying XML::Parser object + - added 'forcecontent' option to force text content to parse to a + hash value even if the element has no attributes + - fix for forcearray getting applied to text content + - integrated patch from Paul Lindner to work around filenames sometimes + being seen as XML when running under mod_perl + - integrated patch from Edward Avis: filename '-' means stdin + - fixed bug where a missing key attribute could cause a crash + - added a warning message for above situation + - added 'support' for CDATA sections - they always worked, but now + they're in the test suite which should ensure they keep working + - fixed error message when caching enabled but parsing from filehandle + - fixed empty elements being skipped by XMLout() when folding enabled + - fixed text content of '0' being skipped by XMLout() + +1.04 Apr 03 2000 + - fix for text content being skipped by XMLout + - added (optional) OO interface for changing default options + - added 'keeproot' option (requested by Mark D. Anderson - MDA) + - added 'contentkey' option (also requested by MDA) + - incorporated 'forcearray' as arrayref patch from Andrew McNaughton + +1.03 Mar 05 2000 + - added 'maketest' script for make impaired platforms + - yet more cross platform robustness added to test scripts incl + workaround for Win32 problem where writing to file changed contents + but not timestamp(!) + - backed out one overzealous use of File::Spec in test script + - POD updates including XML::Twig description contributed by Michel + Rodriguez + +1.02b Feb 16 2000 - limited distribution beta + - reinstated locking with new backwards compatibility code + - fixed platform dependant pathname handling to use File::Basename & + File::Spec in XML::Simple.pm and test scripts + - fixed bug causing XMLout() to incorrectly barf on what it thought was + a recursive data structure + - removed spurious checking code which stopped XMLout unfolding a + single nested hash + - fixed t/4_MemShare.t to gracefully cope with the absense of utime() + - changed t/3_Storable.t and t/5_MemCopy.t to skip gracefully if no + Storable.pm + - removed superflous eval blocks around requires + +1.01 Dec 1 1999 + - removed faulty locking code pending a fix + +1.00 Nov 25 1999 + - added escaping feature + noescape option + - added xmldecl option + - further tidy ups for thread safing + - more POD revisions (incl: pointers to other modules) + +0.95 Nov 2 1999 + - added rootname option + - added outputfile option + - lots of internal tidy ups for thread safing + - fixed bug in check for XML string to XMLin() + - extra tests (esp option handling) + +0.90 Oct 14 1999 (first beta release) + - module renamed to XML::Simple ready for CPAN upload + - XMLToOpt() renamed to XMLin() + - OptToXML() renamed to XMLout() + - added 'convert' script + +0.05 Sep 18 1999 + - fixed location of XML.pm in distribution (make install didn't work) + - added tests for MemCopy + - fixed ABSTRACT_FROM in Makefile.PL + - fixed PREREQ_PM in Makefile.PL + +0.04 Aug 10 1999 + - added caching using Storable.pm + - updated MANIFEST to include missing test files + +0.03 Jun 20 1999 + - rewrite of OptToXML + - anonymous array support + - more and better test routines + - POD updates + +0.02 Jun 10 1999 + - added support for OptToXML + - fixed searchpath inconsistencies + - added 'forcearray' option + - POD improvements + - much improved test routines + +0.01 May 27 1999 + - original version; created by h2xs 1.18 + - module called 'Getopt::XML' + - included basic XMLToOpt routine + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..b46b0db --- /dev/null +++ b/MANIFEST @@ -0,0 +1,26 @@ +Changes +lib/XML/Simple.pm +lib/XML/Simple/FAQ.pod +Makefile.PL +maketest +MANIFEST +META.yml Module meta-data (added by MakeMaker) +README +t/0_Config.t +t/1_XMLin.t +t/1_XMLin.xml +t/2_XMLout.t +t/3_Storable.t +t/4_MemShare.t +t/5_MemCopy.t +t/6_ObjIntf.t +t/7_SaxStuff.t +t/8_Namespaces.t +t/9_Strict.t +t/A_XMLParser.t +t/B_Hooks.t +t/desertnet.src +t/lib/TagsToUpper.pm +t/srt.xml +t/subdir/test2.xml +t/test1.xml diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..cac2231 --- /dev/null +++ b/META.yml @@ -0,0 +1,13 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: XML-Simple +version: 2.18 +version_from: lib/XML/Simple.pm +installdirs: site +requires: + Test::Simple: 0.41 + XML::NamespaceSupport: 1.04 + XML::SAX: 0 + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..9541df6 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,94 @@ +# $Id: Makefile.PL,v 1.8 2006/10/03 01:02:20 grantm Exp $ + +use ExtUtils::MakeMaker; + +BEGIN { + if($] < 5.006) { + warn + qq(This version of XML::Simple requires Perl version 5.6 or better.\n) . + qq(You might prefer to install an older version of XML::Simple\n\n) . + qq( perl -MCPAN -e "install 'G/GR/GRANTM/XML-Simple-1.08.tar.gz'"\n\n); + } +} + +require 5.006; + +my $make_params = { + 'NAME' => 'XML::Simple', + 'VERSION_FROM' => 'lib/XML/Simple.pm', + 'DISTNAME' => 'XML-Simple', + 'PREREQ_PM' => { + Test::Simple => 0.41, + }, + 'dist' => { COMPRESS => 'gzip --best', SUFFIX => 'gz' }, + 'AUTHOR' => 'Grant McLean ', + 'ABSTRACT_FROM' => 'lib/XML/Simple.pm', +}; + +print "Checking installed modules ...\n"; + +if ( eval { require XML::SAX } && ! $@ ) { + my $default_parser = ref(XML::SAX::ParserFactory->parser()); + if ($default_parser eq 'XML::SAX::PurePerl') { + my $version = XML::SAX->VERSION; + if($version > 0.12 and $version < 0.15) { + die <<"EOF"; +============================================================================= + + Fatal error: Your default XML parser (XML::SAX::PurePerl) is broken. + + There are known bugs in the PurePerl parser included with version 0.13 + and 0.14 of XML::SAX. The XML::Simple tests will fail with this parser. + + One way to avoid the problem is to install XML::SAX::Expat - it will + install itself as the system default XML parser and then you will be able + to install XML::Simple successfully. XML::SAX::Expat is also much faster + than XML::SAX::PurePerl so you probably want it anyway. + +============================================================================= +EOF + } + } + elsif ($default_parser eq 'XML::SAX::RTF') { + die <<"EOF"; +============================================================================= + + Fatal error: Your default XML parser (XML::SAX::RTF) is broken. + + The XML::SAX:RTF module is installed as the default XML parser on your + system. This is a bug - although the module does generate SAX events, + it does not parse XML and should not register itself as an XML parser. + + One way to avoid the problem is to install XML::SAX::Expat - it will + register itself as the system default XML parser and then you will be + able to install XML::Simple successfully. + + Another solution would be to locate the XML/SAX/ParserDetails.ini file + and edit it to completely remove the section beginning [XML::SAX::RTF]. + +============================================================================= +EOF + } + print "XML::SAX is installed, it will be used by the test suite\n"; + $make_params->{PREREQ_PM}->{'XML::SAX'} = 0; + $make_params->{PREREQ_PM}->{'XML::NamespaceSupport'} = 1.04; +} +elsif ( eval { require XML::Parser } && ! $@ ) { + print "XML::Parser is installed, it will be used by the test suite\n"; + $make_params->{PREREQ_PM}->{'XML::Parser'} = 0; +} +else { + print "You don't have either XML::SAX or XML::Parser installed!\n"; + $make_params->{PREREQ_PM}->{'XML::SAX'} = 0; + $make_params->{PREREQ_PM}->{'XML::NamespaceSupport'} = 1.04; + # Hopefully the following line can be removed after next XML::SAX release + $make_params->{PREREQ_PM}->{'XML::SAX::Expat'} = 0; +} + +eval { require Storable }; +if($@) { + print "Storable is not installed ... caching functions will not be available\n"; +} + + +WriteMakefile(%$make_params); diff --git a/README b/README new file mode 100644 index 0000000..8a6289a --- /dev/null +++ b/README @@ -0,0 +1,76 @@ +DESCRIPTION + + XML::Simple - Easy API to read/write XML (esp config files) + + +PREREQUISITES + + XML::Simple requires a module capable of parsing XML - either XML::SAX or + XML::Parser must be installed (if you're running ActivePerl, you'll + already have XML::Parser installed). + + If you have installed XML::SAX, it will be used by default. You should + consider installing XML::SAX::Expat or XML::LibXML to replace the (slower) + PurePerl parser from the XML::SAX distribution. + + If you install using the CPAN.pm shell and you do not have either XML::Parser + or XML::SAX installed, then XML::SAX will be installed by default. + + To generate documents with namespaces, XML::NamespaceSupport is required. + + The optional caching features of XML::Simple also require Storable.pm. + + +WARNING MESSAGES FROM XML::SAX + + When you use XML::Simple, you may see this warning message: + + could not find ParserDetails.ini in C:/Perl/site/lib/XML/SAX + + This means your XML::SAX installation is broken (perhaps you installed + version 0.10 from the ActiveState PPM repository). Since it's broken + anyway, the simplest way to suppress these warnings is to remove + C:/Perl/site/lib/XML/SAX.pm. + + The procedure for correctly installing the latest version of XML::SAX + is documented here: + + http://perl-xml.sourceforge.net/faq/#win32_cpan + +BUILDING/INSTALLING + + Once the archive is unpacked, use these commands: + + perl Makefile.PL + make + make test + make install + + If for some reason, you can't run these commands, you can simple copy + the Simple.pm file to your lib/XML directory (where Parser.pm lives). + + If you want to test the module, but don't have 'make', try: + + perl maketest + + +STATUS + + This version (2.16) is the current stable release. + + Please send any feedback to the author: grantm@cpan.org + + See 'Changes' for a detailed history. + + See 'perldoc XML::Simple' for full documentation. + + See 'perldoc XML::Simple::FAQ' for frequently asked questions. + + +COPYRIGHT + + Copyright 1999-2004 Grant McLean + + This library is free software; you can redistribute it + and/or modify it under the same terms as Perl itself. + diff --git a/lib/XML/Simple.pm b/lib/XML/Simple.pm new file mode 100644 index 0000000..38c402d --- /dev/null +++ b/lib/XML/Simple.pm @@ -0,0 +1,3284 @@ +# $Id: Simple.pm,v 1.40 2007/08/15 10:36:48 grantm Exp $ + +package XML::Simple; + +=head1 NAME + +XML::Simple - Easy API to maintain XML (esp config files) + +=head1 SYNOPSIS + + use XML::Simple; + + my $ref = XMLin([] [, ]); + + my $xml = XMLout($hashref [, ]); + +Or the object oriented way: + + require XML::Simple; + + my $xs = XML::Simple->new(options); + + my $ref = $xs->XMLin([] [, ]); + + my $xml = $xs->XMLout($hashref [, ]); + +(or see L<"SAX SUPPORT"> for 'the SAX way'). + +To catch common errors: + + use XML::Simple qw(:strict); + +(see L<"STRICT MODE"> for more details). + +=cut + +# See after __END__ for more POD documentation + + +# Load essentials here, other modules loaded on demand later + +use strict; +use Carp; +require Exporter; + + +############################################################################## +# Define some constants +# + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER); + +@ISA = qw(Exporter); +@EXPORT = qw(XMLin XMLout); +@EXPORT_OK = qw(xml_in xml_out); +$VERSION = '2.18'; +$PREFERRED_PARSER = undef; + +my $StrictMode = 0; + +my @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr + searchpath forcearray cache suppressempty parseropts + grouptags nsexpand datahandler varattr variables + normalisespace normalizespace valueattr); + +my @KnownOptOut = qw(keyattr keeproot contentkey noattr + rootname xmldecl outputfile noescape suppressempty + grouptags nsexpand handler noindent attrindent nosort + valueattr numericescape); + +my @DefKeyAttr = qw(name key id); +my $DefRootName = qq(opt); +my $DefContentKey = qq(content); +my $DefXmlDecl = qq(); + +my $xmlns_ns = 'http://www.w3.org/2000/xmlns/'; +my $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround + + +############################################################################## +# Globals for use by caching routines +# + +my %MemShareCache = (); +my %MemCopyCache = (); + + +############################################################################## +# Wrapper for Exporter - handles ':strict' +# + +sub import { + # Handle the :strict tag + + $StrictMode = 1 if grep(/^:strict$/, @_); + + # Pass everything else to Exporter.pm + + @_ = grep(!/^:strict$/, @_); + goto &Exporter::import; +} + + +############################################################################## +# Constructor for optional object interface. +# + +sub new { + my $class = shift; + + if(@_ % 2) { + croak "Default options must be name=>value pairs (odd number supplied)"; + } + + my %known_opt; + @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100; + + my %raw_opt = @_; + my %def_opt; + while(my($key, $val) = each %raw_opt) { + my $lkey = lc($key); + $lkey =~ s/_//g; + croak "Unrecognised option: $key" unless(exists($known_opt{$lkey})); + $def_opt{$lkey} = $val; + } + my $self = { def_opt => \%def_opt }; + + return(bless($self, $class)); +} + + +############################################################################## +# Sub: _get_object() +# +# Helper routine called from XMLin() and XMLout() to create an object if none +# was provided. Note, this routine does mess with the caller's @_ array. +# + +sub _get_object { + my $self; + if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) { + $self = shift; + } + else { + $self = XML::Simple->new(); + } + + return $self; +} + + +############################################################################## +# Sub/Method: XMLin() +# +# Exported routine for slurping XML into a hashref - see pod for info. +# +# May be called as object method or as a plain function. +# +# Expects one arg for the source XML, optionally followed by a number of +# name => value option pairs. +# + +sub XMLin { + my $self = &_get_object; # note, @_ is passed implicitly + + my $target = shift; + + + # Work out whether to parse a string, a file or a filehandle + + if(not defined $target) { + return $self->parse_file(undef, @_); + } + + elsif($target eq '-') { + local($/) = undef; + $target = ; + return $self->parse_string(\$target, @_); + } + + elsif(my $type = ref($target)) { + if($type eq 'SCALAR') { + return $self->parse_string($target, @_); + } + else { + return $self->parse_fh($target, @_); + } + } + + elsif($target =~ m{<.*?>}s) { + return $self->parse_string(\$target, @_); + } + + else { + return $self->parse_file($target, @_); + } +} + + +############################################################################## +# Sub/Method: parse_file() +# +# Same as XMLin, but only parses from a named file. +# + +sub parse_file { + my $self = &_get_object; # note, @_ is passed implicitly + + my $filename = shift; + + $self->handle_options('in', @_); + + $filename = $self->default_config_file if not defined $filename; + + $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}}); + + # Check cache for previous parse + + if($self->{opt}->{cache}) { + foreach my $scheme (@{$self->{opt}->{cache}}) { + my $method = 'cache_read_' . $scheme; + my $opt = $self->$method($filename); + return($opt) if($opt); + } + } + + my $ref = $self->build_simple_tree($filename, undef); + + if($self->{opt}->{cache}) { + my $method = 'cache_write_' . $self->{opt}->{cache}->[0]; + $self->$method($ref, $filename); + } + + return $ref; +} + + +############################################################################## +# Sub/Method: parse_fh() +# +# Same as XMLin, but only parses from a filehandle. +# + +sub parse_fh { + my $self = &_get_object; # note, @_ is passed implicitly + + my $fh = shift; + croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') . + " as a filehandle" unless ref $fh; + + $self->handle_options('in', @_); + + return $self->build_simple_tree(undef, $fh); +} + + +############################################################################## +# Sub/Method: parse_string() +# +# Same as XMLin, but only parses from a string or a reference to a string. +# + +sub parse_string { + my $self = &_get_object; # note, @_ is passed implicitly + + my $string = shift; + + $self->handle_options('in', @_); + + return $self->build_simple_tree(undef, ref $string ? $string : \$string); +} + + +############################################################################## +# Method: default_config_file() +# +# Returns the name of the XML file to parse if no filename (or XML string) +# was provided. +# + +sub default_config_file { + my $self = shift; + + require File::Basename; + + my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+'); + + # Add script directory to searchpath + + if($script_dir) { + unshift(@{$self->{opt}->{searchpath}}, $script_dir); + } + + return $basename . '.xml'; +} + + +############################################################################## +# Method: build_simple_tree() +# +# Builds a 'tree' data structure as provided by XML::Parser and then +# 'simplifies' it as specified by the various options in effect. +# + +sub build_simple_tree { + my $self = shift; + + my $tree = $self->build_tree(@_); + + return $self->{opt}->{keeproot} + ? $self->collapse({}, @$tree) + : $self->collapse(@{$tree->[1]}); +} + + +############################################################################## +# Method: build_tree() +# +# This routine will be called if there is no suitable pre-parsed tree in a +# cache. It parses the XML and returns an XML::Parser 'Tree' style data +# structure (summarised in the comments for the collapse() routine below). +# +# XML::Simple requires the services of another module that knows how to parse +# XML. If XML::SAX is installed, the default SAX parser will be used, +# otherwise XML::Parser will be used. +# +# This routine expects to be passed a filename as argument 1 or a 'string' as +# argument 2. The 'string' might be a string of XML (passed by reference to +# save memory) or it might be a reference to an IO::Handle. (This +# non-intuitive mess results in part from the way XML::Parser works but that's +# really no excuse). +# + +sub build_tree { + my $self = shift; + my $filename = shift; + my $string = shift; + + + my $preferred_parser = $PREFERRED_PARSER; + unless(defined($preferred_parser)) { + $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || ''; + } + if($preferred_parser eq 'XML::Parser') { + return($self->build_tree_xml_parser($filename, $string)); + } + + eval { require XML::SAX; }; # We didn't need it until now + if($@) { # No XML::SAX - fall back to XML::Parser + if($preferred_parser) { # unless a SAX parser was expressly requested + croak "XMLin() could not load XML::SAX"; + } + return($self->build_tree_xml_parser($filename, $string)); + } + + $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser); + + my $sp = XML::SAX::ParserFactory->parser(Handler => $self); + + $self->{nocollapse} = 1; + my($tree); + if($filename) { + $tree = $sp->parse_uri($filename); + } + else { + if(ref($string) && ref($string) ne 'SCALAR') { + $tree = $sp->parse_file($string); + } + else { + $tree = $sp->parse_string($$string); + } + } + + return($tree); +} + + +############################################################################## +# Method: build_tree_xml_parser() +# +# This routine will be called if XML::SAX is not installed, or if XML::Parser +# was specifically requested. It takes the same arguments as build_tree() and +# returns the same data structure (XML::Parser 'Tree' style). +# + +sub build_tree_xml_parser { + my $self = shift; + my $filename = shift; + my $string = shift; + + + eval { + local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load() + require XML::Parser; # We didn't need it until now + }; + if($@) { + croak "XMLin() requires either XML::SAX or XML::Parser"; + } + + if($self->{opt}->{nsexpand}) { + carp "'nsexpand' option requires XML::SAX"; + } + + my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}}); + my($tree); + if($filename) { + # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl + local(*XML_FILE); + open(XML_FILE, '<', $filename) || croak qq($filename - $!); + $tree = $xp->parse(*XML_FILE); + close(XML_FILE); + } + else { + $tree = $xp->parse($$string); + } + + return($tree); +} + + +############################################################################## +# Method: cache_write_storable() +# +# Wrapper routine for invoking Storable::nstore() to cache a parsed data +# structure. +# + +sub cache_write_storable { + my($self, $data, $filename) = @_; + + my $cachefile = $self->storable_filename($filename); + + require Storable; # We didn't need it until now + + if ('VMS' eq $^O) { + Storable::nstore($data, $cachefile); + } + else { + # If the following line fails for you, your Storable.pm is old - upgrade + Storable::lock_nstore($data, $cachefile); + } + +} + + +############################################################################## +# Method: cache_read_storable() +# +# Wrapper routine for invoking Storable::retrieve() to read a cached parsed +# data structure. Only returns cached data if the cache file exists and is +# newer than the source XML file. +# + +sub cache_read_storable { + my($self, $filename) = @_; + + my $cachefile = $self->storable_filename($filename); + + return unless(-r $cachefile); + return unless((stat($cachefile))[9] > (stat($filename))[9]); + + require Storable; # We didn't need it until now + + if ('VMS' eq $^O) { + return(Storable::retrieve($cachefile)); + } + else { + return(Storable::lock_retrieve($cachefile)); + } + +} + + +############################################################################## +# Method: storable_filename() +# +# Translates the supplied source XML filename into a filename for the storable +# cached data. A '.stor' suffix is added after stripping an optional '.xml' +# suffix. +# + +sub storable_filename { + my($self, $cachefile) = @_; + + $cachefile =~ s{(\.xml)?$}{.stor}; + return $cachefile; +} + + +############################################################################## +# Method: cache_write_memshare() +# +# Takes the supplied data structure reference and stores it away in a global +# hash structure. +# + +sub cache_write_memshare { + my($self, $data, $filename) = @_; + + $MemShareCache{$filename} = [time(), $data]; +} + + +############################################################################## +# Method: cache_read_memshare() +# +# Takes a filename and looks in a global hash for a cached parsed version. +# + +sub cache_read_memshare { + my($self, $filename) = @_; + + return unless($MemShareCache{$filename}); + return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]); + + return($MemShareCache{$filename}->[1]); + +} + + +############################################################################## +# Method: cache_write_memcopy() +# +# Takes the supplied data structure and stores a copy of it in a global hash +# structure. +# + +sub cache_write_memcopy { + my($self, $data, $filename) = @_; + + require Storable; # We didn't need it until now + + $MemCopyCache{$filename} = [time(), Storable::dclone($data)]; +} + + +############################################################################## +# Method: cache_read_memcopy() +# +# Takes a filename and looks in a global hash for a cached parsed version. +# Returns a reference to a copy of that data structure. +# + +sub cache_read_memcopy { + my($self, $filename) = @_; + + return unless($MemCopyCache{$filename}); + return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]); + + return(Storable::dclone($MemCopyCache{$filename}->[1])); + +} + + +############################################################################## +# Sub/Method: XMLout() +# +# Exported routine for 'unslurping' a data structure out to XML. +# +# Expects a reference to a data structure and an optional list of option +# name => value pairs. +# + +sub XMLout { + my $self = &_get_object; # note, @_ is passed implicitly + + croak "XMLout() requires at least one argument" unless(@_); + my $ref = shift; + + $self->handle_options('out', @_); + + + # If namespace expansion is set, XML::NamespaceSupport is required + + if($self->{opt}->{nsexpand}) { + require XML::NamespaceSupport; + $self->{nsup} = XML::NamespaceSupport->new(); + $self->{ns_prefix} = 'aaa'; + } + + + # Wrap top level arrayref in a hash + + if(UNIVERSAL::isa($ref, 'ARRAY')) { + $ref = { anon => $ref }; + } + + + # Extract rootname from top level hash if keeproot enabled + + if($self->{opt}->{keeproot}) { + my(@keys) = keys(%$ref); + if(@keys == 1) { + $ref = $ref->{$keys[0]}; + $self->{opt}->{rootname} = $keys[0]; + } + } + + # Ensure there are no top level attributes if we're not adding root elements + + elsif($self->{opt}->{rootname} eq '') { + if(UNIVERSAL::isa($ref, 'HASH')) { + my $refsave = $ref; + $ref = {}; + foreach (keys(%$refsave)) { + if(ref($refsave->{$_})) { + $ref->{$_} = $refsave->{$_}; + } + else { + $ref->{$_} = [ $refsave->{$_} ]; + } + } + } + } + + + # Encode the hashref and write to file if necessary + + $self->{_ancestors} = []; + my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, ''); + delete $self->{_ancestors}; + + if($self->{opt}->{xmldecl}) { + $xml = $self->{opt}->{xmldecl} . "\n" . $xml; + } + + if($self->{opt}->{outputfile}) { + if(ref($self->{opt}->{outputfile})) { + my $fh = $self->{opt}->{outputfile}; + if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) { + eval { require IO::Handle; }; + croak $@ if $@; + } + return($fh->print($xml)); + } + else { + local(*OUT); + open(OUT, '>', "$self->{opt}->{outputfile}") || + croak "open($self->{opt}->{outputfile}): $!"; + binmode(OUT, ':utf8') if($] >= 5.008); + print OUT $xml || croak "print: $!"; + close(OUT); + } + } + elsif($self->{opt}->{handler}) { + require XML::SAX; + my $sp = XML::SAX::ParserFactory->parser( + Handler => $self->{opt}->{handler} + ); + return($sp->parse_string($xml)); + } + else { + return($xml); + } +} + + +############################################################################## +# Method: handle_options() +# +# Helper routine for both XMLin() and XMLout(). Both routines handle their +# first argument and assume all other args are options handled by this routine. +# Saves a hash of options in $self->{opt}. +# +# If default options were passed to the constructor, they will be retrieved +# here and merged with options supplied to the method call. +# +# First argument should be the string 'in' or the string 'out'. +# +# Remaining arguments should be name=>value pairs. Sets up default values +# for options not supplied. Unrecognised options are a fatal error. +# + +sub handle_options { + my $self = shift; + my $dirn = shift; + + + # Determine valid options based on context + + my %known_opt; + if($dirn eq 'in') { + @known_opt{@KnownOptIn} = @KnownOptIn; + } + else { + @known_opt{@KnownOptOut} = @KnownOptOut; + } + + + # Store supplied options in hashref and weed out invalid ones + + if(@_ % 2) { + croak "Options must be name=>value pairs (odd number supplied)"; + } + my %raw_opt = @_; + my $opt = {}; + $self->{opt} = $opt; + + while(my($key, $val) = each %raw_opt) { + my $lkey = lc($key); + $lkey =~ s/_//g; + croak "Unrecognised option: $key" unless($known_opt{$lkey}); + $opt->{$lkey} = $val; + } + + + # Merge in options passed to constructor + + foreach (keys(%known_opt)) { + unless(exists($opt->{$_})) { + if(exists($self->{def_opt}->{$_})) { + $opt->{$_} = $self->{def_opt}->{$_}; + } + } + } + + + # Set sensible defaults if not supplied + + if(exists($opt->{rootname})) { + unless(defined($opt->{rootname})) { + $opt->{rootname} = ''; + } + } + else { + $opt->{rootname} = $DefRootName; + } + + if($opt->{xmldecl} and $opt->{xmldecl} eq '1') { + $opt->{xmldecl} = $DefXmlDecl; + } + + if(exists($opt->{contentkey})) { + if($opt->{contentkey} =~ m{^-(.*)$}) { + $opt->{contentkey} = $1; + $opt->{collapseagain} = 1; + } + } + else { + $opt->{contentkey} = $DefContentKey; + } + + unless(exists($opt->{normalisespace})) { + $opt->{normalisespace} = $opt->{normalizespace}; + } + $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace})); + + # Cleanups for values assumed to be arrays later + + if($opt->{searchpath}) { + unless(ref($opt->{searchpath})) { + $opt->{searchpath} = [ $opt->{searchpath} ]; + } + } + else { + $opt->{searchpath} = [ ]; + } + + if($opt->{cache} and !ref($opt->{cache})) { + $opt->{cache} = [ $opt->{cache} ]; + } + if($opt->{cache}) { + $_ = lc($_) foreach (@{$opt->{cache}}); + foreach my $scheme (@{$opt->{cache}}) { + my $method = 'cache_read_' . $scheme; + croak "Unsupported caching scheme: $scheme" + unless($self->can($method)); + } + } + + if(exists($opt->{parseropts})) { + if($^W) { + carp "Warning: " . + "'ParserOpts' is deprecated, contact the author if you need it"; + } + } + else { + $opt->{parseropts} = [ ]; + } + + + # Special cleanup for {forcearray} which could be regex, arrayref or boolean + # or left to default to 0 + + if(exists($opt->{forcearray})) { + if(ref($opt->{forcearray}) eq 'Regexp') { + $opt->{forcearray} = [ $opt->{forcearray} ]; + } + + if(ref($opt->{forcearray}) eq 'ARRAY') { + my @force_list = @{$opt->{forcearray}}; + if(@force_list) { + $opt->{forcearray} = {}; + foreach my $tag (@force_list) { + if(ref($tag) eq 'Regexp') { + push @{$opt->{forcearray}->{_regex}}, $tag; + } + else { + $opt->{forcearray}->{$tag} = 1; + } + } + } + else { + $opt->{forcearray} = 0; + } + } + else { + $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 ); + } + } + else { + if($StrictMode and $dirn eq 'in') { + croak "No value specified for 'ForceArray' option in call to XML$dirn()"; + } + $opt->{forcearray} = 0; + } + + + # Special cleanup for {keyattr} which could be arrayref or hashref or left + # to default to arrayref + + if(exists($opt->{keyattr})) { + if(ref($opt->{keyattr})) { + if(ref($opt->{keyattr}) eq 'HASH') { + + # Make a copy so we can mess with it + + $opt->{keyattr} = { %{$opt->{keyattr}} }; + + + # Convert keyattr => { elem => '+attr' } + # to keyattr => { elem => [ 'attr', '+' ] } + + foreach my $el (keys(%{$opt->{keyattr}})) { + if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) { + $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ]; + if($StrictMode and $dirn eq 'in') { + next if($opt->{forcearray} == 1); + next if(ref($opt->{forcearray}) eq 'HASH' + and $opt->{forcearray}->{$el}); + croak "<$el> set in KeyAttr but not in ForceArray"; + } + } + else { + delete($opt->{keyattr}->{$el}); # Never reached (famous last words?) + } + } + } + else { + if(@{$opt->{keyattr}} == 0) { + delete($opt->{keyattr}); + } + } + } + else { + $opt->{keyattr} = [ $opt->{keyattr} ]; + } + } + else { + if($StrictMode) { + croak "No value specified for 'KeyAttr' option in call to XML$dirn()"; + } + $opt->{keyattr} = [ @DefKeyAttr ]; + } + + + # Special cleanup for {valueattr} which could be arrayref or hashref + + if(exists($opt->{valueattr})) { + if(ref($opt->{valueattr}) eq 'ARRAY') { + $opt->{valueattrlist} = {}; + $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} }); + } + } + + # make sure there's nothing weird in {grouptags} + + if($opt->{grouptags}) { + croak "Illegal value for 'GroupTags' option - expected a hashref" + unless UNIVERSAL::isa($opt->{grouptags}, 'HASH'); + + while(my($key, $val) = each %{$opt->{grouptags}}) { + next if $key ne $val; + croak "Bad value in GroupTags: '$key' => '$val'"; + } + } + + + # Check the {variables} option is valid and initialise variables hash + + if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) { + croak "Illegal value for 'Variables' option - expected a hashref"; + } + + if($opt->{variables}) { + $self->{_var_values} = { %{$opt->{variables}} }; + } + elsif($opt->{varattr}) { + $self->{_var_values} = {}; + } + +} + + +############################################################################## +# Method: find_xml_file() +# +# Helper routine for XMLin(). +# Takes a filename, and a list of directories, attempts to locate the file in +# the directories listed. +# Returns a full pathname on success; croaks on failure. +# + +sub find_xml_file { + my $self = shift; + my $file = shift; + my @search_path = @_; + + + require File::Basename; + require File::Spec; + + my($filename, $filedir) = File::Basename::fileparse($file); + + if($filename ne $file) { # Ignore searchpath if dir component + return($file) if(-e $file); + } + else { + my($path); + foreach $path (@search_path) { + my $fullpath = File::Spec->catfile($path, $file); + return($fullpath) if(-e $fullpath); + } + } + + # If user did not supply a search path, default to current directory + + if(!@search_path) { + return($file) if(-e $file); + croak "File does not exist: $file"; + } + + croak "Could not find $file in ", join(':', @search_path); +} + + +############################################################################## +# Method: collapse() +# +# Helper routine for XMLin(). This routine really comprises the 'smarts' (or +# value add) of this module. +# +# Takes the parse tree that XML::Parser produced from the supplied XML and +# recurses through it 'collapsing' unnecessary levels of indirection (nested +# arrays etc) to produce a data structure that is easier to work with. +# +# Elements in the original parser tree are represented as an element name +# followed by an arrayref. The first element of the array is a hashref +# containing the attributes. The rest of the array contains a list of any +# nested elements as name+arrayref pairs: +# +# , [ { }, , [ ... ], ... ] +# +# The special element name '0' (zero) flags text content. +# +# This routine cuts down the noise by discarding any text content consisting of +# only whitespace and then moves the nested elements into the attribute hash +# using the name of the nested element as the hash key and the collapsed +# version of the nested element as the value. Multiple nested elements with +# the same name will initially be represented as an arrayref, but this may be +# 'folded' into a hashref depending on the value of the keyattr option. +# + +sub collapse { + my $self = shift; + + + # Start with the hash of attributes + + my $attr = shift; + if($self->{opt}->{noattr}) { # Discard if 'noattr' set + $attr = {}; + } + elsif($self->{opt}->{normalisespace} == 2) { + while(my($key, $value) = each %$attr) { + $attr->{$key} = $self->normalise_space($value) + } + } + + + # Do variable substitutions + + if(my $var = $self->{_var_values}) { + while(my($key, $val) = each(%$attr)) { + $val =~ s{\$\{([\w.]+)\}}{ $self->get_var($1) }ge; + $attr->{$key} = $val; + } + } + + + # Roll up 'value' attributes (but only if no nested elements) + + if(!@_ and keys %$attr == 1) { + my($k) = keys %$attr; + if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) { + return $attr->{$k}; + } + } + + + # Add any nested elements + + my($key, $val); + while(@_) { + $key = shift; + $val = shift; + + if(ref($val)) { + $val = $self->collapse(@$val); + next if(!defined($val) and $self->{opt}->{suppressempty}); + } + elsif($key eq '0') { + next if($val =~ m{^\s*$}s); # Skip all whitespace content + + $val = $self->normalise_space($val) + if($self->{opt}->{normalisespace} == 2); + + # do variable substitutions + + if(my $var = $self->{_var_values}) { + $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge; + } + + + # look for variable definitions + + if(my $var = $self->{opt}->{varattr}) { + if(exists $attr->{$var}) { + $self->set_var($attr->{$var}, $val); + } + } + + + # Collapse text content in element with no attributes to a string + + if(!%$attr and !@_) { + return($self->{opt}->{forcecontent} ? + { $self->{opt}->{contentkey} => $val } : $val + ); + } + $key = $self->{opt}->{contentkey}; + } + + + # Combine duplicate attributes into arrayref if required + + if(exists($attr->{$key})) { + if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) { + push(@{$attr->{$key}}, $val); + } + else { + $attr->{$key} = [ $attr->{$key}, $val ]; + } + } + elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) { + $attr->{$key} = [ $val ]; + } + else { + if( $key ne $self->{opt}->{contentkey} + and ( + ($self->{opt}->{forcearray} == 1) + or ( + (ref($self->{opt}->{forcearray}) eq 'HASH') + and ( + $self->{opt}->{forcearray}->{$key} + or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}}) + ) + ) + ) + ) { + $attr->{$key} = [ $val ]; + } + else { + $attr->{$key} = $val; + } + } + + } + + + # Turn arrayrefs into hashrefs if key fields present + + if($self->{opt}->{keyattr}) { + while(($key,$val) = each %$attr) { + if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) { + $attr->{$key} = $self->array_to_hash($key, $val); + } + } + } + + + # disintermediate grouped tags + + if($self->{opt}->{grouptags}) { + while(my($key, $val) = each(%$attr)) { + next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1)); + next unless(exists($self->{opt}->{grouptags}->{$key})); + + my($child_key, $child_val) = %$val; + + if($self->{opt}->{grouptags}->{$key} eq $child_key) { + $attr->{$key}= $child_val; + } + } + } + + + # Fold hashes containing a single anonymous array up into just the array + + my $count = scalar keys %$attr; + if($count == 1 + and exists $attr->{anon} + and UNIVERSAL::isa($attr->{anon}, 'ARRAY') + ) { + return($attr->{anon}); + } + + + # Do the right thing if hash is empty, otherwise just return it + + if(!%$attr and exists($self->{opt}->{suppressempty})) { + if(defined($self->{opt}->{suppressempty}) and + $self->{opt}->{suppressempty} eq '') { + return(''); + } + return(undef); + } + + + # Roll up named elements with named nested 'value' attributes + + if($self->{opt}->{valueattr}) { + while(my($key, $val) = each(%$attr)) { + next unless($self->{opt}->{valueattr}->{$key}); + next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1)); + my($k) = keys %$val; + next unless($k eq $self->{opt}->{valueattr}->{$key}); + $attr->{$key} = $val->{$k}; + } + } + + return($attr) + +} + + +############################################################################## +# Method: set_var() +# +# Called when a variable definition is encountered in the XML. (A variable +# definition looks like value where attrname +# matches the varattr setting). +# + +sub set_var { + my($self, $name, $value) = @_; + + $self->{_var_values}->{$name} = $value; +} + + +############################################################################## +# Method: get_var() +# +# Called during variable substitution to get the value for the named variable. +# + +sub get_var { + my($self, $name) = @_; + + my $value = $self->{_var_values}->{$name}; + return $value if(defined($value)); + + return '${' . $name . '}'; +} + + +############################################################################## +# Method: normalise_space() +# +# Strips leading and trailing whitespace and collapses sequences of whitespace +# characters to a single space. +# + +sub normalise_space { + my($self, $text) = @_; + + $text =~ s/^\s+//s; + $text =~ s/\s+$//s; + $text =~ s/\s\s+/ /sg; + + return $text; +} + + +############################################################################## +# Method: array_to_hash() +# +# Helper routine for collapse(). +# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a +# reference to the hash on success or the original array if folding is +# not possible. Behaviour is controlled by 'keyattr' option. +# + +sub array_to_hash { + my $self = shift; + my $name = shift; + my $arrayref = shift; + + my $hashref = $self->new_hashref; + + my($i, $key, $val, $flag); + + + # Handle keyattr => { .... } + + if(ref($self->{opt}->{keyattr}) eq 'HASH') { + return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name})); + ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}}; + for($i = 0; $i < @$arrayref; $i++) { + if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and + exists($arrayref->[$i]->{$key}) + ) { + $val = $arrayref->[$i]->{$key}; + if(ref($val)) { + $self->die_or_warn("<$name> element has non-scalar '$key' key attribute"); + return($arrayref); + } + $val = $self->normalise_space($val) + if($self->{opt}->{normalisespace} == 1); + $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val") + if(exists($hashref->{$val})); + $hashref->{$val} = { %{$arrayref->[$i]} }; + $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-'); + delete $hashref->{$val}->{$key} unless($flag eq '+'); + } + else { + $self->die_or_warn("<$name> element has no '$key' key attribute"); + return($arrayref); + } + } + } + + + # Or assume keyattr => [ .... ] + + else { + my $default_keys = + join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}}); + + ELEMENT: for($i = 0; $i < @$arrayref; $i++) { + return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH')); + + foreach $key (@{$self->{opt}->{keyattr}}) { + if(defined($arrayref->[$i]->{$key})) { + $val = $arrayref->[$i]->{$key}; + if(ref($val)) { + $self->die_or_warn("<$name> element has non-scalar '$key' key attribute") + if not $default_keys; + return($arrayref); + } + $val = $self->normalise_space($val) + if($self->{opt}->{normalisespace} == 1); + $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val") + if(exists($hashref->{$val})); + $hashref->{$val} = { %{$arrayref->[$i]} }; + delete $hashref->{$val}->{$key}; + next ELEMENT; + } + } + + return($arrayref); # No keyfield matched + } + } + + # collapse any hashes which now only have a 'content' key + + if($self->{opt}->{collapseagain}) { + $hashref = $self->collapse_content($hashref); + } + + return($hashref); +} + + +############################################################################## +# Method: die_or_warn() +# +# Takes a diagnostic message and does one of three things: +# 1. dies if strict mode is enabled +# 2. warns if warnings are enabled but strict mode is not +# 3. ignores message and resturns silently if neither strict mode nor warnings +# are enabled +# + +sub die_or_warn { + my $self = shift; + my $msg = shift; + + croak $msg if($StrictMode); + carp "Warning: $msg" if($^W); +} + + +############################################################################## +# Method: new_hashref() +# +# This is a hook routine for overriding in a sub-class. Some people believe +# that using Tie::IxHash here will solve order-loss problems. +# + +sub new_hashref { + my $self = shift; + + return { @_ }; +} + + +############################################################################## +# Method: collapse_content() +# +# Helper routine for array_to_hash +# +# Arguments expected are: +# - an XML::Simple object +# - a hasref +# the hashref is a former array, turned into a hash by array_to_hash because +# of the presence of key attributes +# at this point collapse_content avoids over-complicated structures like +# dir => { libexecdir => { content => '$exec_prefix/libexec' }, +# localstatedir => { content => '$prefix' }, +# } +# into +# dir => { libexecdir => '$exec_prefix/libexec', +# localstatedir => '$prefix', +# } + +sub collapse_content { + my $self = shift; + my $hashref = shift; + + my $contentkey = $self->{opt}->{contentkey}; + + # first go through the values,checking that they are fit to collapse + foreach my $val (values %$hashref) { + return $hashref unless ( (ref($val) eq 'HASH') + and (keys %$val == 1) + and (exists $val->{$contentkey}) + ); + } + + # now collapse them + foreach my $key (keys %$hashref) { + $hashref->{$key}= $hashref->{$key}->{$contentkey}; + } + + return $hashref; +} + + +############################################################################## +# Method: value_to_xml() +# +# Helper routine for XMLout() - recurses through a data structure building up +# and returning an XML representation of that structure as a string. +# +# Arguments expected are: +# - the data structure to be encoded (usually a reference) +# - the XML tag name to use for this item +# - a string of spaces for use as the current indent level +# + +sub value_to_xml { + my $self = shift;; + + + # Grab the other arguments + + my($ref, $name, $indent) = @_; + + my $named = (defined($name) and $name ne '' ? 1 : 0); + + my $nl = "\n"; + + my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack! + if($self->{opt}->{noindent}) { + $indent = ''; + $nl = ''; + } + + + # Convert to XML + + if(ref($ref)) { + croak "circular data structures not supported" + if(grep($_ == $ref, @{$self->{_ancestors}})); + push @{$self->{_ancestors}}, $ref; + } + else { + if($named) { + return(join('', + $indent, '<', $name, '>', + ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)), + '", $nl + )); + } + else { + return("$ref$nl"); + } + } + + + # Unfold hash to array if possible + + if(UNIVERSAL::isa($ref, 'HASH') # It is a hash + and keys %$ref # and it's not empty + and $self->{opt}->{keyattr} # and folding is enabled + and !$is_root # and its not the root element + ) { + $ref = $self->hash_to_array($name, $ref); + } + + + my @result = (); + my($key, $value); + + + # Handle hashrefs + + if(UNIVERSAL::isa($ref, 'HASH')) { + + # Reintermediate grouped values if applicable + + if($self->{opt}->{grouptags}) { + $ref = $self->copy_hash($ref); + while(my($key, $val) = each %$ref) { + if($self->{opt}->{grouptags}->{$key}) { + $ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val }; + } + } + } + + + # Scan for namespace declaration attributes + + my $nsdecls = ''; + my $default_ns_uri; + if($self->{nsup}) { + $ref = $self->copy_hash($ref); + $self->{nsup}->push_context(); + + # Look for default namespace declaration first + + if(exists($ref->{xmlns})) { + $self->{nsup}->declare_prefix('', $ref->{xmlns}); + $nsdecls .= qq( xmlns="$ref->{xmlns}"); + delete($ref->{xmlns}); + } + $default_ns_uri = $self->{nsup}->get_uri(''); + + + # Then check all the other keys + + foreach my $qname (keys(%$ref)) { + my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname); + if($uri) { + if($uri eq $xmlns_ns) { + $self->{nsup}->declare_prefix($lname, $ref->{$qname}); + $nsdecls .= qq( xmlns:$lname="$ref->{$qname}"); + delete($ref->{$qname}); + } + } + } + + # Translate any remaining Clarkian names + + foreach my $qname (keys(%$ref)) { + my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname); + if($uri) { + if($default_ns_uri and $uri eq $default_ns_uri) { + $ref->{$lname} = $ref->{$qname}; + delete($ref->{$qname}); + } + else { + my $prefix = $self->{nsup}->get_prefix($uri); + unless($prefix) { + # $self->{nsup}->declare_prefix(undef, $uri); + # $prefix = $self->{nsup}->get_prefix($uri); + $prefix = $self->{ns_prefix}++; + $self->{nsup}->declare_prefix($prefix, $uri); + $nsdecls .= qq( xmlns:$prefix="$uri"); + } + $ref->{"$prefix:$lname"} = $ref->{$qname}; + delete($ref->{$qname}); + } + } + } + } + + + my @nested = (); + my $text_content = undef; + if($named) { + push @result, $indent, '<', $name, $nsdecls; + } + + if(keys %$ref) { + my $first_arg = 1; + foreach my $key ($self->sorted_keys($name, $ref)) { + my $value = $ref->{$key}; + next if(substr($key, 0, 1) eq '-'); + if(!defined($value)) { + next if $self->{opt}->{suppressempty}; + unless(exists($self->{opt}->{suppressempty}) + and !defined($self->{opt}->{suppressempty}) + ) { + carp 'Use of uninitialized value' if($^W); + } + if($key eq $self->{opt}->{contentkey}) { + $text_content = ''; + } + else { + $value = exists($self->{opt}->{suppressempty}) ? {} : ''; + } + } + + if(!ref($value) + and $self->{opt}->{valueattr} + and $self->{opt}->{valueattr}->{$key} + ) { + $value = { $self->{opt}->{valueattr}->{$key} => $value }; + } + + if(ref($value) or $self->{opt}->{noattr}) { + push @nested, + $self->value_to_xml($value, $key, "$indent "); + } + else { + $value = $self->escape_value($value) unless($self->{opt}->{noescape}); + if($key eq $self->{opt}->{contentkey}) { + $text_content = $value; + } + else { + push @result, "\n$indent " . ' ' x length($name) + if($self->{opt}->{attrindent} and !$first_arg); + push @result, ' ', $key, '="', $value , '"'; + $first_arg = 0; + } + } + } + } + else { + $text_content = ''; + } + + if(@nested or defined($text_content)) { + if($named) { + push @result, ">"; + if(defined($text_content)) { + push @result, $text_content; + $nested[0] =~ s/^\s+// if(@nested); + } + else { + push @result, $nl; + } + if(@nested) { + push @result, @nested, $indent; + } + push @result, '", $nl; + } + else { + push @result, @nested; # Special case if no root elements + } + } + else { + push @result, " />", $nl; + } + $self->{nsup}->pop_context() if($self->{nsup}); + } + + + # Handle arrayrefs + + elsif(UNIVERSAL::isa($ref, 'ARRAY')) { + foreach $value (@$ref) { + next if !defined($value) and $self->{opt}->{suppressempty}; + if(!ref($value)) { + push @result, + $indent, '<', $name, '>', + ($self->{opt}->{noescape} ? $value : $self->escape_value($value)), + '$nl"; + } + elsif(UNIVERSAL::isa($value, 'HASH')) { + push @result, $self->value_to_xml($value, $name, $indent); + } + else { + push @result, + $indent, '<', $name, ">$nl", + $self->value_to_xml($value, 'anon', "$indent "), + $indent, '$nl"; + } + } + } + + else { + croak "Can't encode a value of type: " . ref($ref); + } + + + pop @{$self->{_ancestors}} if(ref($ref)); + + return(join('', @result)); +} + + +############################################################################## +# Method: sorted_keys() +# +# Returns the keys of the referenced hash sorted into alphabetical order, but +# with the 'key' key (as in KeyAttr) first, if there is one. +# + +sub sorted_keys { + my($self, $name, $ref) = @_; + + return keys %$ref if $self->{opt}->{nosort}; + + my %hash = %$ref; + my $keyattr = $self->{opt}->{keyattr}; + + my @key; + + if(ref $keyattr eq 'HASH') { + if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) { + push @key, $keyattr->{$name}->[0]; + delete $hash{$keyattr->{$name}->[0]}; + } + } + elsif(ref $keyattr eq 'ARRAY') { + foreach (@{$keyattr}) { + if(exists $hash{$_}) { + push @key, $_; + delete $hash{$_}; + last; + } + } + } + + return(@key, sort keys %hash); +} + +############################################################################## +# Method: escape_value() +# +# Helper routine for automatically escaping values for XMLout(). +# Expects a scalar data value. Returns escaped version. +# + +sub escape_value { + my($self, $data) = @_; + + return '' unless(defined($data)); + + $data =~ s/&/&/sg; + $data =~ s//>/sg; + $data =~ s/"/"/sg; + + my $level = $self->{opt}->{numericescape} or return $data; + + return $self->numeric_escape($data, $level); +} + +sub numeric_escape { + my($self, $data, $level) = @_; + + use utf8; # required for 5.6 + + if($self->{opt}->{numericescape} eq '2') { + $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse; + } + else { + $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse; + } + + return $data; +} + + +############################################################################## +# Method: hash_to_array() +# +# Helper routine for value_to_xml(). +# Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a +# reference to the array on success or the original hash if unfolding is +# not possible. +# + +sub hash_to_array { + my $self = shift; + my $parent = shift; + my $hashref = shift; + + my $arrayref = []; + + my($key, $value); + + my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref; + foreach $key (@keys) { + $value = $hashref->{$key}; + return($hashref) unless(UNIVERSAL::isa($value, 'HASH')); + + if(ref($self->{opt}->{keyattr}) eq 'HASH') { + return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent})); + push @$arrayref, $self->copy_hash( + $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key + ); + } + else { + push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value }); + } + } + + return($arrayref); +} + + +############################################################################## +# Method: copy_hash() +# +# Helper routine for hash_to_array(). When unfolding a hash of hashes into +# an array of hashes, we need to copy the key from the outer hash into the +# inner hash. This routine makes a copy of the original hash so we don't +# destroy the original data structure. You might wish to override this +# method if you're using tied hashes and don't want them to get untied. +# + +sub copy_hash { + my($self, $orig, @extra) = @_; + + return { @extra, %$orig }; +} + +############################################################################## +# Methods required for building trees from SAX events +############################################################################## + +sub start_document { + my $self = shift; + + $self->handle_options('in') unless($self->{opt}); + + $self->{lists} = []; + $self->{curlist} = $self->{tree} = []; +} + + +sub start_element { + my $self = shift; + my $element = shift; + + my $name = $element->{Name}; + if($self->{opt}->{nsexpand}) { + $name = $element->{LocalName} || ''; + if($element->{NamespaceURI}) { + $name = '{' . $element->{NamespaceURI} . '}' . $name; + } + } + my $attributes = {}; + if($element->{Attributes}) { # Might be undef + foreach my $attr (values %{$element->{Attributes}}) { + if($self->{opt}->{nsexpand}) { + my $name = $attr->{LocalName} || ''; + if($attr->{NamespaceURI}) { + $name = '{' . $attr->{NamespaceURI} . '}' . $name + } + $name = 'xmlns' if($name eq $bad_def_ns_jcn); + $attributes->{$name} = $attr->{Value}; + } + else { + $attributes->{$attr->{Name}} = $attr->{Value}; + } + } + } + my $newlist = [ $attributes ]; + push @{ $self->{lists} }, $self->{curlist}; + push @{ $self->{curlist} }, $name => $newlist; + $self->{curlist} = $newlist; +} + + +sub characters { + my $self = shift; + my $chars = shift; + + my $text = $chars->{Data}; + my $clist = $self->{curlist}; + my $pos = $#$clist; + + if ($pos > 0 and $clist->[$pos - 1] eq '0') { + $clist->[$pos] .= $text; + } + else { + push @$clist, 0 => $text; + } +} + + +sub end_element { + my $self = shift; + + $self->{curlist} = pop @{ $self->{lists} }; +} + + +sub end_document { + my $self = shift; + + delete($self->{curlist}); + delete($self->{lists}); + + my $tree = $self->{tree}; + delete($self->{tree}); + + + # Return tree as-is to XMLin() + + return($tree) if($self->{nocollapse}); + + + # Or collapse it before returning it to SAX parser class + + if($self->{opt}->{keeproot}) { + $tree = $self->collapse({}, @$tree); + } + else { + $tree = $self->collapse(@{$tree->[1]}); + } + + if($self->{opt}->{datahandler}) { + return($self->{opt}->{datahandler}->($self, $tree)); + } + + return($tree); +} + +*xml_in = \&XMLin; +*xml_out = \&XMLout; + +1; + +__END__ + +=head1 QUICK START + +Say you have a script called B and a file of configuration options +called B containing this: + + + +
10.0.0.101
+
10.0.1.101
+ + +
10.0.0.102
+ + +
10.0.0.103
+
10.0.1.103
+ + + +The following lines of code in B: + + use XML::Simple; + + my $config = XMLin(); + +will 'slurp' the configuration options into the hashref $config (because no +arguments are passed to C the name and location of the XML file will +be inferred from name and location of the script). You can dump out the +contents of the hashref using Data::Dumper: + + use Data::Dumper; + + print Dumper($config); + +which will produce something like this (formatting has been adjusted for +brevity): + + { + 'logdir' => '/var/log/foo/', + 'debugfile' => '/tmp/foo.debug', + 'server' => { + 'sahara' => { + 'osversion' => '2.6', + 'osname' => 'solaris', + 'address' => [ '10.0.0.101', '10.0.1.101' ] + }, + 'gobi' => { + 'osversion' => '6.5', + 'osname' => 'irix', + 'address' => '10.0.0.102' + }, + 'kalahari' => { + 'osversion' => '2.0.34', + 'osname' => 'linux', + 'address' => [ '10.0.0.103', '10.0.1.103' ] + } + } + } + +Your script could then access the name of the log directory like this: + + print $config->{logdir}; + +similarly, the second address on the server 'kalahari' could be referenced as: + + print $config->{server}->{kalahari}->{address}->[1]; + +What could be simpler? (Rhetorical). + +For simple requirements, that's really all there is to it. If you want to +store your XML in a different directory or file, or pass it in as a string or +even pass it in via some derivative of an IO::Handle, you'll need to check out +L<"OPTIONS">. If you want to turn off or tweak the array folding feature (that +neat little transformation that produced $config->{server}) you'll find options +for that as well. + +If you want to generate XML (for example to write a modified version of +$config back out as XML), check out C. + +If your needs are not so simple, this may not be the module for you. In that +case, you might want to read L<"WHERE TO FROM HERE?">. + +=head1 DESCRIPTION + +The XML::Simple module provides a simple API layer on top of an underlying XML +parsing module (either XML::Parser or one of the SAX2 parser modules). Two +functions are exported: C and C. Note: you can explicity +request the lower case versions of the function names: C and +C. + +The simplest approach is to call these two functions directly, but an +optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below) +allows them to be called as methods of an B object. The object +interface can also be used at either end of a SAX pipeline. + +=head2 XMLin() + +Parses XML formatted data and returns a reference to a data structure which +contains the same information in a more readily accessible form. (Skip +down to L<"EXAMPLES"> below, for more sample code). + +C accepts an optional XML specifier followed by zero or more 'name => +value' option pairs. The XML specifier can be one of the following: + +=over 4 + +=item A filename + +If the filename contains no directory components C will look for the +file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the +current directory if the SearchPath option is not defined. eg: + + $ref = XMLin('/etc/params.xml'); + +Note, the filename '-' can be used to parse from STDIN. + +=item undef + +If there is no XML specifier, C will check the script directory and +each of the SearchPath directories for a file with the same name as the script +but with the extension '.xml'. Note: if you wish to specify options, you +must specify the value 'undef'. eg: + + $ref = XMLin(undef, ForceArray => 1); + +=item A string of XML + +A string containing XML (recognised by the presence of '<' and '>' characters) +will be parsed directly. eg: + + $ref = XMLin(''); + +=item An IO::Handle object + +An IO::Handle object will be read to EOF and its contents parsed. eg: + + $fh = IO::File->new('/etc/params.xml'); + $ref = XMLin($fh); + +=back + +=head2 XMLout() + +Takes a data structure (generally a hashref) and returns an XML encoding of +that structure. If the resulting XML is parsed using C, it should +return a data structure equivalent to the original (see caveats below). + +The C function can also be used to output the XML as SAX events +see the C option and L<"SAX SUPPORT"> for more details). + +When translating hashes to XML, hash keys which have a leading '-' will be +silently skipped. This is the approved method for marking elements of a +data structure which should be ignored by C. (Note: If these items +were not skipped the key names would be emitted as element or attribute names +with a leading '-' which would not be valid XML). + +=head2 Caveats + +Some care is required in creating data structures which will be passed to +C. Hash keys from the data structure will be encoded as either XML +element names or attribute names. Therefore, you should use hash key names +which conform to the relatively strict XML naming rules: + +Names in XML must begin with a letter. The remaining characters may be +letters, digits, hyphens (-), underscores (_) or full stops (.). It is also +allowable to include one colon (:) in an element name but this should only be +used when working with namespaces (B can only usefully work with +namespaces when teamed with a SAX Parser). + +You can use other punctuation characters in hash values (just not in hash +keys) however B does not support dumping binary data. + +If you break these rules, the current implementation of C will +simply emit non-compliant XML which will be rejected if you try to read it +back in. (A later version of B might take a more proactive +approach). + +Note also that although you can nest hashes and arrays to arbitrary levels, +circular data structures are not supported and will cause C to die. + +If you wish to 'round-trip' arbitrary data structures from Perl to XML and back +to Perl, then you should probably disable array folding (using the KeyAttr +option) both with C and with C. If you still don't get the +expected results, you may prefer to use L which is designed for +exactly that purpose. + +Refer to L<"WHERE TO FROM HERE?"> if C is too simple for your needs. + + +=head1 OPTIONS + +B supports a number of options (in fact as each release of +B adds more options, the module's claim to the name 'Simple' +becomes increasingly tenuous). If you find yourself repeatedly having to +specify the same options, you might like to investigate L<"OPTIONAL OO +INTERFACE"> below. + +If you can't be bothered reading the documentation, refer to +L<"STRICT MODE"> to automatically catch common mistakes. + +Because there are so many options, it's hard for new users to know which ones +are important, so here are the two you really need to know about: + +=over 4 + +=item * + +check out C because you'll almost certainly want to turn it on + +=item * + +make sure you know what the C option does and what its default value is +because it may surprise you otherwise (note in particular that 'KeyAttr' +affects both C and C) + +=back + +The option name headings below have a trailing 'comment' - a hash followed by +two pieces of metadata: + +=over 4 + +=item * + +Options are marked with 'I' if they are recognised by C and +'I' if they are recognised by C. + +=item * + +Each option is also flagged to indicate whether it is: + + 'important' - don't use the module until you understand this one + 'handy' - you can skip this on the first time through + 'advanced' - you can skip this on the second time through + 'SAX only' - don't worry about this unless you're using SAX (or + alternatively if you need this, you also need SAX) + 'seldom used' - you'll probably never use this unless you were the + person that requested the feature + +=back + +The options are listed alphabetically: + +Note: option names are no longer case sensitive so you can use the mixed case +versions shown here; all lower case as required by versions 2.03 and earlier; +or you can add underscores between the words (eg: key_attr). + + +=head2 AttrIndent => 1 I<# out - handy> + +When you are using C, enable this option to have attributes printed +one-per-line with sensible indentation rather than all on one line. + +=head2 Cache => [ cache schemes ] I<# in - advanced> + +Because loading the B module and parsing an XML file can consume a +significant number of CPU cycles, it is often desirable to cache the output of +C for later reuse. + +When parsing from a named file, B supports a number of caching +schemes. The 'Cache' option may be used to specify one or more schemes (using +an anonymous array). Each scheme will be tried in turn in the hope of finding +a cached pre-parsed representation of the XML file. If no cached copy is +found, the file will be parsed and the first cache scheme in the list will be +used to save a copy of the results. The following cache schemes have been +implemented: + +=over 4 + +=item storable + +Utilises B to read/write a cache file with the same name as the +XML file but with the extension .stor + +=item memshare + +When a file is first parsed, a copy of the resulting data structure is retained +in memory in the B module's namespace. Subsequent calls to parse +the same file will return a reference to this structure. This cached version +will persist only for the life of the Perl interpreter (which in the case of +mod_perl for example, may be some significant time). + +Because each caller receives a reference to the same data structure, a change +made by one caller will be visible to all. For this reason, the reference +returned should be treated as read-only. + +=item memcopy + +This scheme works identically to 'memshare' (above) except that each caller +receives a reference to a new data structure which is a copy of the cached +version. Copying the data structure will add a little processing overhead, +therefore this scheme should only be used where the caller intends to modify +the data structure (or wishes to protect itself from others who might). This +scheme uses B to perform the copy. + +=back + +Warning! The memory-based caching schemes compare the timestamp on the file to +the time when it was last parsed. If the file is stored on an NFS filesystem +(or other network share) and the clock on the file server is not exactly +synchronised with the clock where your script is run, updates to the source XML +file may appear to be ignored. + +=head2 ContentKey => 'keyname' I<# in+out - seldom used> + +When text content is parsed to a hash value, this option let's you specify a +name for the hash key to override the default 'content'. So for example: + + XMLin('Text', ContentKey => 'text') + +will parse to: + + { 'one' => 1, 'text' => 'Text' } + +instead of: + + { 'one' => 1, 'content' => 'Text' } + +C will also honour the value of this option when converting a hashref +to XML. + +You can also prefix your selected key name with a '-' character to have +C try a little harder to eliminate unnecessary 'content' keys after +array folding. For example: + + XMLin( + 'FirstSecond', + KeyAttr => {item => 'name'}, + ForceArray => [ 'item' ], + ContentKey => '-content' + ) + +will parse to: + + { + 'item' => { + 'one' => 'First' + 'two' => 'Second' + } + } + +rather than this (without the '-'): + + { + 'item' => { + 'one' => { 'content' => 'First' } + 'two' => { 'content' => 'Second' } + } + } + +=head2 DataHandler => code_ref I<# in - SAX only> + +When you use an B object as a SAX handler, it will return a +'simple tree' data structure in the same format as C would return. If +this option is set (to a subroutine reference), then when the tree is built the +subroutine will be called and passed two arguments: a reference to the +B object and a reference to the data tree. The return value from +the subroutine will be returned to the SAX driver. (See L<"SAX SUPPORT"> for +more details). + +=head2 ForceArray => 1 I<# in - important> + +This option should be set to '1' to force nested elements to be represented +as arrays even when there is only one. Eg, with ForceArray enabled, this +XML: + + + value + + +would parse to this: + + { + 'name' => [ + 'value' + ] + } + +instead of this (the default): + + { + 'name' => 'value' + } + +This option is especially useful if the data structure is likely to be written +back out as XML and the default behaviour of rolling single nested elements up +into attributes is not desirable. + +If you are using the array folding feature, you should almost certainly enable +this option. If you do not, single nested elements will not be parsed to +arrays and therefore will not be candidates for folding to a hash. (Given that +the default value of 'KeyAttr' enables array folding, the default value of this +option should probably also have been enabled too - sorry). + +=head2 ForceArray => [ names ] I<# in - important> + +This alternative (and preferred) form of the 'ForceArray' option allows you to +specify a list of element names which should always be forced into an array +representation, rather than the 'all or nothing' approach above. + +It is also possible (since version 2.05) to include compiled regular +expressions in the list - any element names which match the pattern will be +forced to arrays. If the list contains only a single regex, then it is not +necessary to enclose it in an arrayref. Eg: + + ForceArray => qr/_list$/ + +=head2 ForceContent => 1 I<# in - seldom used> + +When C parses elements which have text content as well as attributes, +the text content must be represented as a hash value rather than a simple +scalar. This option allows you to force text content to always parse to +a hash value even when there are no attributes. So for example: + + XMLin('text1text2', ForceContent => 1) + +will parse to: + + { + 'x' => { 'content' => 'text1' }, + 'y' => { 'a' => 2, 'content' => 'text2' } + } + +instead of: + + { + 'x' => 'text1', + 'y' => { 'a' => 2, 'content' => 'text2' } + } + +=head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy> + +You can use this option to eliminate extra levels of indirection in your Perl +data structure. For example this XML: + + + + /usr/bin + /usr/local/bin + /usr/X11/bin + + + +Would normally be read into a structure like this: + + { + searchpath => { + dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ] + } + } + +But when read in with the appropriate value for 'GroupTags': + + my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' }); + +It will return this simpler structure: + + { + searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ] + } + +The grouping element (C<< >> in the example) must not contain any +attributes or elements other than the grouped element. + +You can specify multiple 'grouping element' to 'grouped element' mappings in +the same hashref. If this option is combined with C, the array +folding will occur first and then the grouped element names will be eliminated. + +C will also use the grouptag mappings to re-introduce the tags around +the grouped elements. Beware though that this will occur in all places that +the 'grouping tag' name occurs - you probably don't want to use the same name +for elements as well as attributes. + +=head2 Handler => object_ref I<# out - SAX only> + +Use the 'Handler' option to have C generate SAX events rather than +returning a string of XML. For more details see L<"SAX SUPPORT"> below. + +Note: the current implementation of this option generates a string of XML +and uses a SAX parser to translate it into SAX events. The normal encoding +rules apply here - your data must be UTF8 encoded unless you specify an +alternative encoding via the 'XMLDecl' option; and by the time the data reaches +the handler object, it will be in UTF8 form regardless of the encoding you +supply. A future implementation of this option may generate the events +directly. + +=head2 KeepRoot => 1 I<# in+out - handy> + +In its attempt to return a data structure free of superfluous detail and +unnecessary levels of indirection, C normally discards the root +element name. Setting the 'KeepRoot' option to '1' will cause the root element +name to be retained. So after executing this code: + + $config = XMLin('', KeepRoot => 1) + +You'll be able to reference the tempdir as +C<$config-E{config}-E{tempdir}> instead of the default +C<$config-E{tempdir}>. + +Similarly, setting the 'KeepRoot' option to '1' will tell C that the +data structure already contains a root element name and it is not necessary to +add another. + +=head2 KeyAttr => [ list ] I<# in+out - important> + +This option controls the 'array folding' feature which translates nested +elements from an array to a hash. It also controls the 'unfolding' of hashes +to arrays. + +For example, this XML: + + + + + + +would, by default, parse to this: + + { + 'user' => [ + { + 'login' => 'grep', + 'fullname' => 'Gary R Epstein' + }, + { + 'login' => 'stty', + 'fullname' => 'Simon T Tyson' + } + ] + } + +If the option 'KeyAttr => "login"' were used to specify that the 'login' +attribute is a key, the same XML would parse to: + + { + 'user' => { + 'stty' => { + 'fullname' => 'Simon T Tyson' + }, + 'grep' => { + 'fullname' => 'Gary R Epstein' + } + } + } + +The key attribute names should be supplied in an arrayref if there is more +than one. C will attempt to match attribute names in the order +supplied. C will use the first attribute name supplied when +'unfolding' a hash into an array. + +Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id']. If you do +not want folding on input or unfolding on output you must setting this option +to an empty list to disable the feature. + +Note 2: If you wish to use this option, you should also enable the +C option. Without 'ForceArray', a single nested element will be +rolled up into a scalar rather than an array and therefore will not be folded +(since only arrays get folded). + +=head2 KeyAttr => { list } I<# in+out - important> + +This alternative (and preferred) method of specifiying the key attributes +allows more fine grained control over which elements are folded and on which +attributes. For example the option 'KeyAttr => { package => 'id' } will cause +any package elements to be folded on the 'id' attribute. No other elements +which have an 'id' attribute will be folded at all. + +Note: C will generate a warning (or a fatal error in L<"STRICT MODE">) +if this syntax is used and an element which does not have the specified key +attribute is encountered (eg: a 'package' element without an 'id' attribute, to +use the example above). Warnings will only be generated if B<-w> is in force. + +Two further variations are made possible by prefixing a '+' or a '-' character +to the attribute name: + +The option 'KeyAttr => { user => "+login" }' will cause this XML: + + + + + + +to parse to this data structure: + + { + 'user' => { + 'stty' => { + 'fullname' => 'Simon T Tyson', + 'login' => 'stty' + }, + 'grep' => { + 'fullname' => 'Gary R Epstein', + 'login' => 'grep' + } + } + } + +The '+' indicates that the value of the key attribute should be copied rather +than moved to the folded hash key. + +A '-' prefix would produce this result: + + { + 'user' => { + 'stty' => { + 'fullname' => 'Simon T Tyson', + '-login' => 'stty' + }, + 'grep' => { + 'fullname' => 'Gary R Epstein', + '-login' => 'grep' + } + } + } + +As described earlier, C will ignore hash keys starting with a '-'. + +=head2 NoAttr => 1 I<# in+out - handy> + +When used with C, the generated XML will contain no attributes. +All hash key/values will be represented as nested elements instead. + +When used with C, any attributes in the XML will be ignored. + +=head2 NoEscape => 1 I<# out - seldom used> + +By default, C will translate the characters 'E', 'E', '&' and +'"' to '<', '>', '&' and '"' respectively. Use this option to +suppress escaping (presumably because you've already escaped the data in some +more sophisticated manner). + +=head2 NoIndent => 1 I<# out - seldom used> + +Set this option to 1 to disable C's default 'pretty printing' mode. +With this option enabled, the XML output will all be on one line (unless there +are newlines in the data) - this may be easier for downstream processing. + +=head2 NoSort => 1 I<# out - seldom used> + +Newer versions of XML::Simple sort elements and attributes alphabetically (*), +by default. Enable this option to suppress the sorting - possibly for +backwards compatibility. + +* Actually, sorting is alphabetical but 'key' attribute or element names (as in +'KeyAttr') sort first. Also, when a hash of hashes is 'unfolded', the elements +are sorted alphabetically by the value of the key field. + +=head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy> + +This option controls how whitespace in text content is handled. Recognised +values for the option are: + +=over 4 + +=item * + +0 = (default) whitespace is passed through unaltered (except of course for the +normalisation of whitespace in attribute values which is mandated by the XML +recommendation) + +=item * + +1 = whitespace is normalised in any value used as a hash key (normalising means +removing leading and trailing whitespace and collapsing sequences of whitespace +characters to a single space) + +=item * + +2 = whitespace is normalised in all text content + +=back + +Note: you can spell this option with a 'z' if that is more natural for you. + +=head2 NSExpand => 1 I<# in+out handy - SAX only> + +This option controls namespace expansion - the translation of element and +attribute names of the form 'prefix:name' to '{uri}name'. For example the +element name 'xsl:template' might be expanded to: +'{http://www.w3.org/1999/XSL/Transform}template'. + +By default, C will return element names and attribute names exactly as +they appear in the XML. Setting this option to 1 will cause all element and +attribute names to be expanded to include their namespace prefix. + +I. + +This option also controls whether C performs the reverse translation +from '{uri}name' back to 'prefix:name'. The default is no translation. If +your data contains expanded names, you should set this option to 1 otherwise +C will emit XML which is not well formed. + +I to translate URIs back to prefixes>. + +=head2 NumericEscape => 0 | 1 | 2 I<# out - handy> + +Use this option to have 'high' (non-ASCII) characters in your Perl data +structure converted to numeric entities (eg: €) in the XML output. Three +levels are possible: + +0 - default: no numeric escaping (OK if you're writing out UTF8) + +1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output + +2 - all characters above 0x7F are escaped (good for plain ASCII output) + +=head2 OutputFile => I<# out - handy> + +The default behaviour of C is to return the XML as a string. If you +wish to write the XML to a file, simply supply the filename using the +'OutputFile' option. + +This option also accepts an IO handle object - especially useful in Perl 5.8.0 +and later for output using an encoding other than UTF-8, eg: + + open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!"; + XMLout($ref, OutputFile => $fh); + +Note, XML::Simple does not require that the object you pass in to the +OutputFile option inherits from L - it simply assumes the object +supports a C method. + +=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this> + +I. + +This option allows you to pass parameters to the constructor of the underlying +XML::Parser object (which of course assumes you're not using SAX). + +=head2 RootName => 'string' I<# out - handy> + +By default, when C generates XML, the root element will be named +'opt'. This option allows you to specify an alternative name. + +Specifying either undef or the empty string for the RootName option will +produce XML with no root elements. In most cases the resulting XML fragment +will not be 'well formed' and therefore could not be read back in by C. +Nevertheless, the option has been found to be useful in certain circumstances. + +=head2 SearchPath => [ list ] I<# in - handy> + +If you pass C a filename, but the filename include no directory +component, you can use this option to specify which directories should be +searched to locate the file. You might use this option to search first in the +user's home directory, then in a global directory such as /etc. + +If a filename is provided to C but SearchPath is not defined, the +file is assumed to be in the current directory. + +If the first parameter to C is undefined, the default SearchPath +will contain only the directory in which the script itself is located. +Otherwise the default SearchPath will be empty. + +=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy> + +This option controls what C should do with empty elements (no +attributes and no content). The default behaviour is to represent them as +empty hashes. Setting this option to a true value (eg: 1) will cause empty +elements to be skipped altogether. Setting the option to 'undef' or the empty +string will cause empty elements to be represented as the undefined value or +the empty string respectively. The latter two alternatives are a little +easier to test for in your code than a hash with no keys. + +The option also controls what C does with undefined values. Setting +the option to undef causes undefined values to be output as empty elements +(rather than empty attributes), it also suppresses the generation of warnings +about undefined values. Setting the option to a true value (eg: 1) causes +undefined values to be skipped altogether on output. + +=head2 ValueAttr => [ names ] I<# in - handy> + +Use this option to deal elements which always have a single attribute and no +content. Eg: + + + + + + +Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to: + + { + colour => 'red', + size => 'XXL' + } + +instead of this (the default): + + { + colour => { value => 'red' }, + size => { value => 'XXL' } + } + +Note: This form of the ValueAttr option is not compatible with C - +since the attribute name is discarded at parse time, the original XML cannot be +reconstructed. + +=head2 ValueAttr => { element => attribute, ... } I<# in+out - handy> + +This (preferred) form of the ValueAttr option requires you to specify both +the element and the attribute names. This is not only safer, it also allows +the original XML to be reconstructed by C. + +Note: You probably don't want to use this option and the NoAttr option at the +same time. + +=head2 Variables => { name => value } I<# in - handy> + +This option allows variables in the XML to be expanded when the file is read. +(there is no facility for putting the variable names back if you regenerate +XML using C). + +A 'variable' is any text of the form C<${name}> which occurs in an attribute +value or in the text content of an element. If 'name' matches a key in the +supplied hashref, C<${name}> will be replaced with the corresponding value from +the hashref. If no matching key is found, the variable will not be replaced. +Names must match the regex: C<[\w.]+> (ie: only 'word' characters and dots are +allowed). + +=head2 VarAttr => 'attr_name' I<# in - handy> + +In addition to the variables defined using C, this option allows +variables to be defined in the XML. A variable definition consists of an +element with an attribute called 'attr_name' (the value of the C +option). The value of the attribute will be used as the variable name and the +text content of the element will be used as the value. A variable defined in +this way will override a variable defined using the C option. For +example: + + XMLin( ' + /usr/local/apache + ${prefix} + ${exec_prefix}/bin + ', + VarAttr => 'name', ContentKey => '-content' + ); + +produces the following data structure: + + { + dir => { + prefix => '/usr/local/apache', + exec_prefix => '/usr/local/apache', + bindir => '/usr/local/apache/bin', + } + } + +=head2 XMLDecl => 1 or XMLDecl => 'string' I<# out - handy> + +If you want the output from C to start with the optional XML +declaration, simply set the option to '1'. The default XML declaration is: + + + +If you want some other string (for example to declare an encoding value), set +the value of this option to the complete string you require. + + +=head1 OPTIONAL OO INTERFACE + +The procedural interface is both simple and convenient however there are a +couple of reasons why you might prefer to use the object oriented (OO) +interface: + +=over 4 + +=item * + +to define a set of default values which should be used on all subsequent calls +to C or C + +=item * + +to override methods in B to provide customised behaviour + +=back + +The default values for the options described above are unlikely to suit +everyone. The OO interface allows you to effectively override B's +defaults with your preferred values. It works like this: + +First create an XML::Simple parser object with your preferred defaults: + + my $xs = XML::Simple->new(ForceArray => 1, KeepRoot => 1); + +then call C or C as a method of that object: + + my $ref = $xs->XMLin($xml); + my $xml = $xs->XMLout($ref); + +You can also specify options when you make the method calls and these values +will be merged with the values specified when the object was created. Values +specified in a method call take precedence. + +Note: when called as methods, the C and C routines may be +called as C or C. The method names are aliased so the +only difference is the aesthetics. + +=head2 Parsing Methods + +You can explicitly call one of the following methods rather than rely on the +C method automatically determining whether the target to be parsed is +a string, a file or a filehandle: + +=over 4 + +=item parse_string(text) + +Works exactly like the C method but assumes the first argument is +a string of XML (or a reference to a scalar containing a string of XML). + +=item parse_file(filename) + +Works exactly like the C method but assumes the first argument is +the name of a file containing XML. + +=item parse_fh(file_handle) + +Works exactly like the C method but assumes the first argument is +a filehandle which can be read to get XML. + +=back + +=head2 Hook Methods + +You can make your own class which inherits from XML::Simple and overrides +certain behaviours. The following methods may provide useful 'hooks' upon +which to hang your modified behaviour. You may find other undocumented methods +by examining the source, but those may be subject to change in future releases. + +=over 4 + +=item handle_options(direction, name => value ...) + +This method will be called when one of the parsing methods or the C +method is called. The initial argument will be a string (either 'in' or 'out') +and the remaining arguments will be name value pairs. + +=item default_config_file() + +Calculates and returns the name of the file which should be parsed if no +filename is passed to C (default: C<$0.xml>). + +=item build_simple_tree(filename, string) + +Called from C or any of the parsing methods. Takes either a file name +as the first argument or C followed by a 'string' as the second +argument. Returns a simple tree data structure. You could override this +method to apply your own transformations before the data structure is returned +to the caller. + +=item new_hashref() + +When the 'simple tree' data structure is being built, this method will be +called to create any required anonymous hashrefs. + +=item sorted_keys(name, hashref) + +Called when C is translating a hashref to XML. This routine returns +a list of hash keys in the order that the corresponding attributes/elements +should appear in the output. + +=item escape_value(string) + +Called from C, takes a string and returns a copy of the string with +XML character escaping rules applied. + +=item numeric_escape(string) + +Called from C, to handle non-ASCII characters (depending on the +value of the NumericEscape option). + +=item copy_hash(hashref, extra_key => value, ...) + +Called from C, when 'unfolding' a hash of hashes into an array of +hashes. You might wish to override this method if you're using tied hashes and +don't want them to get untied. + +=back + +=head2 Cache Methods + +XML::Simple implements three caching schemes ('storable', 'memshare' and +'memcopy'). You can implement a custom caching scheme by implementing +two methods - one for reading from the cache and one for writing to it. + +For example, you might implement a new 'dbm' scheme that stores cached data +structures using the L module. First, you would add a +C method which accepted a filename for use as a lookup key +and returned a data structure on success, or undef on failure. Then, you would +implement a C method which accepted a data structure and a +filename. + +You would use this caching scheme by specifying the option: + + Cache => [ 'dbm' ] + +=head1 STRICT MODE + +If you import the B routines like this: + + use XML::Simple qw(:strict); + +the following common mistakes will be detected and treated as fatal errors + +=over 4 + +=item * + +Failing to explicitly set the C option - if you can't be bothered +reading about this option, turn it off with: KeyAttr => [ ] + +=item * + +Failing to explicitly set the C option - if you can't be bothered +reading about this option, set it to the safest mode with: ForceArray => 1 + +=item * + +Setting ForceArray to an array, but failing to list all the elements from the +KeyAttr hash. + +=item * + +Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains +one or more EpartE elements without a 'partnum' attribute (or nested +element). Note: if strict mode is not set but -w is, this condition triggers a +warning. + +=item * + +Data error - as above, but non-unique values are present in the key attribute +(eg: more than one EpartE element with the same partnum). This will +also trigger a warning if strict mode is not enabled. + +=item * + +Data error - as above, but value of key attribute (eg: partnum) is not a +scalar string (due to nested elements etc). This will also trigger a warning +if strict mode is not enabled. + +=back + +=head1 SAX SUPPORT + +From version 1.08_01, B includes support for SAX (the Simple API +for XML) - specifically SAX2. + +In a typical SAX application, an XML parser (or SAX 'driver') module generates +SAX events (start of element, character data, end of element, etc) as it parses +an XML document and a 'handler' module processes the events to extract the +required data. This simple model allows for some interesting and powerful +possibilities: + +=over 4 + +=item * + +Applications written to the SAX API can extract data from huge XML documents +without the memory overheads of a DOM or tree API. + +=item * + +The SAX API allows for plug and play interchange of parser modules without +having to change your code to fit a new module's API. A number of SAX parsers +are available with capabilities ranging from extreme portability to blazing +performance. + +=item * + +A SAX 'filter' module can implement both a handler interface for receiving +data and a generator interface for passing modified data on to a downstream +handler. Filters can be chained together in 'pipelines'. + +=item * + +One filter module might split a data stream to direct data to two or more +downstream handlers. + +=item * + +Generating SAX events is not the exclusive preserve of XML parsing modules. +For example, a module might extract data from a relational database using DBI +and pass it on to a SAX pipeline for filtering and formatting. + +=back + +B can operate at either end of a SAX pipeline. For example, +you can take a data structure in the form of a hashref and pass it into a +SAX pipeline using the 'Handler' option on C: + + use XML::Simple; + use Some::SAX::Filter; + use XML::SAX::Writer; + + my $ref = { + .... # your data here + }; + + my $writer = XML::SAX::Writer->new(); + my $filter = Some::SAX::Filter->new(Handler => $writer); + my $simple = XML::Simple->new(Handler => $filter); + $simple->XMLout($ref); + +You can also put B at the opposite end of the pipeline to take +advantage of the simple 'tree' data structure once the relevant data has been +isolated through filtering: + + use XML::SAX; + use Some::SAX::Filter; + use XML::Simple; + + my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']); + my $filter = Some::SAX::Filter->new(Handler => $simple); + my $parser = XML::SAX::ParserFactory->parser(Handler => $filter); + + my $ref = $parser->parse_uri('some_huge_file.xml'); + + print $ref->{part}->{'555-1234'}; + +You can build a filter by using an XML::Simple object as a handler and setting +its DataHandler option to point to a routine which takes the resulting tree, +modifies it and sends it off as SAX events to a downstream handler: + + my $writer = XML::SAX::Writer->new(); + my $filter = XML::Simple->new( + DataHandler => sub { + my $simple = shift; + my $data = shift; + + # Modify $data here + + $simple->XMLout($data, Handler => $writer); + } + ); + my $parser = XML::SAX::ParserFactory->parser(Handler => $filter); + + $parser->parse_uri($filename); + +I but it could also have been specified in the constructor>. + +=head1 ENVIRONMENT + +If you don't care which parser module B uses then skip this +section entirely (it looks more complicated than it really is). + +B will default to using a B parser if one is available or +B if SAX is not available. + +You can dictate which parser module is used by setting either the environment +variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable +$XML::Simple::PREFERRED_PARSER to contain the module name. The following rules +are used: + +=over 4 + +=item * + +The package variable takes precedence over the environment variable if both are defined. To force B to ignore the environment settings and use +its default rules, you can set the package variable to an empty string. + +=item * + +If the 'preferred parser' is set to the string 'XML::Parser', then +L will be used (or C will die if L is not +installed). + +=item * + +If the 'preferred parser' is set to some other value, then it is assumed to be +the name of a SAX parser module and is passed to L +If L is not installed, or the requested parser module is not +installed, then C will die. + +=item * + +If the 'preferred parser' is not defined at all (the normal default +state), an attempt will be made to load L. If L is +installed, then a parser module will be selected according to +L's normal rules (which typically means the last SAX +parser installed). + +=item * + +if the 'preferred parser' is not defined and B is not +installed, then B will be used. C will die if +L is not installed. + +=back + +Note: The B distribution includes an XML parser written entirely in +Perl. It is very portable but it is not very fast. You should consider +installing L or L if they are available for your +platform. + +=head1 ERROR HANDLING + +The XML standard is very clear on the issue of non-compliant documents. An +error in parsing any single element (for example a missing end tag) must cause +the whole document to be rejected. B will die with an appropriate +message if it encounters a parsing error. + +If dying is not appropriate for your application, you should arrange to call +C in an eval block and look for errors in $@. eg: + + my $config = eval { XMLin() }; + PopUpMessage($@) if($@); + +Note, there is a common misconception that use of B will significantly +slow down a script. While that may be true when the code being eval'd is in a +string, it is not true of code like the sample above. + +=head1 EXAMPLES + +When C reads the following very simple piece of XML: + + + +it returns the following data structure: + + { + 'username' => 'testuser', + 'password' => 'frodo' + } + +The identical result could have been produced with this alternative XML: + + + +Or this (although see 'ForceArray' option for variations): + + + testuser + frodo + + +Repeated nested elements are represented as anonymous arrays: + + + + joe@smith.com + jsmith@yahoo.com + + + bob@smith.com + + + + { + 'person' => [ + { + 'email' => [ + 'joe@smith.com', + 'jsmith@yahoo.com' + ], + 'firstname' => 'Joe', + 'lastname' => 'Smith' + }, + { + 'email' => 'bob@smith.com', + 'firstname' => 'Bob', + 'lastname' => 'Smith' + } + ] + } + +Nested elements with a recognised key attribute are transformed (folded) from +an array into a hash keyed on the value of that attribute (see the C +option): + + + + + + + + { + 'person' => { + 'jbloggs' => { + 'firstname' => 'Joe', + 'lastname' => 'Bloggs' + }, + 'tsmith' => { + 'firstname' => 'Tom', + 'lastname' => 'Smith' + }, + 'jsmith' => { + 'firstname' => 'Joe', + 'lastname' => 'Smith' + } + } + } + + +The tag can be used to form anonymous arrays: + + + Col 1Col 2Col 3 + R1C1R1C2R1C3 + R2C1R2C2R2C3 + R3C1R3C2R3C3 + + + { + 'head' => [ + [ 'Col 1', 'Col 2', 'Col 3' ] + ], + 'data' => [ + [ 'R1C1', 'R1C2', 'R1C3' ], + [ 'R2C1', 'R2C2', 'R2C3' ], + [ 'R3C1', 'R3C2', 'R3C3' ] + ] + } + +Anonymous arrays can be nested to arbirtrary levels and as a special case, if +the surrounding tags for an XML document contain only an anonymous array the +arrayref will be returned directly rather than the usual hashref: + + + Col 1Col 2 + R1C1R1C2 + R2C1R2C2 + + + [ + [ 'Col 1', 'Col 2' ], + [ 'R1C1', 'R1C2' ], + [ 'R2C1', 'R2C2' ] + ] + +Elements which only contain text content will simply be represented as a +scalar. Where an element has both attributes and text content, the element +will be represented as a hashref with the text content in the 'content' key +(see the C option): + + + first + second + + + { + 'one' => 'first', + 'two' => { 'attr' => 'value', 'content' => 'second' } + } + +Mixed content (elements which contain both text content and nested elements) +will be not be represented in a useful way - element order and significant +whitespace will be lost. If you need to work with mixed content, then +XML::Simple is not the right tool for your job - check out the next section. + +=head1 WHERE TO FROM HERE? + +B is able to present a simple API because it makes some +assumptions on your behalf. These include: + +=over 4 + +=item * + +You're not interested in text content consisting only of whitespace + +=item * + +You don't mind that when things get slurped into a hash the order is lost + +=item * + +You don't want fine-grained control of the formatting of generated XML + +=item * + +You would never use a hash key that was not a legal XML element name + +=item * + +You don't need help converting between different encodings + +=back + +In a serious XML project, you'll probably outgrow these assumptions fairly +quickly. This section of the document used to offer some advice on chosing a +more powerful option. That advice has now grown into the 'Perl-XML FAQ' +document which you can find at: L + +The advice in the FAQ boils down to a quick explanation of tree versus +event based parsers and then recommends: + +For event based parsing, use SAX (do not set out to write any new code for +XML::Parser's handler API - it is obselete). + +For tree-based parsing, you could choose between the 'Perlish' approach of +L and more standards based DOM implementations - preferably one with +XPath support. + + +=head1 SEE ALSO + +B requires either L or L. + +To generate documents with namespaces, L is required. + +The optional caching functions require L. + +Answers to Frequently Asked Questions about XML::Simple are bundled with this +distribution as: L + +=head1 COPYRIGHT + +Copyright 1999-2004 Grant McLean Egrantm@cpan.orgE + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + + diff --git a/lib/XML/Simple/FAQ.pod b/lib/XML/Simple/FAQ.pod new file mode 100644 index 0000000..0aa52e8 --- /dev/null +++ b/lib/XML/Simple/FAQ.pod @@ -0,0 +1,646 @@ +package XML::Simple::FAQ; +1; + +__END__ + +=head1 Frequently Asked Questions about XML::Simple + + +=head1 Basics + + +=head2 What is XML::Simple designed to be used for? + +XML::Simple is a Perl module that was originally developed as a tool for +reading and writing configuration data in XML format. You can use it for +many other purposes that involve storing and retrieving structured data in +XML. + +You might also find XML::Simple a good starting point for playing with XML +from Perl. It doesn't have a steep learning curve and if you outgrow its +capabilities there are plenty of other Perl/XML modules to 'step up' to. + + +=head2 Why store configuration data in XML anyway? + +The many advantages of using XML format for configuration data include: + +=over 4 + +=item * + +Using existing XML parsing tools requires less development time, is easier +and more robust than developing your own config file parsing code + +=item * + +XML can represent relationships between pieces of data, such as nesting of +sections to arbitrary levels (not easily done with .INI files for example) + +=item * + +XML is basically just text, so you can easily edit a config file (easier than +editing a Win32 registry) + +=item * + +XML provides standard solutions for handling character sets and encoding +beyond basic ASCII (important for internationalization) + +=item * + +If it becomes necessary to change your configuration file format, there are +many tools available for performing transformations on XML files + +=item * + +XML is an open standard (the world does not need more proprietary binary +file formats) + +=item * + +Taking the extra step of developing a DTD allows the format of configuration +files to be validated before your program reads them (not directly supported +by XML::Simple) + +=item * + +Combining a DTD with a good XML editor can give you a GUI config editor for +minimal coding effort + +=back + + +=head2 What isn't XML::Simple good for? + +The main limitation of XML::Simple is that it does not work with 'mixed +content' (see the next question). If you consider your XML files contain +marked up text rather than structured data, you should probably use another +module. + +If you are working with very large XML files, XML::Simple's approach of +representing the whole file in memory as a 'tree' data structure may not be +suitable. + + +=head2 What is mixed content? + +Consider this example XML: + + + This is mixed content. + + +This is said to be mixed content, because the EparaE element contains +both character data (text content) and nested elements. + +Here's some more XML: + + + Joe + Bloggs + 25-April-1969 + + +This second example is not generally considered to be mixed content. The +Efirst_nameE, Elast_nameE and EdobE elements contain +only character data and the EpersonE element contains only nested +elements. (Note: Strictly speaking, the whitespace between the nested +elements is character data, but it is ignored by XML::Simple). + + +=head2 Why doesn't XML::Simple handle mixed content? + +Because if it did, it would no longer be simple :-) + +Seriously though, there are plenty of excellent modules that allow you to +work with mixed content in a variety of ways. Handling mixed content +correctly is not easy and by ignoring these issues, XML::Simple is able to +present an API without a steep learning curve. + + +=head2 Which Perl modules do handle mixed content? + +Every one of them except XML::Simple :-) + +If you're looking for a recommendation, I'd suggest you look at the Perl-XML +FAQ at: + + http://perl-xml.sourceforge.net/faq/ + + +=head1 Installation + + +=head2 How do I install XML::Simple? + +If you're running ActiveState Perl, you've probably already got XML::Simple +(although you may want to upgrade to version 1.09 or better for SAX support). + +If you do need to install XML::Simple, you'll need to install an XML parser +module first. Install either XML::Parser (which you may have already) or +XML::SAX. If you install both, XML::SAX will be used by default. + +Once you have a parser installed ... + +On Unix systems, try: + + perl -MCPAN -e 'install XML::Simple' + +If that doesn't work, download the latest distribution from +ftp://ftp.cpan.org/pub/CPAN/authors/id/G/GR/GRANTM , unpack it and run these +commands: + + perl Makefile.PL + make + make test + make install + +On Win32, if you have a recent build of ActiveState Perl (618 or better) try +this command: + + ppm install XML::Simple + +If that doesn't work, you really only need the Simple.pm file, so extract it +from the .tar.gz file (eg: using WinZIP) and save it in the \site\lib\XML +directory under your Perl installation (typically C:\Perl). + + +=head2 I'm trying to install XML::Simple and 'make test' fails + +Is the directory where you've unpacked XML::Simple mounted from a file server +using NFS, SMB or some other network file sharing? If so, that may cause +errors in the the following test scripts: + + 3_Storable.t + 4_MemShare.t + 5_MemCopy.t + +The test suite is designed to exercise the boundary conditions of all +XML::Simple's functionality and these three scripts exercise the caching +functions. If XML::Simple is asked to parse a file for which it has a cached +copy of a previous parse, then it compares the timestamp on the XML file with +the timestamp on the cached copy. If the cached copy is *newer* then it will +be used. If the cached copy is older or the same age then the file is +re-parsed. The test scripts will get confused by networked filesystems if +the workstation and server system clocks are not synchronised (to the +second). + +If you get an error in one of these three test scripts but you don't plan to +use the caching options (they're not enabled by default), then go right ahead +and run 'make install'. If you do plan to use caching, then try unpacking +the distribution on local disk and doing the build/test there. + +It's probably not a good idea to use the caching options with networked +filesystems in production. If the file server's clock is ahead of the local +clock, XML::Simple will re-parse files when it could have used the cached +copy. However if the local clock is ahead of the file server clock and a +file is changed immediately after it is cached, the old cached copy will be +used. + +Is one of the three test scripts (above) failing but you're not running on +a network filesystem? Are you running Win32? If so, you may be seeing a bug +in Win32 where writes to a file do not affect its modfication timestamp. + +If none of these scenarios match your situation, please confirm you're +running the latest version of XML::Simple and then email the output of +'make test' to me at grantm@cpan.org + +=head2 Why is XML::Simple so slow? + +If you find that XML::Simple is very slow reading XML, the most likely reason +is that you have XML::SAX installed but no additional SAX parser module. The +XML::SAX distribution includes an XML parser written entirely in Perl. This is +very portable but not very fast. For better performance install either +XML::SAX::Expat or XML::LibXML. + + +=head1 Usage + +=head2 How do I use XML::Simple? + +If you had an XML document called /etc/appconfig/foo.xml you could 'slurp' it +into a simple data structure (typically a hashref) with these lines of code: + + use XML::Simple; + + my $config = XMLin('/etc/appconfig/foo.xml'); + +The XMLin() function accepts options after the filename. + + +=head2 There are so many options, which ones do I really need to know about? + +Although you can get by without using any options, you shouldn't even +consider using XML::Simple in production until you know what these two +options do: + +=over 4 + +=item * + +forcearray + +=item * + +keyattr + +=back + +The reason you really need to read about them is because the default values +for these options will trip you up if you don't. Although everyone agrees +that these defaults are not ideal, there is not wide agreement on what they +should be changed to. The answer therefore is to read about them (see below) +and select values which are right for you. + + +=head2 What is the forcearray option all about? + +Consider this XML in a file called ./person.xml: + + + Joe + Bloggs + bungy jumping + sky diving + knitting + + +You could read it in with this line: + + my $person = XMLin('./person.xml'); + +Which would give you a data structure like this: + + $person = { + 'first_name' => 'Joe', + 'last_name' => 'Bloggs', + 'hobbie' => [ 'bungy jumping', 'sky diving', 'knitting' ] + }; + +The Efirst_nameE and Elast_nameE elements are represented as +simple scalar values which you could refer to like this: + + print "$person->{first_name} $person->{last_name}\n"; + +The EhobbieE elements are represented as an array - since there is +more than one. You could refer to the first one like this: + + print $person->{hobbie}->[0], "\n"; + +Or the whole lot like this: + + print join(', ', @{$person->{hobbie}} ), "\n"; + +The catch is, that these last two lines of code will only work for people +who have more than one hobbie. If there is only one EhobbieE +element, it will be represented as a simple scalar (just like +Efirst_nameE and Elast_nameE). Which might lead you to write +code like this: + + if(ref($person->{hobbie})) { + print join(', ', @{$person->{hobbie}} ), "\n"; + } + else { + print $person->{hobbie}, "\n"; + } + +Don't do that. + +One alternative approach is to set the forcearray option to a true value: + + my $person = XMLin('./person.xml', forcearray => 1); + +Which will give you a data structure like this: + + $person = { + 'first_name' => [ 'Joe' ], + 'last_name' => [ 'Bloggs' ], + 'hobbie' => [ 'bungy jumping', 'sky diving', 'knitting' ] + }; + +Then you can use this line to refer to all the list of hobbies even if there +was only one: + + print join(', ', @{$person->{hobbie}} ), "\n"; + +The downside of this approach is that the Efirst_nameE and +Elast_nameE elements will also always be represented as arrays even +though there will never be more than one: + + print "$person->{first_name}->[0] $person->{last_name}->[0]\n"; + +This might be OK if you change the XML to use attributes for things that +will always be singular and nested elements for things that may be plural: + + + motorcycle maintenance + + +On the other hand, if you prefer not to use attributes, then you could +specify that any EhobbieE elements should always be represented as +arrays and all other nested elements should be simple scalar values unless +there is more than one: + + my $person = XMLin('./person.xml', forcearray => [ 'hobbie' ]); + +The forcearray option accepts a list of element names which should always +be forced to an array representation: + + forcearray => [ qw(hobbie qualification childs_name) ] + +See the XML::Simple manual page for more information. + + +=head2 What is the keyattr option all about? + +Consider this sample XML: + + + + + + + +You could slurp it in with this code: + + my $catalog = XMLin('./catalog.xml'); + +Which would return a data structure like this: + + $catalog = { + 'part' => [ + { + 'partnum' => '1842334', + 'desc' => 'High pressure flange', + 'price' => '24.50' + }, + { + 'partnum' => '9344675', + 'desc' => 'Threaded gasket', + 'price' => '9.25' + }, + { + 'partnum' => '5634896', + 'desc' => 'Low voltage washer', + 'price' => '12.00' + } + ] + }; + +Then you could access the description of the first part in the catalog +with this code: + + print $catalog->{part}->[0]->{desc}, "\n"; + +However, if you wanted to access the description of the part with the +part number of "9344675" then you'd have to code a loop like this: + + foreach my $part (@{$catalog->{part}}) { + if($part->{partnum} eq '9344675') { + print $part->{desc}, "\n"; + last; + } + } + +The knowledge that each EpartE element has a unique partnum attribute +allows you to eliminate this search. You can pass this knowledge on to +XML::Simple like this: + + my $catalog = XMLin($xml, keyattr => ['partnum']); + +Which will return a data structure like this: + + $catalog = { + 'part' => { + '5634896' => { 'desc' => 'Low voltage washer', 'price' => '12.00' }, + '1842334' => { 'desc' => 'High pressure flange', 'price' => '24.50' }, + '9344675' => { 'desc' => 'Threaded gasket', 'price' => '9.25' } + } + }; + +XML::Simple has been able to transform $catalog->{part} from an arrayref to +a hashref (keyed on partnum). This transformation is called 'array folding'. + +Through the use of array folding, you can now index directly to the +description of the part you want: + + print $catalog->{part}->{9344675}->{desc}, "\n"; + +The 'keyattr' option also enables array folding when the unique key is in a +nested element rather than an attribute. eg: + + + + 1842334 + High pressure flange + 24.50 + + + 9344675 + Threaded gasket + 9.25 + + + 5634896 + Low voltage washer + 12.00 + + + +See the XML::Simple manual page for more information. + + +=head2 So what's the catch with 'keyattr'? + +One thing to watch out for is that you might get array folding even if you +don't supply the keyattr option. The default value for this option is: + + [ 'name', 'key', 'id'] + +Which means if your XML elements have a 'name', 'key' or 'id' attribute (or +nested element) then they may get folded on those values. This means that +you can take advantage of array folding simply through careful choice of +attribute names. On the hand, if you really don't want array folding at all, +you'll need to set 'key attr to an empty list: + + my $ref = XMLin($xml, keyattr => []); + +A second 'gotcha' is that array folding only works on arrays. That might +seem obvious, but if there's only one record in your XML and you didn't set +the 'forcearray' option then it won't be represented as an array and +consequently won't get folded into a hash. The moral is that if you're +using array folding, you should always turn on the forcearray option. + +You probably want to be as specific as you can be too. For instance, the +safest way to parse the EcatalogE example above would be: + + my $catalog = XMLin($xml, keyattr => { part => 'partnum'}, + forcearray => ['part']); + +By using the hashref for keyattr, you can specify that only EpartE +elements should be folded on the 'partnum' attribute (and that the +EpartE elements should not be folded on any other attribute). + +By supplying a list of element names for forcearray, you're ensuring that +folding will work even if there's only one EpartE. You're also +ensuring that if the 'partnum' unique key is supplied in a nested element +then that element won't get forced to an array too. + + +=head2 How do I know what my data structure should look like? + +The rules are fairly straightforward: + +=over 4 + +=item * + +each element gets represented as a hash + +=item * + +unless it contains only text, in which case it'll be a simple scalar value + +=item * + +or unless there's more than one element with the same name, in which case +they'll be represented as an array + +=item * + +unless you've got array folding enabled, in which case they'll be folded into +a hash + +=item * + +empty elements (no text contents B no attributes) will either be +represented as an empty hash, an empty string or undef - depending on the value +of the 'suppressempty' option. + +=back + +If you're in any doubt, use Data::Dumper, eg: + + use XML::Simple; + use Data::Dumper; + + my $ref = XMLin($xml); + + print Dumper($ref); + + +=head2 I'm getting 'Use of uninitialized value' warnings + +You're probably trying to index into a non-existant hash key - try +Data::Dumper. + + +=head2 I'm getting a 'Not an ARRAY reference' error + +Something that you expect to be an array is not. The two most likely causes +are that you forgot to use 'forcearray' or that the array got folded into a +hash - try Data::Dumper. + + +=head2 I'm getting a 'No such array field' error + +Something that you expect to be a hash is actually an array. Perhaps array +folding failed because one element was missing the key attribute - try +Data::Dumper. + + +=head2 I'm getting an 'Out of memory' error + +Something in the data structure is not as you expect and Perl may be trying +unsuccessfully to autovivify things - try Data::Dumper. + +If you're already using Data::Dumper, try calling Dumper() immediately after +XMLin() - ie: before you attempt to access anything in the data structure. + + +=head2 My element order is getting jumbled up + +If you read an XML file with XMLin() and then write it back out with +XMLout(), the order of the elements will likely be different. (However, if +you read the file back in with XMLin() you'll get the same Perl data +structure). + +The reordering happens because XML::Simple uses hashrefs to store your data +and Perl hashes do not really have any order. + +It is possible that a future version of XML::Simple will use Tie::IxHash +to store the data in hashrefs which do retain the order. However this will +not fix all cases of element order being lost. + +If your application really is sensitive to element order, don't use +XML::Simple (and don't put order-sensitive values in attributes). + + +=head2 XML::Simple turns nested elements into attributes + +If you read an XML file with XMLin() and then write it back out with +XMLout(), some data which was originally stored in nested elements may end up +in attributes. (However, if you read the file back in with XMLin() you'll +get the same Perl data structure). + +There are a number of ways you might handle this: + +=over 4 + +=item * + +use the 'forcearray' option with XMLin() + +=item * + +use the 'noattr' option with XMLout() + +=item * + +live with it + +=item * + +don't use XML::Simple + +=back + + +=head2 Why does XMLout() insert EnameE elements (or attributes)? + +Try setting keyattr => []. + +When you call XMLin() to read XML, the 'keyattr' option controls whether arrays +get 'folded' into hashes. Similarly, when you call XMLout(), the 'keyattr' +option controls whether hashes get 'unfolded' into arrays. As described above, +'keyattr' is enabled by default. + +=head2 Why are empty elements represented as empty hashes? + +An element is always represented as a hash unless it contains only text, in +which case it is represented as a scalar string. + +If you would prefer empty elements to be represented as empty strings or the +undefined value, set the 'suppressempty' option to '' or undef respectively. + +=head2 Why is ParserOpts deprecated? + +The C option is a remnant of the time when XML::Simple only worked +with the XML::Parser API. Its value is completely ignored if you're using a +SAX parser, so writing code which relied on it would bar you from taking +advantage of SAX. + +Even if you are using XML::Parser, it is seldom necessary to pass options to +the parser object. A number of people have written to say they use this option +to set XML::Parser's C option. Don't do that, it's wrong, +Wrong, WRONG! Fix the XML document so that it's well-formed and you won't have +a problem. + +Having said all of that, as long as XML::Simple continues to support the +XML::Parser API, this option will not be removed. There are currently no plans +to remove support for the XML::Parser API. + +=cut + + diff --git a/maketest b/maketest new file mode 100644 index 0000000..8e644ab --- /dev/null +++ b/maketest @@ -0,0 +1,92 @@ +#!perl -w +############################################################################# +# +# If your platform/installation does not support make test, you can try this: +# +# perl maketest +# +############################################################################# + +use strict; +use File::Spec; +use Test::Harness qw(&runtests $verbose); + +$verbose = 0; + + +############################################################################# +# Are we in the right directory? If not, the pathname component of $0 +# must be pointing to it or we wouldn't be running this script. +# + +unless(-f 'MANIFEST') { + my($script_name, $script_dir) = File::Basename::fileparse($0); + if($script_dir) { + chdir($script_dir) || die "chdir($script_dir): $!"; + } +} + + +############################################################################# +# Confirm distribution is complete (read MANIFEST file without assuming it +# has been converted to platform's native text format). +# Build up a list of test files as we go. +# + +my @tests = (); +{ + open(MNFST, 'MANIFEST') || die "open(MANIFEST): $!"; + local($/) = undef; + foreach(split(/[\r\n]+/, )) { + next unless(/\S/); + my $src_file = File::Spec->catfile(split('/')); + (-f $src_file ) || die "Could not find expected file: $src_file"; + push @tests, $src_file if($src_file =~ /^t\b.*\.t$/); + } + close(MNFST); +} + +print "XML::Distribution appears complete\n"; + + +############################################################################# +# Build and populate what we need of blib (the build library) +# + +my $path = 'blib'; +(-d $path) || mkdir($path, 0777) || die "mkdir($path): $!"; + +$path = File::Spec->catdir($path, 'lib'); +(-d $path) || mkdir($path, 0777) || die "mkdir($path): $!"; + +$path = File::Spec->catdir($path, 'XML'); +(-d $path) || mkdir($path, 0777) || die "mkdir($path): $!"; + +$path = File::Spec->catfile($path, 'Simple.pm'); +unless(-f $path) { + open(MOD, 'Simple.pm') || die "open(Simple.pm): $!"; + { + local($/) = undef; + my $module = ; + close(MOD); + open(MOD, ">$path") || die "open($path): $!"; + print MOD $module; + close(MOD); + } + print "Created $path\n"; +} + + +############################################################################# +# Run the tests +# + +print "Running tests...\n"; + +unshift @INC, 'blib/lib'; + +@tests = @ARGV if(@ARGV); + +runtests @tests; + + diff --git a/t/0_Config.t b/t/0_Config.t new file mode 100644 index 0000000..ebb0377 --- /dev/null +++ b/t/0_Config.t @@ -0,0 +1,64 @@ +# $Id: 0_Config.t,v 1.6 2003/05/20 08:50:10 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More tests => 1; + + +# Build up a list of installed modules + +my @mod_list = qw(XML::Simple Storable XML::Parser XML::SAX); + + +# If XML::SAX is installed, add a list of installed SAX parsers + +eval " use XML::SAX; "; +my $default_parser = ''; +unless($@) { + push @mod_list, 'XML::NamespaceSupport'; + push @mod_list, map { $_->{Name} } @{XML::SAX->parsers()}; + $default_parser = ref(XML::SAX::ParserFactory->parser()); +} + + +# Extract the version number from each module + +my(%version); +foreach my $module (@mod_list) { + eval " require $module; "; + unless($@) { + no strict 'refs'; + $version{$module} = ${$module . '::VERSION'} || "Unknown"; + } +} + +$default_parser = 'XML::Parser' if(!$default_parser && $version{'XML::Parser'}); + + +# Add version number of the Perl binary + +eval ' use Config; $version{perl} = $Config{version} '; # Should never fail +if($@) { + $version{perl} = $]; +} +unshift @mod_list, 'perl'; + + +# Check for preferred parser via environment setting + +my $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || ' '; + + +# Print details of installed modules on STDERR + +diag(sprintf("\r# %-30s %s\n", 'Package', 'Version')); +foreach my $module (@mod_list) { + $version{$module} = 'Not Installed' unless(defined($version{$module})); + $version{$module} .= " (default parser)" if($module eq $default_parser); + $version{$module} .= " (preferred parser)" if($module eq $preferred_parser); + diag(sprintf(" %-30s %s\n", $module, $version{$module})); +} + +# Housekeeping + +ok(1, "Dumped config"); diff --git a/t/1_XMLin.t b/t/1_XMLin.t new file mode 100644 index 0000000..b5b6d03 --- /dev/null +++ b/t/1_XMLin.t @@ -0,0 +1,1509 @@ +# $Id: 1_XMLin.t,v 1.28 2007/08/15 10:36:48 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use IO::File; +use File::Spec; + +$^W = 1; + + +# Initialise filenames and check they're there + +my $XMLFile = File::Spec->catfile('t', 'test1.xml'); # t/test1.xml + +unless(-e $XMLFile) { + plan skip_all => 'Test data missing'; +} + +plan tests => 131; + + +my $last_warning = ''; + +$@ = ''; +eval "use XML::Simple;"; +is($@, '', 'Module compiled OK'); +my $version = 'unknown'; +if(open my $chg, ') { + last if ($version) = $_ =~ /^([\d\._]+) /; + } + close($chg); +} +unless($XML::Simple::VERSION eq $version) { + diag("Warning: XML::Simple::VERSION = $XML::Simple::VERSION (Changes version: $version)"); +} + + +# Start by parsing an extremely simple piece of XML + +my $opt = XMLin(q()); + +my $expected = { + name1 => 'value1', + name2 => 'value2', + }; + +ok(1, "XMLin() didn't crash"); +ok(defined($opt), 'and it returned a value'); +is(ref($opt), 'HASH', 'and a hasref at that'); +is_deeply($opt, $expected, 'matches expectations (attributes)'); + + +# Now try a slightly more complex one that returns the same value + +$opt = XMLin(q( + + value1 + value2 + +)); +is_deeply($opt, $expected, 'same again with nested elements'); + + +# And something else that returns the same (line break included to pick up +# missing /s bug) + +$opt = XMLin(q()); +is_deeply($opt, $expected, 'attributes in empty element'); + + +# Try something with two lists of nested values + +$opt = XMLin(q( + + value1.1 + value1.2 + value1.3 + value2.1 + value2.2 + value2.3 + ) +); + +is_deeply($opt, { + name1 => [ 'value1.1', 'value1.2', 'value1.3' ], + name2 => [ 'value2.1', 'value2.2', 'value2.3' ], +}, 'repeated child elements give arrays of scalars'); + + +# Now a simple nested hash + +$opt = XMLin(q( + + + ) +); + +is_deeply($opt, { + item => { name1 => 'value1', name2 => 'value2' } +}, 'nested element gives hash'); + + +# Now a list of nested hashes + +$opt = XMLin(q( + + + + ) +); +is_deeply($opt, { + item => [ + { name1 => 'value1', name2 => 'value2' }, + { name1 => 'value3', name2 => 'value4' } + ] +}, 'repeated child elements give list of hashes'); + + +# Now a list of nested hashes transformed into a hash using default key names + +my $string = q( + + + + +); +my $target = { + item => { + item1 => { attr1 => 'value1', attr2 => 'value2' }, + item2 => { attr1 => 'value3', attr2 => 'value4' } + } +}; +$opt = XMLin($string); +is_deeply($opt, $target, "array folded on default key 'name'"); + + +# Same thing left as an array by suppressing default key names + +$target = { + item => [ + {name => 'item1', attr1 => 'value1', attr2 => 'value2' }, + {name => 'item2', attr1 => 'value3', attr2 => 'value4' } + ] +}; +my @cont_key = (contentkey => '-content'); +$opt = XMLin($string, keyattr => [], @cont_key); +is_deeply($opt, $target, 'not folded when keyattr turned off'); + + +# Same again with alternative key suppression + +$opt = XMLin($string, keyattr => {}, @cont_key); +is_deeply($opt, $target, 'still works when keyattr is empty hash'); + + +# Try the other two default key attribute names + +$opt = XMLin(q( + + + + +), @cont_key); +is_deeply($opt, { + item => { + item1 => { attr1 => 'value1', attr2 => 'value2' }, + item2 => { attr1 => 'value3', attr2 => 'value4' } + } +}, "folded on default key 'key'"); + + +$opt = XMLin(q( + + + + +), @cont_key); +is_deeply($opt, { + item => { + item1 => { attr1 => 'value1', attr2 => 'value2' }, + item2 => { attr1 => 'value3', attr2 => 'value4' } + } +}, "folded on default key 'id'"); + + +# Similar thing using non-standard key names + +my $xml = q( + + + + ); + +$target = { + item => { + item1 => { attr1 => 'value1', attr2 => 'value2' }, + item2 => { attr1 => 'value3', attr2 => 'value4' } + } +}; + +$opt = XMLin($xml, keyattr => [qw(xname)], @cont_key); +is_deeply($opt, $target, "folded on non-default key 'xname'"); + + +# And with precise element/key specification + +$opt = XMLin($xml, keyattr => { 'item' => 'xname' }, @cont_key); +is_deeply($opt, $target, 'same again but keyattr set with hash'); + + +# Same again but with key field further down the list + +$opt = XMLin($xml, keyattr => [qw(wibble xname)], @cont_key); +is_deeply($opt, $target, 'keyattr as array with value in second position'); + + +# Same again but with key field supplied as scalar + +$opt = XMLin($xml, keyattr => qw(xname), @cont_key); +is_deeply($opt, $target, 'keyattr as scalar'); + + +# Same again but with mixed-case option name + +$opt = XMLin($xml, KeyAttr => qw(xname), @cont_key); +is_deeply($opt, $target, 'KeyAttr as scalar'); + + +# Same again but with underscores in option name + +$opt = XMLin($xml, key_attr => qw(xname), @cont_key); +is_deeply($opt, $target, 'key_attr as scalar'); + + +# Weird variation, not exactly what we wanted but it is what we expected +# given the current implementation and we don't want to break it accidently + +$xml = q( + + + + + +); + +$target = { item => { + 'three' => { 'value' => 3 }, + 'a' => { 'value' => 1, 'id' => 'one' }, + 'two' => { 'value' => 2 } + } +}; + +$opt = XMLin($xml, @cont_key); +is_deeply($opt, $target, 'fold same array on two different keys'); + + +# Or somewhat more as one might expect + +$target = { item => { + 'one' => { 'value' => '1', 'name' => 'a' }, + 'two' => { 'value' => '2' }, + 'three' => { 'value' => '3' }, + } +}; +$opt = XMLin($xml, keyattr => { 'item' => 'id' }, @cont_key); +is_deeply($opt, $target, 'same again but with priority switch'); + + +# Now a somewhat more complex test of targetting folding + +$xml = q( + + + + + + +); + +$target = { + 'car' => { + 'LW1804' => { + 'id' => 2, + 'make' => 'GM', + 'option' => { + '9926543-1167' => { 'key' => 1, 'desc' => 'Steering Wheel' } + } + }, + 'SH6673' => { + 'id' => 1, + 'make' => 'Ford', + 'option' => { + '6389733317-12' => { 'key' => 1, 'desc' => 'Electric Windows' }, + '3735498158-01' => { 'key' => 2, 'desc' => 'Leather Seats' }, + '5776155953-25' => { 'key' => 3, 'desc' => 'Sun Roof' } + } + } + } +}; + +$opt = XMLin($xml, forcearray => 1, + keyattr => { 'car' => 'license', 'option' => 'pn' }, @cont_key); +is_deeply($opt, $target, 'folded on multi-key keyattr hash'); + + +# Now try leaving the keys in place + +$target = { + 'car' => { + 'LW1804' => { + 'id' => 2, + 'make' => 'GM', + 'option' => { + '9926543-1167' => { 'key' => 1, 'desc' => 'Steering Wheel', + '-pn' => '9926543-1167' } + }, + license => 'LW1804' + }, + 'SH6673' => { + 'id' => 1, + 'make' => 'Ford', + 'option' => { + '6389733317-12' => { 'key' => 1, 'desc' => 'Electric Windows', + '-pn' => '6389733317-12' }, + '3735498158-01' => { 'key' => 2, 'desc' => 'Leather Seats', + '-pn' => '3735498158-01' }, + '5776155953-25' => { 'key' => 3, 'desc' => 'Sun Roof', + '-pn' => '5776155953-25' } + }, + license => 'SH6673' + } + } +}; +$opt = XMLin($xml, forcearray => 1, keyattr => { 'car' => '+license', 'option' => '-pn' }, @cont_key); +is_deeply($opt, $target, "same again but with '+' prefix to copy keys"); + + +# Confirm the stringifying references bug is fixed + +$xml = q( + + + Bob + 21 + + + Kate + 22 + + ); + +$target = { + item => [ + { age => '21', name => { firstname => 'Bob'} }, + { age => '22', name => { firstname => 'Kate'} }, + ] +}; + +{ + local($SIG{__WARN__}) = \&warn_handler; + + $last_warning = ''; + $opt = XMLin($xml, @cont_key); + is_deeply($opt, $target, "did not fold on default key with non-scalar value"); + is($last_warning, '', 'no warning issued'); + + $last_warning = ''; + $opt = XMLin($xml, keyattr => { item => 'name' }, @cont_key); + is_deeply($opt, $target, "did not fold on specific key with non-scalar value"); + isnt($last_warning, '', 'warning issued as expected'); + like($last_warning, + qr{ element has non-scalar 'name' key attribute}, + 'text in warning is correct' + ); + + $last_warning = ''; + $opt = XMLin($xml, keyattr => [ 'name' ], @cont_key); + is_deeply($opt, $target, "same again but with keyattr as array"); + isnt($last_warning, '', 'warning issued as expected'); + like($last_warning, + qr{ element has non-scalar 'name' key attribute}, + 'text in warning is correct' + ); + + $last_warning = ''; + local($^W) = 0; + $opt = XMLin($xml, keyattr => { item => 'name' }, @cont_key); + is_deeply($opt, $target, "did not fold on specific key with non-scalar value"); + is($last_warning, '', 'no warning issued (as expected)'); + + $last_warning = ''; + $^W = 1; + my $xitems = q( + red + heavy + ornery + ); + my $items = { + 'item' => [ + { 'name' => 'color', 'content' => 'red', }, + { 'name' => 'mass', 'content' => 'heavy', }, + { 'nime' => 'disposition', 'content' => 'ornery', } + ] + }; + $opt = XMLin($xitems, keyattr => { item => 'name' }, @cont_key); + is_deeply($opt, $items, "did not fold when element missing key attribute"); + like($last_warning, qr{Warning: element has no 'name' key attribute}, + 'expected warning issued'); + + $last_warning = ''; + $^W = 0; + $opt = XMLin($xitems, keyattr => { item => 'name' }, @cont_key); + is_deeply($opt, $items, "same again"); + is($last_warning, '', 'but with no warning this time'); + + $last_warning = ''; + $^W = 1; + $xitems = q( + red + heavy + ornery + green + ); + $items = { + 'item' => { + 'color' => 'green', + 'mass' => 'heavy', + 'disposition' => 'ornery', + } + }; + $opt = XMLin($xitems, keyattr => { item => 'name' }, @cont_key); + is_deeply($opt, $items, "folded elements despite non-unique key attribute"); + like($last_warning, qr{Warning: element has non-unique value in 'name' key attribute: color}, + 'expected warning issued'); + + $last_warning = ''; + $opt = XMLin($xitems, keyattr => [ 'name' ], @cont_key); + is_deeply($opt, $items, "same again but with keyattr as array"); + like($last_warning, qr{Warning: element has non-unique value in 'name' key attribute: color}, + 'expected warning issued'); + + $last_warning = ''; + $^W = 0; + $opt = XMLin($xitems, keyattr => { item => 'name' }, @cont_key); + is_deeply($opt, $items, "same again"); + is($last_warning, '', 'but with no warning this time'); +} + + +# Make sure that the root element name is preserved if we ask for it + +$target = XMLin("$xml", forcearray => 1, + keyattr => { 'car' => '+license', 'option' => '-pn' }, + @cont_key); + +$opt = XMLin( $xml, forcearray => 1, keeproot => 1, + keyattr => { 'car' => '+license', 'option' => '-pn' }, + @cont_key); + +is_deeply($opt, $target, 'keeproot option works'); + + +# confirm that CDATA sections parse correctly + +$xml = q{Hello, world!]]>}; +$opt = XMLin($xml, @cont_key); +is_deeply($opt, { + 'cdata' => 'Hello, world!' +}, 'CDATA section parsed correctly'); + +$xml = q{one]]>two]]>}; +$opt = XMLin($xml, @cont_key); +is_deeply($opt, { + 'x' => 'onetwo' +}, 'CDATA section containing markup characters parsed correctly'); + + +# Try parsing a named external file + +$@ = ''; +$opt = eval{ XMLin($XMLFile); }; +is($@, '', "XMLin didn't choke on named external file"); +is_deeply($opt, { + location => 't/test1.xml' +}, 'and contents parsed as expected'); + + +# Try parsing default external file (scriptname.xml in script directory) + +$@ = ''; +$opt = eval { XMLin(); }; +is($@, '', "XMLin didn't choke on un-named (default) external file"); +is_deeply($opt, { + location => 't/1_XMLin.xml' +}, 'and contents parsed as expected'); + + +# Try parsing named file in a directory in the searchpath + +$@ = ''; +$opt = eval { + XMLin('test2.xml', searchpath => [ + 'dir1', 'dir2', File::Spec->catdir('t', 'subdir'), @cont_key + ] ); + +}; +is($@, '', 'XMLin found file using searchpath'); +is_deeply($opt, { + location => 't/subdir/test2.xml' +}, 'and contents parsed as expected'); + + +# Ensure we get expected result if file does not exist + +$@ = ''; +$opt = undef; +$opt = eval { + XMLin('bogusfile.xml', searchpath => 't' ); # should 'die' +}; +is($opt, undef, 'XMLin choked on nonexistant file'); +like($@, qr/Could not find bogusfile.xml in/, 'with the expected message'); + + +# same again, but with no searchpath + +$@ = ''; +$opt = undef; +$opt = eval { XMLin('bogusfile.xml'); }; +is($opt, undef, 'nonexistant file not found in current directory'); +like($@, qr/File does not exist: bogusfile.xml/, 'with the expected message'); + + +# Confirm searchpath is ignored if filename includes directory component + +$@ = ''; +$opt = undef; +$opt = eval { + XMLin(File::Spec->catfile('subdir', 'test2.xml'), searchpath => 't' ); +}; +is($opt, undef, 'search path ignored when pathname supplied'); + + +# Try parsing from an IO::Handle + +$@ = ''; +my $fh = new IO::File; +$XMLFile = File::Spec->catfile('t', '1_XMLin.xml'); # t/1_XMLin.xml +eval { + $fh->open($XMLFile) || die "$!"; + $opt = XMLin($fh, @cont_key); +}; +is($@, '', "XMLin didn't choke on an IO::File object"); +is($opt->{location}, 't/1_XMLin.xml', 'and it parsed the right file'); + + +# Try parsing from STDIN + +close(STDIN); +$@ = ''; +eval { + open(STDIN, $XMLFile) || die "$!"; + $opt = XMLin('-'); +}; +is($@, '', "XMLin didn't choke on STDIN ('-')"); +is($opt->{location}, 't/1_XMLin.xml', 'and data parsed correctly'); + + +# Confirm anonymous array handling works in general + +$xml = q{ + + + 0.00.10.2 + + + 1.01.11.2 + + + 2.02.12.2 + + +}; + +$expected = { + row => [ + [ '0.0', '0.1', '0.2' ], + [ '1.0', '1.1', '1.2' ], + [ '2.0', '2.1', '2.2' ] + ] +}; + +$opt = XMLin($xml, @cont_key); +is_deeply($opt, $expected, 'anonymous arrays parsed correctly'); + +# Confirm it still works with array folding disabled (was a bug) + +$opt = XMLin($xml, keyattr => [], @cont_key); +is_deeply($opt, $expected, 'anonymous arrays parsed correctly'); + + +# Confirm anonymous array handling works in special top level case + +$opt = XMLin(q{ + + one + two + three + +}, @cont_key); +is_deeply($opt, [ + qw(one two three) +], 'top level anonymous array returned arrayref'); + + +$opt = XMLin(q( + + 1 + + 2.1 + + 2.2.1 + 2.2.2 + + + +), @cont_key); +is_deeply($opt, [ + 1, + [ + '2.1', [ '2.2.1', '2.2.2'] + ] +], 'nested anonymous arrays parsed correctly'); + + +# Check for the dreaded 'content' attribute + +$xml = q( + + text + +); + +$opt = XMLin($xml); +is_deeply($opt, { + item => { + content => 'text', + attr => 'value' + } +}, "'content' key appears as expected"); + + +# And check that we can change its name if required + +$opt = XMLin($xml, contentkey => 'text_content'); +is_deeply($opt, { + item => { + text_content => 'text', + attr => 'value' + } +}, "'content' key successfully renamed to 'text'"); + + +# Check that it doesn't get screwed up by forcearray option + +$xml = q(text content); + +$opt = XMLin($xml, forcearray => 1); +is_deeply($opt, { + 'attr' => 'value', + 'content' => 'text content' +}, "'content' key not munged by forcearray"); + + +# Test that we can force all text content to parse to hash values + +$xml = q(text1text2); +$opt = XMLin($xml, forcecontent => 1); +is_deeply($opt, { + 'x' => { 'content' => 'text1' }, + 'y' => { 'a' => 2, 'content' => 'text2' } +}, 'gratuitous use of content key works as expected'); + + +# And that this is compatible with changing the key name + +$opt = XMLin($xml, forcecontent => 1, contentkey => '0'); +is_deeply($opt, { + 'x' => { 0 => 'text1' }, + 'y' => { 'a' => 2, 0 => 'text2' } +}, "even when we change it's name to 'text'"); + + +# Confirm that spurious 'content' keys are *not* eliminated after array folding + +$xml = q(FirstSecond); +$opt = XMLin($xml, forcearray => [ 'x' ], keyattr => {x => 'y'}); +is_deeply($opt, { + x => { + one => { content => 'First' }, + two => { content => 'Second' }, + } +}, "spurious content keys not eliminated after folding"); + + +# unless we ask nicely + +$xml = q(FirstSecond); +$opt = XMLin( + $xml, forcearray => [ 'x' ], keyattr => {x => 'y'}, contentkey => '-content' +); +is_deeply($opt, { + x => { + one => 'First', + two => 'Second', + } +}, "spurious content keys not eliminated after folding"); + + +# Check that mixed content parses in the weird way we expect + +$xml = q( + Text with a bold word + Mixed but no attributes +); + +is_deeply(XMLin($xml, @cont_key), { + 'p1' => { + 'content' => [ 'Text with a ', ' word' ], + 'class' => 'mixed', + 'b' => 'bold' + }, + 'p2' => { + 'content' => [ 'Mixed ', ' no attributes' ], + 'b' => 'but' + } +}, "mixed content doesn't work - no surprises there"); + + +# Confirm single nested element rolls up into a scalar attribute value + +$string = q( + + value + +); +$opt = XMLin($string); +is_deeply($opt, { + name => 'value' +}, 'nested element rolls up to scalar'); + + +# Unless 'forcearray' option is specified + +$opt = XMLin($string, forcearray => 1, @cont_key); +is_deeply($opt, { + name => [ 'value' ] +}, 'except when forcearray is enabled'); + + +# Confirm array folding of single nested hash + +$string = q( + +); + +$opt = XMLin($string, forcearray => 1, @cont_key); +is_deeply($opt, { + 'inner' => { 'one' => { 'value' => 1 } } +}, 'array folding works with single nested hash'); + + +# But not without forcearray option specified + +$opt = XMLin($string, forcearray => 0, @cont_key); +is_deeply($opt, { + 'inner' => { 'name' => 'one', 'value' => 1 } +}, 'but not if forcearray is turned off'); + + +# Test advanced features of forcearray + +$xml = q( + i + ii + iii + 3 + c + +); + +$opt = XMLin($xml, forcearray => [ 'two' ], @cont_key); +is_deeply($opt, { + 'zero' => '0', + 'one' => 'i', + 'two' => [ 'ii' ], + 'three' => [ 'iii', 3, 'c' ] +}, 'selective application of forcearray successful'); + + +# Test forcearray regexes + +$xml = q( + i + ii + iii + iv + v + +); + +$opt = XMLin($xml, forcearray => [ qr/^f/, 'two', qr/n/ ], @cont_key); +is_deeply($opt, { + 'zero' => '0', + 'one' => [ 'i' ], + 'two' => [ 'ii' ], + 'three' => 'iii', + 'four' => [ 'iv' ], + 'five' => [ 'v' ], +}, 'forcearray using regex successful'); + + +# Same again but a single regexp rather than in an arrayref + +$opt = XMLin($xml, forcearray => qr/^f|e$/, @cont_key); +is_deeply($opt, { + 'zero' => '0', + 'one' => [ 'i' ], + 'two' => 'ii', + 'three' => [ 'iii'], + 'four' => [ 'iv' ], + 'five' => [ 'v' ], +}, 'forcearray using a single regex successful'); + + +# Test 'noattr' option + +$xml = q( + text + +); + +$opt = XMLin($xml, noattr => 1, @cont_key); +is_deeply($opt, { nest => 'text' }, 'attributes successfully skipped'); + + +# And make sure it doesn't screw up array folding + +$xml = q{ + aalpha + bbeta + ggamma + +}; + + +$opt = XMLin($xml, noattr => 1, @cont_key); +is_deeply($opt, { + 'item' => { + 'a' => { 'value' => 'alpha' }, + 'b' => { 'value' => 'beta' }, + 'g' => { 'value' => 'gamma' } + } +}, 'noattr does not intefere with array folding'); + + +# Confirm empty elements parse to empty hashrefs + +$xml = q( + bob + + + + +); + +$opt = XMLin($xml, noattr => 1, @cont_key); +is_deeply($opt, { + 'name' => 'bob', + 'outer' => { + 'inner1' => {}, + 'inner2' => {} + } +}, 'empty elements parse to hashrefs'); + + +# Unless 'suppressempty' is enabled + +$opt = XMLin($xml, noattr => 1, suppressempty => 1, @cont_key); +is_deeply($opt, { 'name' => 'bob', }, 'or are suppressed'); + + +# Check behaviour when 'suppressempty' is set to to undef; + +$opt = XMLin($xml, noattr => 1, suppressempty => undef, @cont_key); +is_deeply($opt, { + 'name' => 'bob', + 'outer' => { + 'inner1' => undef, + 'inner2' => undef + } +}, "or parse to 'undef'"); + +# Check behaviour when 'suppressempty' is set to to empty string; + +$opt = XMLin($xml, noattr => 1, suppressempty => '', @cont_key); +is_deeply($opt, { + 'name' => 'bob', + 'outer' => { + 'inner1' => '', + 'inner2' => '' + } +}, 'or parse to an empty string'); + +# Confirm completely empty XML parses to undef with 'suppressempty' + +$xml = q( + + + + +); + +$opt = XMLin($xml, noattr => 1, suppressempty => 1, @cont_key); +is($opt, undef, 'empty document parses to undef'); + + +# Confirm nothing magical happens with grouped elements + +$xml = q( + before + + /usr/bin + /usr/local/bin + + after +); + +$opt = XMLin($xml); +is_deeply($opt, { + prefix => 'before', + dirs => { + dir => [ '/usr/bin', '/usr/local/bin' ] + }, + suffix => 'after', +}, 'grouped tags parse normally'); + + +# unless we specify how the grouping works + +$xml = q( + before + + /usr/bin + /usr/local/bin + + after +); + +$opt = XMLin($xml, grouptags => {dirs => 'dir'} ); +is_deeply($opt, { + prefix => 'before', + dirs => [ '/usr/bin', '/usr/local/bin' ], + suffix => 'after', +}, 'disintermediation of grouped tags works'); + + +# try again with multiple groupings + +$xml = q( + before + + /usr/bin + /usr/local/bin + + between + + vt100 + xterm + + after +); + +$opt = XMLin($xml, grouptags => {dirs => 'dir', terms => 'term'} ); +is_deeply($opt, { + prefix => 'before', + dirs => [ '/usr/bin', '/usr/local/bin' ], + infix => 'between', + terms => [ 'vt100', 'xterm' ], + suffix => 'after', +}, 'disintermediation works with multiple groups'); + + +# confirm folding and ungrouping work together + +$xml = q( + before + + /usr/bin + /usr/local/bin + + after +); + +$opt = XMLin($xml, keyattr => {dir => 'name'}, grouptags => {dirs => 'dir'} ); +is_deeply($opt, { + prefix => 'before', + dirs => { + first => { content => '/usr/bin' }, + second => { content => '/usr/local/bin' }, + }, + suffix => 'after', +}, 'folding and ungrouping work together'); + + +# confirm folding, ungrouping and content stripping work together + +$xml = q( + before + + /usr/bin + /usr/local/bin + + after +); + +$opt = XMLin($xml, + contentkey => '-text', + keyattr => {dir => 'name'}, + grouptags => {dirs => 'dir'} +); +is_deeply($opt, { + prefix => 'before', + dirs => { + first => '/usr/bin', + second => '/usr/local/bin', + }, + suffix => 'after', +}, 'folding, ungrouping and content stripping work together'); + + +# confirm folding fails as expected even with ungrouping but (no forcearray) + +$xml = q( + before + + /usr/bin + + after +); + +$opt = XMLin($xml, + contentkey => '-text', + keyattr => {dir => 'name'}, + grouptags => {dirs => 'dir'} +); +is_deeply($opt, { + prefix => 'before', + dirs => { name => 'first', text => '/usr/bin'}, + suffix => 'after', +}, 'folding without forcearray but with ungrouping fails as expected'); + + +# but works with forcearray enabled + +$xml = q( + before + + /usr/bin + + after +); + +$opt = XMLin($xml, + contentkey => '-text', + forcearray => [ 'dir' ], + keyattr => {dir => 'name'}, + grouptags => {dirs => 'dir'} +); +is_deeply($opt, { + prefix => 'before', + dirs => {'first' => '/usr/bin'}, + suffix => 'after', +}, 'folding with forcearray and ungrouping works'); + + +# Test variable expansion - when no variables are defined + +$xml = q( + ${conf_dir}/appname.conf + ${log_dir}/appname.log + ${log_dir}/appname.dbg + + +); + +$opt = XMLin($xml, contentkey => '-content'); +is_deeply($opt, { + file => { + config_file => '${conf_dir}/appname.conf', + log_file => '${log_dir}/appname.log', + debug_file => '${log_dir}/appname.dbg', + }, + opt => { docs => '${have_docs}' }, + bogus => { value => '${undef}' } +}, 'undefined variables are left untouched'); + + +# try again but with variables defined in advance + +$opt = XMLin($xml, + contentkey => '-content', + variables => { conf_dir => '/etc', log_dir => '/var/log', + have_docs => 'true' } +); +is_deeply($opt, { + file => { + config_file => '/etc/appname.conf', + log_file => '/var/log/appname.log', + debug_file => '/var/log/appname.dbg', + }, + opt => { docs => 'true' }, + bogus => { value => '${undef}' } +}, 'substitution of pre-defined variables works'); + + +# now try defining them in the XML + +$xml = q( + /etc + /var/log + false + search.perl.org + bogus + ${conf_dir}/appname.conf + ${log_dir}/appname.log + ${log_dir}/appname.dbg + ${bad/name} + + +); + +$opt = XMLin($xml, contentkey => '-content', varattr => 'xsvar'); +is_deeply($opt, { + file => { + config_file => '/etc/appname.conf', + log_file => '/var/log/appname.log', + debug_file => '/var/log/appname.dbg', + bogus_file => '${bad/name}', # '/' is not valid in a var name + }, + opt => { docs => 'false' }, + site => { url => 'http://search.perl.org/' }, + dir => [ + { xsvar => 'conf_dir', content => '/etc' }, + { xsvar => 'log_dir', content => '/var/log' }, + ], + cfg => [ + { xsvar => 'have_docs', content => 'false' }, + { xsvar => 'host.domain', content => 'search.perl.org' }, + { xsvar => 'bad/name', content => 'bogus' }, + ], +}, 'variables defined in XML work'); + + +# confirm that variables in XML are merged with pre-defined ones + +$xml = q( + /var/log + ${conf_dir}/appname.conf + ${log_dir}/appname.log + ${log_dir}/appname.dbg +); + +$opt = XMLin($xml, + contentkey => '-content', + varattr => 'xsvar', + variables => { conf_dir => '/etc', log_dir => '/tmp' } +); +is_deeply($opt, { + file => { + config_file => '/etc/appname.conf', + log_file => '/var/log/appname.log', + debug_file => '/var/log/appname.dbg', + }, + dir => { xsvar => 'log_dir', content => '/var/log' }, +}, 'variables defined in XML merged successfully with predefined vars'); + + +# confirm that a variables are expanded in variable definitions + +$xml = q( + + /usr/local/apache + ${prefix} + ${exec_prefix}/bin + +); + +$opt = XMLin($xml, + contentkey => '-content', + varattr => 'name', + grouptags => { dirs => 'dir' }, +); +is_deeply($opt, { + dirs => { + prefix => '/usr/local/apache', + exec_prefix => '/usr/local/apache', + bin_dir => '/usr/local/apache/bin', + } +}, 'variables are expanded in later variable definitions'); + + +# Confirm only a hash is acceptable to grouptags and variables + +$@ = ''; +$_ = eval { $opt = XMLin($xml, grouptags => [ 'dir' ]); }; +ok(!defined($_), 'grouptags requires a hash'); +like($@, qr/Illegal value for 'GroupTags' option - expected a hashref/, +'with correct error message'); + +$@ = ''; +$_ = eval { $opt = XMLin($xml, variables => [ 'dir' ]); }; +ok(!defined($_), 'variables requires a hash'); +like($@, qr/Illegal value for 'Variables' option - expected a hashref/, +'with correct error message'); + + +# Try to disintermediate on the wrong child key + +$xml = q( + before + + /usr/bin + /usr/local/bin + + after +); + +$opt = XMLin($xml, grouptags => {dirs => 'dir'} ); +is_deeply($opt, { + prefix => 'before', + dirs => { lib => [ '/usr/bin', '/usr/local/bin' ] }, + suffix => 'after', +}, 'disintermediation using wrong child key - as expected'); + + +# Test option error handling + +$@=''; +$_ = eval { XMLin('', rootname => 'fred') }; # not valid for XMLin() +is($_, undef, 'invalid options are trapped'); +like($@, qr/Unrecognised option:/, 'with correct error message'); + +$@=''; +$_ = eval { XMLin('', 'searchpath') }; +is($_, undef, 'invalid number of options are trapped'); +like($@, qr/Options must be name=>value pairs \(odd number supplied\)/, +'with correct error message'); + + +# Test the NormaliseSpace option + +$xml = q( + + + Jane + Doe + + three + four + + +); + +$opt = XMLin($xml, KeyAttr => [ 'name' ], NormaliseSpace => 1); +ok(ref($opt->{user}) eq 'HASH', "NS-1: folding OK"); +ok(exists($opt->{user}->{'Joe Bloggs'}), "NS-2: space normalised in hash key"); +ok(exists($opt->{user}->{'Jane Doe'}), "NS-3: space normalised in hash key"); +like($opt->{user}->{'Jane Doe'}->{id}, qr{^\s\s+three\s\s+four\s\s+$}s, + "NS-4: space not normalised in hash value"); + +$opt = XMLin($xml, KeyAttr => { user => 'name' }, NormaliseSpace => 1); +ok(ref($opt->{user}) eq 'HASH', "NS-1a: folding OK"); +ok(exists($opt->{user}->{'Joe Bloggs'}), "NS-2a: space normalised in hash key"); +ok(exists($opt->{user}->{'Jane Doe'}), "NS-3a: space normalised in hash key"); +like($opt->{user}->{'Jane Doe'}->{id}, qr{^\s\s+three\s\s+four\s\s+$}s, + "NS-4a: space not normalised in hash value"); + +$opt = XMLin($xml, KeyAttr => [ 'name' ], NormaliseSpace => 2); +ok(ref($opt->{user}) eq 'HASH', "NS-5: folding OK"); +ok(exists($opt->{user}->{'Joe Bloggs'}), "NS-6: space normalised in hash key"); +like($opt->{user}->{'Joe Bloggs'}->{id}, qr{^one\stwo$}s, + "NS-7: space normalised in attribute value"); +ok(exists($opt->{user}->{'Jane Doe'}), "NS-8: space normalised in hash key"); +like($opt->{user}->{'Jane Doe'}->{id}, qr{^three\sfour$}s, + "NS-9: space normalised in element text content"); + +# confirm NormaliseSpace works in anonymous arrays too + +$xml = q( + one two three + four five six seveneightnine +); + +$opt = XMLin($xml, NormaliseSpace => 2); +is_deeply($opt, [ 'one two', 'three four five', 'six', 'seveneightnine' ], + "NS-10: space normalised in anonymous array"); + +# Check that American speeling works too + +$opt = XMLin($xml, NormalizeSpace => 2); +is_deeply($opt, [ 'one two', 'three four five', 'six', 'seveneightnine' ], + "NS-11: space normalized in anonymous array"); + +# Check that attributes called 'value' are not special + +$xml = q( + + + + +); + +$opt = XMLin($xml); + +is_deeply($opt, { + 'today' => { value => "today.png" }, + 'nav-prev' => { value => "prev.png" }, + 'nav-home' => { value => "home.png" }, + 'nav-next' => { value => "next.png" }, +}, "Nothing special about 'value' attributes"); + +# Now turn on the ValueAttr option and try again + +$opt = XMLin($xml, ValueAttr => [ 'value' ]); + +is_deeply($opt, { + 'today' => "today.png", + 'nav-prev' => "prev.png", + 'nav-home' => "home.png", + 'nav-next' => "next.png", +}, "ValueAttr as arrayref works"); + +# Try with a list of different ValueAttr names + +$xml = q( + + + + +); + +$opt = XMLin($xml, ValueAttr => [ qw(xxx yyy zzz) ]); + +is_deeply($opt, { + 'today' => "today.png", + 'nav-prev' => "prev.png", + 'nav-home' => "home.png", + 'nav-next' => { value => "next.png" }, +}, "ValueAttr as arrayref works"); + +# Try specifying ValueAttr as a hashref + +$xml = q( + + + + +); + +$opt = XMLin($xml, + ValueAttr => { + 'today' => 'xxx', + 'nav-home' => 'yyy', + 'nav-next' => 'value' + } +); + +is_deeply($opt, { + 'today' => "today.png", + 'nav-prev' => { value => "prev.png" }, + 'nav-home' => "home.png", + 'nav-next' => "next.png", +}, "ValueAttr as hashref works too"); + +# Confirm that there's no conflict with KeyAttr or ContentKey defaults + +$xml = q( + + + + red +); + +$opt = XMLin($xml, ValueAttr => { 'today' => 'value' }); + +is_deeply($opt, { + today => 'today.png', + animal => { + lion => { age => 7 }, + elephant => { age => 97 }, + }, + colour => { rgb => '#FF0000', content => 'red' }, +}, "ValueAttr as hashref works too"); + +# Now for a 'real world' test, try slurping in an SRT config file + +$opt = XMLin(File::Spec->catfile('t', 'srt.xml'), + forcearray => 1, @cont_key +); +$target = { + 'global' => [ + { + 'proxypswd' => 'bar', + 'proxyuser' => 'foo', + 'exclude' => [ + '/_vt', + '/save\\b', + '\\.bak$', + '\\.\\$\\$\\$$' + ], + 'httpproxy' => 'http://10.1.1.5:8080/', + 'tempdir' => 'C:/Temp' + } + ], + 'pubpath' => { + 'test1' => { + 'source' => [ + { + 'label' => 'web_source', + 'root' => 'C:/webshare/web_source' + } + ], + 'title' => 'web_source -> web_target1', + 'package' => { + 'images' => { 'dir' => 'wwwroot/images' } + }, + 'target' => [ + { + 'label' => 'web_target1', + 'root' => 'C:/webshare/web_target1', + 'temp' => 'C:/webshare/web_target1/temp' + } + ], + 'dir' => [ 'wwwroot' ] + }, + 'test2' => { + 'source' => [ + { + 'label' => 'web_source', + 'root' => 'C:/webshare/web_source' + } + ], + 'title' => 'web_source -> web_target1 & web_target2', + 'package' => { + 'bios' => { 'dir' => 'wwwroot/staff/bios' }, + 'images' => { 'dir' => 'wwwroot/images' }, + 'templates' => { 'dir' => 'wwwroot/templates' } + }, + 'target' => [ + { + 'label' => 'web_target1', + 'root' => 'C:/webshare/web_target1', + 'temp' => 'C:/webshare/web_target1/temp' + }, + { + 'label' => 'web_target2', + 'root' => 'C:/webshare/web_target2', + 'temp' => 'C:/webshare/web_target2/temp' + } + ], + 'dir' => [ 'wwwroot' ] + }, + 'test3' => { + 'source' => [ + { + 'label' => 'web_source', + 'root' => 'C:/webshare/web_source' + } + ], + 'title' => 'web_source -> web_target1 via HTTP', + 'addexclude' => [ '\\.pdf$' ], + 'target' => [ + { + 'label' => 'web_target1', + 'root' => 'http://127.0.0.1/cgi-bin/srt_slave.plx', + 'noproxy' => 1 + } + ], + 'dir' => [ 'wwwroot' ] + } + } +}; +is_deeply($opt, $target, 'successfully read an SRT config file'); + + +exit(0); + + +sub warn_handler { + $last_warning = $_[0]; +} diff --git a/t/1_XMLin.xml b/t/1_XMLin.xml new file mode 100644 index 0000000..637b39a --- /dev/null +++ b/t/1_XMLin.xml @@ -0,0 +1 @@ + diff --git a/t/2_XMLout.t b/t/2_XMLout.t new file mode 100644 index 0000000..6d7fdf9 --- /dev/null +++ b/t/2_XMLout.t @@ -0,0 +1,1214 @@ +# $Id: 2_XMLout.t,v 1.17 2006/10/05 08:28:05 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; + +$^W = 1; + +plan tests => 201; + + +############################################################################## +# S U P P O R T R O U T I N E S +############################################################################## + +############################################################################## +# Read file and return contents as a scalar. +# + +sub ReadFile { + local($/) = undef; + + open(_READ_FILE_, $_[0]) || die "open($_[0]): $!"; + my $data = <_READ_FILE_>; + close(_READ_FILE_); + return($data); +} + +use XML::Simple; + +# Confirm error when mandatory parameter missing + +$_ = eval { + XMLout(); +}; +ok(!defined($_), 'call with no args proves fatal'); +like($@, qr/XMLout\(\) requires at least one argument/, +'with correct error message'); + +# Try encoding a scalar value + +my $xml = XMLout("scalar"); +ok(1, 'XMLout did not crash'); +ok(defined($xml), 'and it returned an XML string'); +is(XMLin($xml), 'scalar', 'which parses back OK'); + + +# Next try encoding a hash + +my $hashref1 = { one => 1, two => 'II', three => '...' }; +my $hashref2 = { one => 1, two => 'II', three => '...' }; + +# Expect: +# + +$_ = XMLout($hashref1); +is_deeply(XMLin($_), $hashref1, 'encoded a hash'); +ok(s/one="1"//, 'first key encoded OK'); +ok(s/two="II"//, 'second key encoded OK'); +ok(s/three="..."//, 'third key encoded OK'); +like($_, qr/^<\w+\s+\/>/, 'no other attributes encoded'); + + +# Now try encoding a hash with a nested array + +my $ref = {array => [qw(one two three)]}; +# Expect: +# +# one +# two +# three +# + +$_ = XMLout($ref); +is_deeply(XMLin($_), $ref, 'encoded a hash with nested array'); +ok(s{one\s* + two\s* + three}{}sx, 'array elements encoded in correct order'); +like($_, qr/^<(\w+)\s*>\s*<\/\1>\s*$/s, 'no other spurious encodings'); + + +# Now try encoding a nested hash + +$ref = { value => '555 1234', + hash1 => { one => 1 }, + hash2 => { two => 2 } }; +# Expect: +# +# +# +# + +$_ = XMLout($ref); +is_deeply(XMLin($_), $ref, 'encoded nested hashes'); + +ok(s{\s*}{}s, 'nested hash 1 ok'); +ok(s{\s*}{}s, 'nested hash 2 ok'); +like($_, qr{^<(\w+)\s+value="555 1234"\s*>\s*\s*$}s, 'whole OK'); + + +# Now try encoding an anonymous array + +$ref = [ qw(1 two III) ]; +# Expect: +# +# 1 +# two +# III +# + +$_ = XMLout($ref); +is_deeply(XMLin($_), $ref, 'encoded anonymous array'); + +like($_, qr{ + ^<(\w+)\s*> + \s*1 + \s*two + \s*III + \s*\s*$}sx, 'output matches expectations'); + + +# Now try encoding a nested anonymous array + +$ref = [ [ qw(1.1 1.2) ], [ qw(2.1 2.2) ] ]; +# Expect: +# +# +# 1.1 +# 1.2 +# +# +# 2.1 +# 2.2 +# +# + +$_ = XMLout($ref); +is_deeply(XMLin($_), $ref, 'encoded nested anonymous arrays'); + +like($_, qr{ + <(\w+)\s*> + \s* + \s*1\.1 + \s*1\.2 + \s* + \s* + \s*2\.1 + \s*2\.2 + \s* + \s* +}sx, 'output matches expectations'); + + +# Now try encoding a hash of hashes with key folding disabled + +$ref = { country => { + England => { capital => 'London' }, + France => { capital => 'Paris' }, + Turkey => { capital => 'Istanbul' }, + } + }; +# Expect: +# +# +# +# +# +# +# + +$_ = XMLout($ref, keyattr => []); +is_deeply(XMLin($_), $ref, 'encoded hash of hashes with folding disabled'); +ok(s{\s*}{}s, 'nested hash 1 ok'); +ok(s{\s*}{}s, 'nested hash 2 ok'); +ok(s{\s*}{}s, 'nested hash 3 ok'); +ok(s{\s*}{}s, 'container hash ok'); +ok(s{^<(\w+)\s*>\s*$}{}s, 'document ok'); + + +# Try encoding same again with key folding set to non-standard value + +# Expect: +# +# +# +# +# + +my $expected = qr{ + ^<(\w+)\s*>\s* + ( + \s* + |\s* + |\s* + ){3} + $ +}xs; + +$xml = XMLout($ref, keyattr => ['fullname']); +is_deeply(XMLin($xml, keyattr => ['fullname']), $ref, +'encoded hash of hashes with explicit folding enabled'); + +like($xml, $expected, 'output as expected'); + + +# Same again but specify name as scalar rather than array + +$xml = XMLout($ref, keyattr => 'fullname'); +like($xml, $expected, 'still works when keyattr is scalar'); + + +# Same again but specify keyattr as hash rather than array + +$xml = XMLout($ref, keyattr => { country => 'fullname' }); +like($xml, $expected, 'still works when keyattr is hash'); + + +# Same again but add leading '+' + +$xml = XMLout($ref, keyattr => { country => '+fullname' }); +like($xml, $expected, "still works when keyattr is hash with leading '+'"); + + +# and leading '-' + +$xml = XMLout($ref, keyattr => { country => '-fullname' }); +like($xml, $expected, "still works when keyattr is hash with leading '-'"); + + +# One more time but with default key folding values + +# Expect: +# +# +# +# +# + +$expected = qr{ + ^<(\w+)\s*>\s* + ( + \s* + |\s* + |\s* + ){3} + $ +}xs; + +$xml = XMLout($ref); +is_deeply(XMLin($xml), $ref, +'encoded hash of hashes with default folding enabled'); +like($xml, $expected, "expected output with default keyattr"); + + +# Finally, confirm folding still works with only one nested hash + +# Expect: +# +# +# + +$ref = { country => { England => { capital => 'London' } } }; +$_ = XMLout($ref); +is_deeply(XMLin($_, forcearray => 1), $ref, 'single nested hash unfolded'); +ok(s{\s*name="England"}{uk}s, 'attr 1 ok'); +ok(s{\s*capital="London"}{uk}s, 'attr 2 ok'); +ok(s{\s*}{}s, 'element ok'); +ok(s{^<(\w+)\s*>\s*$}{}s, 'document ok'); + + +# Check that default XML declaration works +# +# Expect: +# +# + +$ref = { one => 1 }; + +$_ = XMLout($ref, xmldecl => 1); +is_deeply(XMLin($_), $ref, 'generated doc with XML declaration'); +ok(s{^\Q\E}{}s, 'XML declaration OK'); +like($_, qr{^\s*}s, 'data OK too'); + + +# Check that custom XML declaration works +# +# Expect: +# +# + +$_ = XMLout($ref, xmldecl => ""); +is_deeply(XMLin($_), $ref, 'generated doc with custom XML declaration'); +ok(s{^\Q\E}{}s, 'XML declaration OK'); +like($_, qr{^\s*}s, 'data OK too'); + + +# Check that special characters do get escaped + +$ref = { a => '', b => '"B"', c => '&C&' }; +$_ = XMLout($ref); +is_deeply(XMLin($_), $ref, 'generated document with escaping'); +ok(s{a="<A>"}{}s, 'angle brackets escaped OK'); +ok(s{b=""B""}{}s, 'double quotes escaped OK'); +ok(s{c="&C&"}{}s, 'ampersands escaped OK'); +ok(s{^<(\w+)\s*/>$}{}s, 'data OK too'); + + +# unless we turn escaping off + +$ref = { a => '', b => '"B"', c => ['&C&'] }; +$_ = XMLout($ref, noescape => 1); +ok(s{a=""}{}s, 'generated unescaped angle brackets'); +ok(s{b=""B""}{}s, 'generated unescaped double quotes'); +ok(s{&C&}{}s, 'generated unescaped ampersands'); +ok(s{^<(\w+)\s*>\s*$}{}s, 'data OK too'); + +# same again but with a scalar + +$xml = XMLout("", noescape => 1); +like($xml, qr{^<(\w+)>}, "Unescaped scalar as expected too"); + +# Try encoding a circular data structure and confirm that it fails + +$_ = eval { + my $ref = { a => '1' }; + $ref->{b} = $ref; + XMLout($ref); +}; +ok(!defined($_), 'caught circular data structure'); +like($@, qr/circular data structures not supported/, +'with correct error message'); + + +# Try encoding a repetitive (but non-circular) data structure and confirm that +# it does not fail + +$_ = eval { + my $a = { alpha => 1 }; + my $ref = { a => $a, b => $a }; + XMLout($ref); +}; +ok(defined($_), 'repetitive (non-circular) data structure not fatal'); +like($_, qr{^ + + ( + \s* + | + \s* + ){2} +\s* +}xs, 'and encodes as expected'); + + +# Try encoding a non array/hash blessed reference and confirm that it fails + +$_ = eval { my $ref = bless \*STDERR, 'BogoClass'; XMLout($ref) }; +is($_, undef, 'caught blessed non array/hash reference in data structure'); +like($@, qr/Can't encode a value of type: /, 'with correct error message'); + + +# Repeat some of the above tests with named root element + +# Try encoding a scalar value + +$xml = XMLout("scalar", rootname => 'TOM'); +ok(defined($xml), 'generated document with named root element'); +is(XMLin($xml), 'scalar', 'parsed it back correctly'); +like($xml, qr/^\s*scalar<\/TOM>\s*$/si, 'XML as expected'); + + +# Next try encoding a hash + +# Expect: +# + +$_ = XMLout($hashref1, rootname => 'DICK'); +is_deeply(XMLin($_), $hashref1, 'same again but encoded a hash'); +ok(s/one="1"//, 'first key encoded OK'); +ok(s/two="II"//, 'second key encoded OK'); +ok(s/three="..."//, 'third key encoded OK'); +like($_, qr/^/, 'XML looks OK'); + + +# Now try encoding a hash with a nested array + +$ref = {array => [qw(one two three)]}; +# Expect: +# +# one +# two +# three +# + +$_ = XMLout($ref, rootname => 'LARRY'); +is_deeply(XMLin($_), $ref, 'same again but with array in hash'); +ok(s{one\s* + two\s* + three}{}sx, 'array encoded in correct order'); +like($_, qr/^<(LARRY)\s*>\s*<\/\1>\s*$/s, 'only expected root element left'); + + +# Now try encoding a nested hash + +$ref = { value => '555 1234', + hash1 => { one => 1 }, + hash2 => { two => 2 } }; +# Expect: +# +# +# +# + +$_ = XMLout($ref, rootname => 'CURLY'); +is_deeply(XMLin($_), $ref, 'same again but with nested hashes'); + +ok(s{\s*}{}s, 'hash 1 encoded OK'); +ok(s{\s*}{}s, 'hash 2 encoded OK'); +like($_, qr{^<(CURLY)\s+value="555 1234"\s*>\s*\s*$}s, 'document OK'); + + +# Now try encoding an anonymous array + +$ref = [ qw(1 two III) ]; +# Expect: +# +# 1 +# two +# III +# + +$_ = XMLout($ref, rootname => 'MOE'); +is_deeply(XMLin($_), $ref, 'same again but with nested anonymous array'); +like($_, qr{ + ^<(MOE)\s*> + \s*1 + \s*two + \s*III + \s*\s*$}sx, 'document OK'); + + +# Test again, this time with no root element + +# Try encoding a scalar value + +like(XMLout("scalar", rootname => ''), qr/scalar\s+/s, + 'encoded scalar with no root element'); +like(XMLout("scalar", rootname => undef), qr/scalar\s+/s, + 'same again but with rootname = undef'); + + +# Next try encoding a hash + +# Expect: +# 1 +# II +# ... + +$_ = XMLout($hashref1, rootname => ''); +is_deeply(XMLin("$_"), $hashref1, + 'generated doc with no root element from hash'); +ok(s/1<\/one>//, 'first key encoded OK'); +ok(s/II<\/two>//, 'second key encoded OK'); +ok(s/...<\/three>//, 'third key encoded OK'); +like($_, qr/^\s*$/, 'document OK'); + + +# Now try encoding a nested hash + +$ref = { value => '555 1234', + hash1 => { one => 1 }, + hash2 => { two => 2 } }; +# Expect: +# 555 1234 +# +# + +$_ = XMLout($ref, rootname => ''); +is_deeply(XMLin("$_"), $ref, + 'generated docucment with no root element from nested hashes'); +ok(s{555 1234<\/value>\s*}{}s, 'first element OK'); +ok(s{\s*}{}s, 'second element OK'); +ok(s{\s*}{}s, 'third element OK'); +like($_, qr{^\s*$}s, 'document OK'); + + +# Now try encoding an anonymous array + +$ref = [ qw(1 two III) ]; +# Expect: +# 1 +# two +# III + +$_ = XMLout($ref, rootname => ''); +is_deeply(XMLin("$_"), $ref, + 'generated doc with no root name from array'); +like($_, qr{ + ^\s*1 + \s*two + \s*III + \s*$}sx, 'document OK'); + + +# Test option error handling + +$_ = eval { XMLout($hashref1, searchpath => []) }; # only valid for XMLin() +ok(!defined($_), 'caught attempt to specify searchpath on XMLout'); +like($@, qr/Unrecognised option:/, 'with correct error message'); + +$_ = eval { XMLout($hashref1, 'bogus') }; +ok(!defined($_), 'caught attempt to specify odd number of option args'); +like($@, qr/Options must be name=>value pairs \(odd number supplied\)/, + 'with correct error message'); + + +# Test output to file + +my $TestFile = 'testoutput.xml'; +unlink($TestFile); +ok(!-e $TestFile, 'output file does not exist'); + +$xml = XMLout($hashref1); +eval { XMLout($hashref1, outputfile => $TestFile); }; +ok(-e $TestFile, 'created xml output file'); +is(ReadFile($TestFile), $xml, 'Contents match expectations'); +unlink($TestFile); + + +# Test output to an IO handle + +ok(!-e $TestFile); +eval { + open my $fh, '>', $TestFile or die "$!"; + XMLout($hashref1, outputfile => $fh); + $fh->close(); +}; +ok(-e $TestFile, 'create XML output file via IO::File'); +is(ReadFile($TestFile), $xml, 'Contents match expectations'); +unlink($TestFile); + +# After all that, confirm that the original hashref we supplied has not +# been corrupted. + +is_deeply($hashref1, $hashref2, 'original data not corrupted'); + + +# Confirm that hash keys with leading '-' are skipped + +$ref = { + 'a' => 'one', + '-b' => 'two', + '-c' => { + 'one' => 1, + 'two' => 2 + } +}; + +$_ = XMLout($ref, rootname => 'opt'); +like($_, qr{^\s*\s*$}s, "skipped hashkeys with '-' prefix"); + + +# Try a more complex unfolding with key attributes named in a hash + +$ref = { + 'car' => { + 'LW1804' => { + 'option' => { + '9926543-1167' => { 'key' => 1, 'desc' => 'Steering Wheel' } + }, + 'id' => 2, + 'make' => 'GM' + }, + 'SH6673' => { + 'option' => { + '6389733317-12' => { 'key' => 2, 'desc' => 'Electric Windows' }, + '3735498158-01' => { 'key' => 3, 'desc' => 'Leather Seats' }, + '5776155953-25' => { 'key' => 4, 'desc' => 'Sun Roof' }, + }, + 'id' => 1, + 'make' => 'Ford' + } + } +}; + +# Expect: +# +# +# +# +# +# + +$_ = XMLout($ref, keyattr => { 'car' => 'license', 'option' => 'pn' }); +is_deeply(XMLin($_, + forcearray => 1, + keyattr => { 'car' => 'license', 'option' => 'pn' } +), $ref, 'generated document from complex nested hash with unfolding'); +ok(s{\s*make="GM"}{gm}s, 'element 1 attribute 1 OK'); +ok(s{\s*id="2"}{gm}s, 'element 1 attribute 2 OK'); +ok(s{\s*license="LW1804"}{gm}s, 'element 1 attribute 3 OK'); +ok(s{\s*desc="Steering Wheel"}{opt}s, 'element 1.1 attribute 1 OK'); +ok(s{\s*pn="9926543-1167"}{opt}s, 'element 1.1 attribute 2 OK'); +ok(s{\s*key="1"}{opt}s, 'element 1.1 attribute 3 OK'); +ok(s{\s*\s*\s*}{CAR}s, + 'elements 1 and 1.1 OK'); +ok(s{\s*make="Ford"}{ford}s, 'element 2 attribute 1 OK'); +ok(s{\s*id="1"}{ford}s, 'element 2 attribute 2 OK'); +ok(s{\s*license="SH6673"}{ford}s, 'element 2 attribute 3 OK'); +ok(s{\s*desc="Electric Windows"}{1}s, 'element 2.1 attribute 1 OK'); +ok(s{\s*pn="6389733317-12"}{1}s, 'element 2.1 attribute 2 OK'); +ok(s{\s*key="2"}{1}s, 'element 2.1 attribute 3 OK'); +ok(s{\s*\s*(\s*){3}}{CAR}s, 'element 2 OK'); +ok(s{^<(\w+)\s*>\s*CAR\s*CAR\s*$}{}s, 'document OK'); + + +# Check that empty hashes translate to empty tags + +$ref = { + 'one' => { + 'attr1' => 'avalue1', + 'nest1' => [ 'nvalue1' ], + 'nest2' => {} + }, + two => {} +}; + +$_ = XMLout($ref); +ok(s{\s*}{}, 'nested empty hash OK'); +ok(s{nvalue1\s*}{}, 'array OK'); +ok(s{\s*}{}, 'scalar OK'); +ok(s{\s*\s*\s*}{}, 'nesting OK'); +ok(s{\s*}{}, 'empty hash OK'); +like($_, qr{^\s*<(\w+)\s*>\s*\s*\s*\s*$}, 'document OK'); + + +# Check undefined values generate warnings + +{ + local($^W) = 1; + my $warn = ''; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + $ref = { 'one' => 1, 'two' => undef }; + my $expect = qr/^<\w+(\s+one="1"|\s+two=""){2}/; + + $_ = XMLout($ref); + like($warn, qr/Use of uninitialized value/, + 'caught warning re uninitialised value'); + like($_, $expect, 'undef maps to any empty attribute by default'); + + # unless warnings are disabled + $^W = 0; + $warn = ''; + $_ = XMLout($ref); + is($warn, '', 'no warning re uninitialised value if warnings off'); + like($_, $expect, 'undef still maps to any empty attribute'); +} + + +# Unless undef is mapped to empty elements + +$ref = { 'tag' => undef }; +$_ = XMLout($ref, suppressempty => undef); +like($_, qr{^\s*<(\w*)\s*>\s*\s*\s*$}s, + 'uninitialiased values successfully mapped to empty elements'); + + +# Set suppressempty to 1 to not output anything for undef + +$ref = { 'one' => 1, 'two' => undef }; +$_ = XMLout($ref, suppressempty => 1, noattr => 1); +like($_, qr{^\s*<(\w*)\s*>\s*1\s*\s*$}s, + 'uninitialiased values successfully skipped'); + + +# Try undef in an array + +$ref = { a => [ 'one', undef, 'three' ] }; +$_ = XMLout($ref); +like($_, + qr{ + ^\s*<(\w*)\s*> + \s*one + \s* + \s*three + \s*\s*$ + }xs, + 'uninitialiased value in array is empty element'); + + +# And again with SuppressEmpty enabled + +$_ = XMLout($ref, SuppressEmpty => 1); +like($_, + qr{ + ^\s*<(\w*)\s*> + \s*one + \s*three + \s*\s*$ + }xs, + 'uninitialiased value in array is skipped'); + + +# Test the keeproot option + +$ref = { + 'seq' => { + 'name' => 'alpha', + 'alpha' => [ 1, 2, 3 ] + } +}; + +my $xml1 = XMLout($ref, rootname => 'sequence'); +my $xml2 = XMLout({ 'sequence' => $ref }, keeproot => 1); + +is_deeply($xml1, $xml2, 'keeproot works as expected'); + + +# Test that items with text content are output correctly +# Expect: text + +$ref = { 'one' => 1, 'content' => 'text' }; + +$_ = XMLout($ref); + +like($_, qr{^\s*text\s*$}s, 'content keys mapped OK'); + + +# Even if we change the default value for the 'contentkey' option + +$ref = { 'one' => 1, 'text_content' => 'text' }; + +$_ = XMLout($ref, contentkey => 'text_content'); + +like($_, qr{^\s*text\s*$}s, 'even when name changed'); + + +# and also if we add the '-' prefix + +$_ = XMLout($ref, contentkey => '-text_content'); + +like($_, qr{^\s*text\s*$}s, 'even with "-" prefix'); + + +# Confirm content key works with undef values (and no warnings) + +{ + $^W = 1; + my $warn = ''; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + $_ = eval { + $ref = { + column => [ + { name => 'title', content => 'A Title' }, + { name => 'sponsor', content => undef }, + ], + }; + XMLout($ref, suppress_empty => undef, content_key => 'content'); + }; + ok(!$warn, 'no warnings with suppress_empty => undef'); + like($_, qr{^<(\w+)> + \s*A\sTitle + \s* + \s* + $ + }sx, "undef does not cause content tags in output" + ); +} + + +# Check 'noattr' option + +$ref = { + attr1 => 'value1', + attr2 => 'value2', + nest => [ qw(one two three) ] +}; + +# Expect: +# +# +# value1 +# value2 +# one +# two +# three +# +# + +$_ = XMLout($ref, noattr => 1); + +unlike($_, qr{=}s, 'generated document with no attributes'); +is_deeply(XMLin($_), $ref, 'parses ok'); +ok(s{\s*<(attr1)>value1\s*}{NEST}s, 'scalar 1 mapped ok'); +ok(s{\s*<(attr2)>value2\s*}{NEST}s, 'scalar 2 mapped ok'); +ok(s{\s*<(nest)>one\s*<\1>two\s*<\1>three}{NEST}s, +'array mapped ok'); +like($_, qr{^<(\w+)\s*>(NEST\s*){3}$}s, 'document OK'); + + +# Check noattr doesn't screw up keyattr + +$ref = { number => { + 'twenty one' => { dec => 21, hex => '0x15' }, + 'thirty two' => { dec => 32, hex => '0x20' } + } +}; + +# Expect: +# +# +# +# 21 +# twenty one +# 0x15 +# +# +# 32 +# thirty two +# 0x20 +# +# +# + +$_ = XMLout($ref, noattr => 1, keyattr => [ 'word' ]); + +unlike($_, qr{=}s, 'same again but with unfolding too'); +is_deeply(XMLin($_, keyattr => [ 'word' ]), $ref, 'parsed OK'); +ok(s{\s*<(dec)>21\s*}{21}s, 'scalar 1.1 mapped OK'); +ok(s{\s*<(hex)>0x15\s*}{21}s, 'scalar 1.2 mapped OK'); +ok(s{\s*<(word)>twenty one\s*}{21}s, 'scalar 1.3 mapped OK'); +ok(s{\s*<(number)>212121\s*}{NUM}s, 'element 1 OK'); +ok(s{\s*<(dec)>32\s*}{32}s, 'scalar 2.1 mapped OK'); +ok(s{\s*<(hex)>0x20\s*}{32}s, 'scalar 2.1 mapped OK'); +ok(s{\s*<(word)>thirty two\s*}{32}s, 'scalar 2.1 mapped OK'); +ok(s{\s*<(number)>323232\s*}{NUM}s, 'element 2 OK'); +like($_, qr{^<(\w+)\s*>NUMNUM$}, 'document OK'); + + +# Check grouped tags get ungrouped correctly + +$ref = { + prefix => 'before', + dirs => [ '/usr/bin', '/usr/local/bin' ], + suffix => 'after', +}; + +# Expect: +# +# +# before +# +# /usr/bin +# /usr/local/bin +# +# after +# +# + +$@ = ''; +$_ = eval { XMLout($ref, grouptags => {dirs => 'dirs'}, noattr => 1); }; +ok($@, 'bad GroupTags value was caught'); +like("$@", qr{Bad value in GroupTags: 'dirs' => 'dirs'}, + 'error message looks good'); + +$@ = ''; +$_ = eval { XMLout($ref, grouptags => {dirs => 'dir'}, noattr => 1); }; +ok(!$@, 'good GroupTags value caused no error'); + +ok(s{\s*<(prefix)>before\s*}{ELEM}s, 'prefix OK'); +ok(s{\s*<(suffix)>after\s*}{ELEM}s, 'suffix OK'); +ok(s{\s*/usr/bin\s*/usr/local/bin\s*}{LIST}s, 'list OK'); +ok(s{\s*LIST\s*}{ELEM}s, 'group OK'); +like($_, qr{^<(\w+)\s*>ELEMELEMELEM$}, 'document OK'); + +is_deeply($ref, { + prefix => 'before', + dirs => [ '/usr/bin', '/usr/local/bin' ], + suffix => 'after', +}, 'original ref is not messed with'); + +# Try again with multiple groupings + +$ref = { + dirs => [ '/usr/bin', '/usr/local/bin' ], + terms => [ 'vt100', 'xterm' ], +}; + +# Expect: +# +# +# +# /usr/bin +# /usr/local/bin +# +# +# vt100 +# xterm +# +# +# + +$_ = XMLout($ref, grouptags => {dirs => 'dir', terms => 'term'}, noattr => 1); + +ok(s{\s*/usr/bin\s*/usr/local/bin\s*}{LIST}s, 'list 1 OK'); +ok(s{\s*LIST\s*}{ELEM}s, 'group 1 OK'); +ok(s{\s*vt100\s*xterm\s*}{LIST}s, 'list 2 OK'); +ok(s{\s*LIST\s*}{ELEM}s, 'group 2 OK'); +like($_, qr{^<(\w+)\s*>ELEMELEM$}, 'document OK'); + + +# Confirm unfolding and grouping work together + +$ref = { + dirs => { + first => { content => '/usr/bin' }, + second => { content => '/usr/local/bin' }, + }, +}; + +# Expect: +# +# +# +# /usr/bin +# /usr/local/bin +# +# +# + +$_ = XMLout($ref, + grouptags => {dirs => 'dir'}, keyattr => {dir => 'name'}, +); + +ok(s{\s*/usr/bin\s*}{ITEM}s, 'item 1 OK'); +ok(s{\s*/usr/local/bin\s*}{ITEM}s, 'item 2 OK'); +ok(s{\s*ITEMITEM\s*}{GROUP}s, 'group OK'); +like($_, qr{^<(\w+)\s*>GROUP$}, 'document OK'); + + +# Combine unfolding, grouping and stripped content - watch it fail :-( + +$ref = { + dirs => { + first => '/usr/bin', + second => '/usr/local/bin' + }, +}; + +# Expect: +# +# +# +# +# + +$_ = XMLout($ref, + grouptags => {dirs => 'dir'}, keyattr => {dir => 'name'}, + contentkey => '-content' +); + +like($_, qr{ + ^<(\w+)>\s* + \s* + \s* + \s* + $ +}x, 'Failed to unwrap/group stripped content - as expected'); + + +# Check 'NoIndent' option + +$ref = { + nest => [ qw(one two three) ] +}; + +# Expect: +# +# onetwothree +# + +$_ = XMLout($ref, NoIndent => 1); + +is_deeply(XMLin($_), $ref, 'parses ok'); +is($_, 'onetwothree', +'NoIndent worked ok'); + + +# Check 'NoIndent' works with KeyAttr + +$ref = { + person => { + bob => { age => 25 }, + kate => { age => 22 }, + }, +}; + +# Expect: +# +# +# + +$_ = XMLout($ref, NoIndent => 1, KeyAttr => {person => 'name'}); + +is_deeply(XMLin($_), $ref, 'parses ok'); +like($_, qr{ + + ( + + | + ){2} + +}sx, +'NoIndent worked ok with KeyAttr'); + + +# Try the 'AttrIndent' option (assume NoSort defaults to off) + +$ref = { + beta => '2', + gamma => '3', + alpha => '1', + colours => { + red => '#ff0000', + green => '#00ff00', + } +}; + +$_ = XMLout($ref, AttrIndent => 1, RootName => 'opt'); + +is($_, ' + + +', 'AttrIndent seems to work'); + + +# Test the attribute/element sorting algorithm + +$xml = q{ + + + + + + + +}; + +$ref = XMLin($xml); + +$_ = XMLout($ref, RootName => 'opt'); + +is($_, qq(\n) . + qq( \n) . + qq( \n) . + qq( \n) . + qq( \n) . + qq( \n) . + qq(\n), +'sorting by default key attribute works'); + + +# Try again but with specific key fields: + +$ref = XMLin($xml, KeyAttr => {test => 'vegetable', box => 'size'}); + +$_ = XMLout($ref, + RootName => 'opt', + KeyAttr => {test => 'vegetable', box => 'size'} +); + +is($_, qq(\n) . + qq( \n) . + qq( \n) . + qq( \n) . + qq( \n) . + qq( \n) . + qq(\n), +'sorting by specified key attributes works'); + + +# Try again but with no key fields: + +$ref = XMLin($xml, KeyAttr => {}); + +$_ = XMLout($ref, RootName => 'opt', KeyAttr => {}); + +like($_, qr{^\s* + ( + ( + \s* + \s* + \s* + ) + |( + \s* + \s* + ) + ){2} +\s* +$}sx, 'sorting with no key attribute works'); + + +# Check that sorting can be disabled + +$@ = ''; +SKIP: { + eval { require Tie::IxHash }; + + skip "Tie::IxHash not installed", 1 if $@; + + my(%hash1, %hash2); + tie %hash1, 'Tie::IxHash', Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5; + tie %hash2, 'Tie::IxHash', X => { b => 2 }, A => { c => 3 }, Z => { a => 1 }, + M => { f => 6 }, K => { e => 4 }, O => { d => 5 }; + $hash1{func} = \%hash2; + + $_ = XMLout(\%hash1, NoSort => 1, KeyAttr => {func => 'name'}); + + like($_, qr{ + ^\s+ + \s+ + \s+ + \s+ + \s+ + \s+ + \s+ + \s*$ + }sx, 'Suppressing sort worked'); + +} + +# Check ValueAttr => {} can expand the relevant records + +$ref = { one => 1, two => 2, six => 6 }; + +$xml = XMLout($ref, ValueAttr => { one => 'value', six => 'num' }); + +like($xml, qr{ + ^ + ( + \s* + | \s* + ){2} + \s*$ + }sx, 'Correct attributes inserted when ValueAttr specified' +); + +# Try out the NumericEscape option + +SKIP: { + skip "Perl 5.6 or better required", 4 unless($] >= 5.006); + + $ref = { euro => "\x{20AC}", nbsp => "\x{A0}" }; + + $xml = XMLout($ref); # Default: no numeric escaping + my $ents = join ',', sort ($xml =~ m{&#(\d+);}g); + is($ents, '', "No numeric escaping by default"); + + $xml = XMLout($ref, NumericEscape => 0); + $ents = join ',', sort ($xml =~ m{&#(\d+);}g); + is($ents, '', "No numeric escaping: explicit"); + + $xml = XMLout($ref, NumericEscape => 2); + $ents = join ',', sort ($xml =~ m{&#(\d+);}g); + is($ents, '160,8364', "Level 2 numeric escaping looks good"); + + $xml = XMLout($ref, NumericEscape => 1); + $ents = join ',', sort ($xml =~ m{&#(\d+);}g); + is($ents, '8364', "Level 1 numeric escaping looks good"); +} + +# 'Stress test' with a data structure that maps to several thousand elements. +# Unfold elements with XMLout() and fold them up again with XMLin() + +my $opt1 = {}; +foreach my $i (0..40) { + foreach my $j (0..$i) { + $opt1->{TypeA}->{$i}->{Record}->{$j} = { Hex => sprintf("0x%04X", $j) }; + $opt1->{TypeB}->{$i}->{Record}->{$j} = { Oct => sprintf("%04o", $j) }; + $opt1->{List}->[$i]->[$j] = "$i:$j"; + } +} + +$xml = XMLout($opt1, keyattr => { TypeA => 'alpha', TypeB => 'beta', Record => 'id' }); + +my $opt2 = XMLin($xml, keyattr => { TypeA => 'alpha', TypeB => 'beta', Record => 'id' }, forcearray => 1); + +is_deeply($opt1, $opt2, 'large datastructure mapped to XML and back OK'); + +exit(0); + + + diff --git a/t/3_Storable.t b/t/3_Storable.t new file mode 100644 index 0000000..88d48af --- /dev/null +++ b/t/3_Storable.t @@ -0,0 +1,238 @@ +# $Id: 3_Storable.t,v 1.11 2007/08/02 10:38:22 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use File::Spec; + +$^W = 1; + + +eval { require Storable; }; +unless($INC{'Storable.pm'}) { + plan skip_all => 'no Storable.pm'; +} +unless(UNIVERSAL::can(Storable => 'lock_nstore')) { + plan skip_all => 'Storable.pm is too old - no file locking support'; +} + + +# Initialise filenames and check they're there + +my $SrcFile = File::Spec->catfile('t', 'desertnet.src'); +my $XMLFile = File::Spec->catfile('t', 'desertnet.xml'); +my $CacheFile = File::Spec->catfile('t', 'desertnet.stor'); + +unless(-e $SrcFile) { + plan skip_all => 'test data missing'; +} + +# Make sure we can write to the filesystem and check it uses the same +# clock as the machine we're running on. + +my $t0 = time(); +unless(open(XML, ">$XMLFile")) { + plan skip_all => "can't create test file: $!"; +} +close(XML); +my $t1 = (stat($XMLFile))[9]; +my $t2 = time(); + +if($t1 < $t0 or $t2 < $t1) { + plan skip_all => 'time moved backwards!' +} + + +plan tests => 23; + +############################################################################## +# S U P P O R T R O U T I N E S +############################################################################## + +############################################################################## +# Copy a file +# + +sub CopyFile { + my($Src, $Dst) = @_; + + open(IN, $Src) || return(undef); + local($/) = undef; + my $Data = ; + close(IN); + + open(OUT, ">$Dst") || return(undef); + print OUT $Data; + close(OUT); + + return(1); +} + + +############################################################################## +# Delete a file - portably +# + +sub DeleteFile { + my($Filename) = @_; + + if ('VMS' eq $^O) { + 1 while (unlink($Filename)); + } else { + unlink($Filename); + } +} + + +############################################################################## +# Create a file, making sure that its timestamp is newer than another +# existing file. +# + +sub MakeNewerFile { + my($File1, $File2, $CodeRef) = @_; + + my $t0 = (stat($File1))[9]; + while(1) { + unlink($File2); + $CodeRef->(); + return if (stat($File2))[9] > $t0; + sleep(1); + } +} + + +############################################################################## +# Wait until the current time is greater than the supplied value +# + +sub PassTime { + my($Target) = @_; + + while(time <= $Target) { + sleep 1; + } +} + + +############################################################################## +# T E S T R O U T I N E S +############################################################################## + +use XML::Simple; + +# Initialise test data + +my $Expected = { + 'server' => { + 'sahara' => { + 'osversion' => '2.6', + 'osname' => 'solaris', + 'address' => [ + '10.0.0.101', + '10.0.1.101' + ] + }, + 'gobi' => { + 'osversion' => '6.5', + 'osname' => 'irix', + 'address' => '10.0.0.102' + }, + 'kalahari' => { + 'osversion' => '2.0.34', + 'osname' => 'linux', + 'address' => [ + '10.0.0.103', + '10.0.1.103' + ] + } + } + }; + +ok(CopyFile($SrcFile, $XMLFile), 'copied known good source file'); +unlink($CacheFile); +ok(! -e $CacheFile, 'no cache files lying around'); + +my $opt = XMLin($XMLFile); +is_deeply($opt, $Expected, 'parsed expected data from file'); +ok(! -e $CacheFile, 'and no cache file was created'); +PassTime(time()); # Ensure cache file will be newer + +$opt = XMLin($XMLFile, cache => 'storable'); +is_deeply($opt, $Expected, 'parsed expected data from file (again)'); +ok(-e $CacheFile, 'but this time a cache file was created'); +$t0 = (stat($CacheFile))[9]; # Remember cache timestamp +PassTime($t0); + +$opt = XMLin($XMLFile, cache => ['storable']); +is_deeply($opt, $Expected, 'got expected data from cache'); +$t1 = (stat($CacheFile))[9]; +is($t0, $t1, 'and cache timestamp has not changed'); + +PassTime(time()); +$t0 = time(); +open(FILE, ">>$XMLFile"); # Touch the XML file +print FILE "\n"; +close(FILE); +$opt = XMLin($XMLFile, cache => 'storable'); +is_deeply($opt, $Expected, 'parsed in expected value again'); +$t2 = (stat($CacheFile))[9]; +isnt($t1, $t2, 'and this time the cache timestamp has changed'); + +DeleteFile($XMLFile); +ok(! -e $XMLFile, 'deleted the source file'); +open(FILE, ">$XMLFile"); # Re-create it (empty) +close(FILE); +ok(-e $XMLFile, 'recreated the source file'); +is(-s $XMLFile, 0, 'but with nothing in it'); +MakeNewerFile($XMLFile, $CacheFile, sub { # Make sure cache file is newer + Storable::nstore($Expected, $CacheFile); +}); +$opt = XMLin($XMLFile, cache => 'storable'); +is_deeply($opt, $Expected, 'got the expected data from the cache'); +$t2 = (stat($CacheFile))[9]; +PassTime($t2); +open(FILE, ">$XMLFile") || # Write some new data to the XML file + die "open(>$XMLFile): $!\n"; +print FILE qq(\n); +close(FILE); + +$opt = XMLin($XMLFile); # Parse with no caching +is_deeply($opt, { one => 1, two => 2}, 'parsed in expected data from file'); +$t0 = (stat($CacheFile))[9]; # And timestamp on cache file +my $s0 = (-s $CacheFile); +is($t0, $t2, 'and the cache file was not touched'); + + # Parse again with caching enabled +$opt = XMLin($XMLFile, cache => 'storable'); +is_deeply($opt, { one => 1, two => 2}, 'parsed expected data through cache'); +$t1 = (stat($CacheFile))[9]; +my $s1 = (-s $CacheFile); +ok(($t0 != $t1) || ($s0 != $s1), +'and the cache was updated'); # Content changes but date may not on Win32 + +ok(CopyFile($SrcFile, $XMLFile), 'copied back the original file'); +PassTime($t1); +$opt = XMLin($XMLFile, cache => 'storable'); +is_deeply($opt, $Expected, 'parsed expected data in through cache'); + +# Make sure scheme name is case-insensitive + +$opt = XMLin($XMLFile, cache => 'Storable'); +is_deeply($opt, $Expected, 'scheme name is case-insensitive'); + +# Make sure bad scheme names are trapped + +$@=''; +$_ = eval { XMLin($XMLFile, cache => 'Storubble'); }; +is($_, undef, 'bad cache scheme names are trapped'); +like($@, qr/Unsupported caching scheme: storubble/, +'with correct error message'); + + +# Clean up and go + +unlink($CacheFile); +unlink($XMLFile); +exit(0); + diff --git a/t/4_MemShare.t b/t/4_MemShare.t new file mode 100644 index 0000000..3e3810a --- /dev/null +++ b/t/4_MemShare.t @@ -0,0 +1,154 @@ +# $Id: 4_MemShare.t,v 1.5 2005/01/29 04:17:42 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use File::Spec; + +$^W = 1; + + +# Initialise filenames and check they're there + +my $SrcFile = File::Spec->catfile('t', 'desertnet.src'); +my $XMLFile = File::Spec->catfile('t', 'desertnet.xml'); + +unless(-e $SrcFile) { + plan skip_all => 'test data missing'; +} + +# Make sure we can write to the filesystem and check it uses the same +# clock as the machine we're running on. + +my $t0 = time(); +unless(open(XML, ">$XMLFile")) { + plan skip_all => "can't create test file: $!"; +} +close(XML); +my $t1 = (stat($XMLFile))[9]; +my $t2 = time(); + +if($t1 < $t0 or $t2 < $t1) { + plan skip_all => 'time moved backwards!' +} + + +plan tests => 8; + +############################################################################## +# S U P P O R T R O U T I N E S +############################################################################## + +############################################################################## +# Copy a file +# + +sub CopyFile { + my($Src, $Dst) = @_; + + open(IN, $Src) || return(undef); + local($/) = undef; + my $Data = ; + close(IN); + + open(OUT, ">$Dst") || return(undef); + print OUT $Data; + close(OUT); + + return(1); +} + + +############################################################################## +# Wait until the current time is greater than the supplied value +# + +sub PassTime { + my($Target) = @_; + + while(time <= $Target) { + sleep 1; + } +} + + +############################################################################## +# T E S T R O U T I N E S +############################################################################## + +use XML::Simple; + +# Initialise test data + +my $Expected = { + 'server' => { + 'sahara' => { + 'osversion' => '2.6', + 'osname' => 'solaris', + 'address' => [ + '10.0.0.101', + '10.0.1.101' + ] + }, + 'gobi' => { + 'osversion' => '6.5', + 'osname' => 'irix', + 'address' => '10.0.0.102' + }, + 'kalahari' => { + 'osversion' => '2.0.34', + 'osname' => 'linux', + 'address' => [ + '10.0.0.103', + '10.0.1.103' + ] + } + } + }; + +ok(CopyFile($SrcFile, $XMLFile), 'copied known good source file'); +$t0 = (stat($XMLFile))[9]; # Remember its timestamp + + # Parse it with caching enabled +my $opt = XMLin($XMLFile, cache => 'memshare'); +is_deeply($opt, $Expected, 'parsed expected data from file'); + +if ('VMS' eq $^O) { + 1 while (unlink($XMLFile)); +} else { + unlink($XMLFile); +} +ok(! -e $XMLFile, 'deleted the XML source file'); +open(FILE, ">$XMLFile"); # Re-create it (empty) +close(FILE); +ok(-e $XMLFile, 'and recreated it (empty)'); +$t1 = $t0 - 1; +eval { utime($t1, $t1, $XMLFile); }; # but wind back the clock +$t2 = (stat($XMLFile))[9]; # Skip these tests if that didn't work +SKIP: { + skip 'no utime', 2 if($t2 >= $t0); + + $opt = XMLin($XMLFile, cache => 'memshare'); + is_deeply($opt, $Expected, 'got expected values from the cache'); + is(-s $XMLFile, 0, 'even though the XML file is empty'); +} +PassTime(time()); # Ensure timestamp changes + +open(FILE, ">$XMLFile"); # Write some new data to the XML file +print FILE qq(\n); +close(FILE); +PassTime(time()); # Ensure current time later than file time + + # Parse again with caching enabled +$opt = XMLin($XMLFile, cache => 'memshare'); +is_deeply($opt, { one => 1, two => 2}, 'parsed new data through cache'); + +$opt->{three} = 3; # Alter the returned structure + # Retrieve again from the cache +my $opt2 = XMLin($XMLFile, cache => 'memshare'); + +is($opt2->{three}, 3, 'cache was modified'); + + +exit(0); + diff --git a/t/5_MemCopy.t b/t/5_MemCopy.t new file mode 100644 index 0000000..26d2d1d --- /dev/null +++ b/t/5_MemCopy.t @@ -0,0 +1,162 @@ +# $Id: 5_MemCopy.t,v 1.6 2005/01/29 04:17:42 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use File::Spec; + +$^W = 1; + + +eval { require Storable; }; +unless($INC{'Storable.pm'}) { + plan skip_all => 'no Storable.pm'; +} + +# Initialise filenames and check they're there + +my $SrcFile = File::Spec->catfile('t', 'desertnet.src'); +my $XMLFile = File::Spec->catfile('t', 'desertnet.xml'); + +unless(-e $SrcFile) { + plan skip_all => 'test data missing'; +} + +# Make sure we can write to the filesystem and check it uses the same +# clock as the machine we're running on. + +my $t0 = time(); +unless(open(XML, ">$XMLFile")) { + plan skip_all => "can't create test file: $!"; +} +close(XML); +my $t1 = (stat($XMLFile))[9]; +my $t2 = time(); + +if($t1 < $t0 or $t2 < $t1) { + plan skip_all => 'time moved backwards!' +} + +plan tests => 7; + +############################################################################## +# S U P P O R T R O U T I N E S +############################################################################## + +############################################################################## +# Copy a file +# + +sub CopyFile { + my($Src, $Dst) = @_; + + open(IN, $Src) || return(undef); + local($/) = undef; + my $Data = ; + close(IN); + + open(OUT, ">$Dst") || return(undef); + print OUT $Data; + close(OUT); + + return(1); +} + + +############################################################################## +# Wait until the current time is greater than the supplied value +# + +sub PassTime { + my($Target) = @_; + + while(time <= $Target) { + sleep 1; + } +} + + +############################################################################## +# T E S T R O U T I N E S +############################################################################## + +use XML::Simple; + +# Initialise test data + +my $Expected = { + 'server' => { + 'sahara' => { + 'osversion' => '2.6', + 'osname' => 'solaris', + 'address' => [ + '10.0.0.101', + '10.0.1.101' + ] + }, + 'gobi' => { + 'osversion' => '6.5', + 'osname' => 'irix', + 'address' => '10.0.0.102' + }, + 'kalahari' => { + 'osversion' => '2.0.34', + 'osname' => 'linux', + 'address' => [ + '10.0.0.103', + '10.0.1.103' + ] + } + } + }; + +ok(CopyFile($SrcFile, $XMLFile), 'copied source XML file'); +$t0 = (stat($XMLFile))[9]; # Remember its timestamp + + # Parse it with caching enabled +my $opt = XMLin($XMLFile, cache => 'memcopy'); +is_deeply($opt, $Expected, 'parsed expected data through the cache'); + +if ('VMS' eq $^O) { + 1 while (unlink($XMLFile)); +} else { + unlink($XMLFile); +} +ok(! -e $XMLFile, 'deleted the source XML file'); +open(FILE, ">$XMLFile"); # Re-create it (empty) +close(FILE); +$t1 = $t0 - 1; +eval { utime($t1, $t1, $XMLFile); }; # but wind back the clock +$t2 = (stat($XMLFile))[9]; # Skip these tests if that didn't work +SKIP: { + skip 'no utime', 2 if($t2 >= $t0); + + $opt = XMLin($XMLFile, cache => 'memcopy'); + is_deeply($opt, $Expected, 'got what we expected from the cache'); + is(-s $XMLFile, 0, 'even though the source XML file is empty'); +} + + +PassTime(time()); # Ensure source file will be newer +open(FILE, ">$XMLFile"); # Write some new data to the XML file +print FILE qq(\n); +close(FILE); +PassTime(time()); # Ensure current time later than file time + + + # Parse again with caching enabled +$opt = XMLin($XMLFile, cache => 'memcopy'); +is_deeply($opt, { one => 1, two => 2}, 'parsed expected data through cache'); + +$opt->{three} = 3; # Alter the returned structure + # Retrieve again from the cache +my $opt2 = XMLin($XMLFile, cache => 'memcopy'); + +ok(!defined($opt2->{three}), 'cache not modified'); + + +# Clean up and go + +unlink($XMLFile); +exit(0); + diff --git a/t/6_ObjIntf.t b/t/6_ObjIntf.t new file mode 100644 index 0000000..7b95292 --- /dev/null +++ b/t/6_ObjIntf.t @@ -0,0 +1,383 @@ +# $Id: 6_ObjIntf.t,v 1.8 2004/02/29 09:49:18 grantm Exp $ +# vim: syntax=perl + +use strict; + +$^W = 1; + +use Test::More tests => 37; + +############################################################################## +# Derived version of XML::Simple that returns everything in upper case +############################################################################## + +package XML::Simple::UC; + +use vars qw(@ISA); +@ISA = qw(XML::Simple); + +sub build_tree { + my $self = shift; + + my $tree = $self->SUPER::build_tree(@_); + + ($tree) = uctree($tree); + + return($tree); +} + +sub uctree { + foreach my $i (0..$#_) { + my $x = $_[$i]; + if(ref($x) eq 'ARRAY') { + $_[$i] = [ uctree(@$x) ]; + } + elsif(ref($x) eq 'HASH') { + $_[$i] = { uctree(%$x) }; + } + else { + $_[$i] = uc($x); + } + } + return(@_); +} + + +############################################################################## +# Derived version of XML::Simple that uses CDATA sections for escaping +############################################################################## + +package XML::Simple::CDE; + +use vars qw(@ISA); +@ISA = qw(XML::Simple); + +sub escape_value { + my $self = shift; + + my($data) = @_; + + if($data =~ /[&<>"]/) { + $data = ''; + } + + return($data); +} + + +############################################################################## +# Start of the test script itself +############################################################################## + +package main; + +use XML::Simple; + +# Check error handling in constructor + +$@=''; +$_ = eval { XML::Simple->new('searchpath') }; +is($_, undef, 'invalid number of options are trapped'); +like($@, qr/Default options must be name=>value pairs \(odd number supplied\)/, +'with correct error message'); + + +my $xml = q( + + R.E.M. + Automatic For The People + Drive + Try Not To Breathe + The Sidewinder Sleeps Tonite + Everybody Hurts + New Orleans Instrumental No. 1 + Sweetness Follows + Monty Got A Raw Deal + Ignoreland + Star Me Kitten + Man On The Moon + Nightswimming + Find The River + + +); + +my %opts1 = ( + keyattr => { disc => 'cddbid', track => 'number' }, + keeproot => 1, + contentkey => 'title', + forcearray => [ qw(disc album) ] +); + +my %opts2 = ( + keyattr => { } +); + +my %opts3 = ( + keyattr => { disc => 'cddbid', track => 'number' }, + keeproot => 1, + contentkey => '-title', + forcearray => [ qw(disc album) ] +); + +my $xs1 = new XML::Simple( %opts1 ); +my $xs2 = new XML::Simple( %opts2 ); +my $xs3 = new XML::Simple( %opts3 ); +isa_ok($xs1, 'XML::Simple', 'object one'); +isa_ok($xs2, 'XML::Simple', 'object two'); +isa_ok($xs3, 'XML::Simple', 'object three'); +is_deeply(\%opts1, { + keyattr => { disc => 'cddbid', track => 'number' }, + keeproot => 1, + contentkey => 'title', + forcearray => [ qw(disc album) ] +}, 'options hash was not corrupted'); + +my $exp1 = { + 'cddatabase' => { + 'disc' => { + '960b750c' => { + 'id' => '9362-45055-2', + 'album' => [ 'Automatic For The People' ], + 'artist' => 'R.E.M.', + 'track' => { + 1 => { 'title' => 'Drive' }, + 2 => { 'title' => 'Try Not To Breathe' }, + 3 => { 'title' => 'The Sidewinder Sleeps Tonite' }, + 4 => { 'title' => 'Everybody Hurts' }, + 5 => { 'title' => 'New Orleans Instrumental No. 1' }, + 6 => { 'title' => 'Sweetness Follows' }, + 7 => { 'title' => 'Monty Got A Raw Deal' }, + 8 => { 'title' => 'Ignoreland' }, + 9 => { 'title' => 'Star Me Kitten' }, + 10 => { 'title' => 'Man On The Moon' }, + 11 => { 'title' => 'Nightswimming' }, + 12 => { 'title' => 'Find The River' } + } + } + } + } +}; + +my $ref1 = $xs1->XMLin($xml); +is_deeply($ref1, $exp1, 'parsed expected data via object 1'); + + +# Try using the other object + +my $exp2 = { + 'disc' => { + 'album' => 'Automatic For The People', + 'artist' => 'R.E.M.', + 'cddbid' => '960b750c', + 'id' => '9362-45055-2', + 'track' => [ + { 'number' => 1, 'content' => 'Drive' }, + { 'number' => 2, 'content' => 'Try Not To Breathe' }, + { 'number' => 3, 'content' => 'The Sidewinder Sleeps Tonite' }, + { 'number' => 4, 'content' => 'Everybody Hurts' }, + { 'number' => 5, 'content' => 'New Orleans Instrumental No. 1' }, + { 'number' => 6, 'content' => 'Sweetness Follows' }, + { 'number' => 7, 'content' => 'Monty Got A Raw Deal' }, + { 'number' => 8, 'content' => 'Ignoreland' }, + { 'number' => 9, 'content' => 'Star Me Kitten' }, + { 'number' => 10, 'content' => 'Man On The Moon' }, + { 'number' => 11, 'content' => 'Nightswimming' }, + { 'number' => 12, 'content' => 'Find The River' } + ] + } +}; + +my $ref2 = $xs2->XMLin($xml); +is_deeply($ref2, $exp2, 'parsed expected data via object 2'); + + +# Try using the third object + +my $exp3 = { + 'cddatabase' => { + 'disc' => { + '960b750c' => { + 'id' => '9362-45055-2', + 'album' => [ 'Automatic For The People' ], + 'artist' => 'R.E.M.', + 'track' => { + 1 => 'Drive', + 2 => 'Try Not To Breathe', + 3 => 'The Sidewinder Sleeps Tonite', + 4 => 'Everybody Hurts', + 5 => 'New Orleans Instrumental No. 1', + 6 => 'Sweetness Follows', + 7 => 'Monty Got A Raw Deal', + 8 => 'Ignoreland', + 9 => 'Star Me Kitten', + 10 => 'Man On The Moon', + 11 => 'Nightswimming', + 12 => 'Find The River' + } + } + } + } +}; + +my $ref3 = $xs3->XMLin($xml); +is_deeply($ref3, $exp3, 'parsed expected data via object 3'); + + +# Confirm default options in object merge correctly with options as args + +$ref1 = $xs1->XMLin($xml, keyattr => [], forcearray => 0); + +is_deeply($ref1, { # Parsed to what we expected + 'cddatabase' => { + 'disc' => { + 'album' => 'Automatic For The People', + 'id' => '9362-45055-2', + 'artist' => 'R.E.M.', + 'cddbid' => '960b750c', + 'track' => [ + { 'number' => 1, 'title' => 'Drive' }, + { 'number' => 2, 'title' => 'Try Not To Breathe' }, + { 'number' => 3, 'title' => 'The Sidewinder Sleeps Tonite' }, + { 'number' => 4, 'title' => 'Everybody Hurts' }, + { 'number' => 5, 'title' => 'New Orleans Instrumental No. 1' }, + { 'number' => 6, 'title' => 'Sweetness Follows' }, + { 'number' => 7, 'title' => 'Monty Got A Raw Deal' }, + { 'number' => 8, 'title' => 'Ignoreland' }, + { 'number' => 9, 'title' => 'Star Me Kitten' }, + { 'number' => 10, 'title' => 'Man On The Moon' }, + { 'number' => 11, 'title' => 'Nightswimming' }, + { 'number' => 12, 'title' => 'Find The River' } + ] + } + } +}, 'successfully merged options'); + + +# Confirm that default options in object still work as expected + +$ref1 = $xs1->XMLin($xml); +is_deeply($ref1, $exp1, 'defaults were not affected by merge'); + + +# Confirm they work for output too + +$_ = $xs1->XMLout($ref1); + +ok(s{Drive} {}, 't1'); +ok(s{Try Not To Breathe} {}, 't2'); +ok(s{The Sidewinder Sleeps Tonite} {}, 't3'); +ok(s{Everybody Hurts} {}, 't4'); +ok(s{New Orleans Instrumental No. 1}{}, 't5'); +ok(s{Sweetness Follows} {}, 't6'); +ok(s{Monty Got A Raw Deal} {}, 't7'); +ok(s{Ignoreland} {}, 't8'); +ok(s{Star Me Kitten} {}, 't9'); +ok(s{Man On The Moon} {}, 't10'); +ok(s{Nightswimming} {}, 't11'); +ok(s{Find The River} {}, 't12'); +ok(s{Automatic For The People} {}, 'ttl'); +ok(s{cddbid="960b750c"}{ATTR}, 'cddbid'); +ok(s{id="9362-45055-2"}{ATTR}, 'id'); +ok(s{artist="R.E.M."} {ATTR}, 'artist'); +ok(s{(\s*){13}\s*}{}s, 'disc'); +ok(m{^\s*<(cddatabase)>\s*\s*\s*$}, 'database'); + + +# Confirm error when mandatory parameter missing + +$_ = eval { + $xs1->XMLout(); +}; +ok(!defined($_), 'XMLout() method call with no args proves fatal'); +like($@, qr/XMLout\(\) requires at least one argument/, +'with correct error message'); + + +# Check that overriding build_tree() method works + +$xml = q( + + Apollo +
10 Downing Street
+ + +); + +my $xsp = new XML::Simple::UC(); +$ref1 = $xsp->XMLin($xml); +is_deeply($ref1, { + 'SERVER' => { + 'NAME' => 'APOLLO', + 'ADDRESS' => '10 DOWNING STREET' + } +}, 'inheritance works with build_tree() overridden'); + + +# Check that overriding escape_value() method works + +my $ref = { + 'server' => { + 'address' => '12->14 "Puf&Stuf" Drive' + } +}; + +$xsp = new XML::Simple::CDE(); + +$_ = $xsp->XMLout($ref); + +like($_, qr{\s* + 14\s+"Puf&Stuf"\s+Drive\]\]>"\s*/>\s* +}xs, 'inheritance works with escape_value() overridden'); + + +# Check variables defined in the constructor don't get trounced for +# subsequent parses + +$xs1 = XML::Simple->new( + contentkey => '-content', + varattr => 'xsvar', + variables => { conf_dir => '/etc', log_dir => '/tmp' } +); + +$xml = q( + /var/log + ${conf_dir}/appname.conf + ${log_dir}/appname.log + ${log_dir}/appname.dbg +); + +my $opt = $xs1->XMLin($xml); +is_deeply($opt, { + file => { + config_file => '/etc/appname.conf', + log_file => '/var/log/appname.log', + debug_file => '/var/log/appname.dbg', + }, + dir => { xsvar => 'log_dir', content => '/var/log' }, +}, 'variables from XML merged with predefined variables'); + +$xml = q( + ${conf_dir}/appname.conf + ${log_dir}/appname.log + ${log_dir}/appname.dbg +); + +$opt = $xs1->XMLin($xml); +is_deeply($opt, { + file => { + config_file => '/etc/appname.conf', + log_file => '/tmp/appname.log', + debug_file => '/tmp/appname.dbg', + }, +}, 'variables from XML merged with predefined variables'); + +# check that unknown options passed to the constructor are rejected + +$@ = undef; +eval { $xs1 = XML::Simple->new(KeyAttr => {}, WibbleFlibble => 1) }; +ok(defined($@), "unrecognised option caught by constructor"); +like($@, qr/^Unrecognised option: WibbleFlibble at/, + "correct message in exception"); + +exit(0); diff --git a/t/7_SaxStuff.t b/t/7_SaxStuff.t new file mode 100644 index 0000000..9986659 --- /dev/null +++ b/t/7_SaxStuff.t @@ -0,0 +1,282 @@ +# $Id: 7_SaxStuff.t,v 1.5 2005/01/29 04:17:42 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use File::Spec; +use IO::File; + +$^W = 1; + + +BEGIN { + unshift @INC, File::Spec->catfile('t', 'lib'); + + eval { require XML::SAX; }; + if($@) { + plan skip_all => 'no XML::SAX'; + } +} + +use TagsToUpper; + +# Initialise filenames and check they're there + +my $SrcFile = File::Spec->catfile('t', 'desertnet.src'); +my $XMLFile = File::Spec->catfile('t', 'desertnet.xml'); +my $CacheFile = File::Spec->catfile('t', 'desertnet.stor'); + +unless(-e $SrcFile) { + plan skip_all => 'test data missing'; +} + + +plan tests => 14; + + +############################################################################## +# S U P P O R T R O U T I N E S +############################################################################## + +############################################################################## +# Copy a file +# + +sub CopyFile { + my($Src, $Dst) = @_; + + open(IN, $Src) || return(undef); + local($/) = undef; + my $Data = ; + close(IN); + + open(OUT, ">$Dst") || return(undef); + print OUT $Data; + close(OUT); + + return(1); +} + + +############################################################################## +# T E S T R O U T I N E S +############################################################################## + +use XML::Simple; + +# Initialise test data + +my $Expected = { + 'server' => { + 'sahara' => { + 'osversion' => '2.6', + 'osname' => 'solaris', + 'address' => [ + '10.0.0.101', + '10.0.1.101' + ] + }, + 'gobi' => { + 'osversion' => '6.5', + 'osname' => 'irix', + 'address' => '10.0.0.102' + }, + 'kalahari' => { + 'osversion' => '2.0.34', + 'osname' => 'linux', + 'address' => [ + '10.0.0.103', + '10.0.1.103' + ] + } + } +}; + +my $xml = ''; + + +# Force default behaviour of using SAX parser if it is available (which it +# is or we wouldn't be here). + +$XML::Simple::PREFERRED_PARSER = ''; + +ok(CopyFile($SrcFile, $XMLFile), 'created source XML file'); +if ('VMS' eq $^O) { + 1 while (unlink($CacheFile)); +} else { + unlink($CacheFile); +} +ok(! -e $CacheFile, 'deleted old cache files'); + +# Pass in a filename to check parse_uri() + +my $opt = XMLin($XMLFile); +is_deeply($opt, $Expected, 'parsed expected value from file'); + + +# Pass in an IO::File object to test parse_file() + +my $fh = IO::File->new("<$XMLFile"); +isa_ok($fh, 'IO::File', '$fh'); +$opt = XMLin($fh); +is_deeply($opt, $Expected, 'parsed expected value from IO::File object'); +$fh->close(); + + +# Pass in a string to test parse_string() + +if(open(XMLFILE, "<$XMLFile")) { + local($/) = undef; + $xml = ; + close(XMLFILE); +} +$opt = XMLin($xml); +is_deeply($opt, $Expected, 'parsed expected value from string'); + + +# Pass in '-' for STDIN + +open(OLDSTDIN, "<&STDIN"); +close(STDIN); +open(STDIN, "<$XMLFile"); +$opt = XMLin('-'); +is_deeply($opt, $Expected, "parsed expected value from STDIN ('-')"); + +open(STDIN, "<&OLDSTDIN"); +close(OLDSTDIN); + + +# Try using XML:Simple object as a SAX handler + +my $simple = XML::Simple->new(); +my $parser = XML::SAX::ParserFactory->parser(Handler => $simple); + +$opt = $parser->parse_uri($XMLFile); +is_deeply($opt, $Expected, + 'XML::Simple as a SAX handler returned expected value'); + + +# Try again but make sure options from the constructor are being used + +$simple = XML::Simple->new( + keyattr => { server => 'osname' }, + forcearray => ['address'], +); +$parser = XML::SAX::ParserFactory->parser(Handler => $simple); + +$opt = $parser->parse_uri($XMLFile); +my $Expected2 = { + 'server' => { + 'irix' => { + 'address' => [ '10.0.0.102' ], + 'osversion' => '6.5', + 'name' => 'gobi' + }, + 'solaris' => { + 'address' => [ '10.0.0.101', '10.0.1.101' ], + 'osversion' => '2.6', + 'name' => 'sahara' + }, + 'linux' => { + 'address' => [ '10.0.0.103', '10.0.1.103' ], + 'osversion' => '2.0.34', + 'name' => 'kalahari' + } + } +}; + +is_deeply($opt, $Expected2, 'options passed to handler contructor work'); + + +# Try using XML::Simple to drive a SAX pipeline + +my $Expected3 = { + 'SERVER' => { + 'sahara' => { + 'OSVERSION' => '2.6', + 'OSNAME' => 'solaris', + 'ADDRESS' => [ + '10.0.0.101', + '10.0.1.101' + ] + }, + 'gobi' => { + 'OSVERSION' => '6.5', + 'OSNAME' => 'irix', + 'ADDRESS' => '10.0.0.102' + }, + 'kalahari' => { + 'OSVERSION' => '2.0.34', + 'OSNAME' => 'linux', + 'ADDRESS' => [ + '10.0.0.103', + '10.0.1.103' + ] + } + } +}; +my $simple2 = XML::Simple->new(keyattr => [qw(NAME)]); +my $filter = TagsToUpper->new(Handler => $simple2); + +my $opt2 = XMLout($opt, + keyattr => { server => 'osname' }, + Handler => $filter, +); +is_deeply($opt2, $Expected3, 'driving a SAX pipeline with XML::Simple worked'); + + +# Confirm that 'handler' is a synonym for 'Handler' + +$simple2 = XML::Simple->new(keyattr => [qw(NAME)]); +$filter = TagsToUpper->new(Handler => $simple2); +$opt2 = XMLout($opt, + keyattr => { server => 'osname' }, + handler => $filter, +); +is_deeply($opt2, $Expected3, "'handler' is a synonym for 'Handler'"); + + +# Confirm that DataHandler routine gets called + +$xml = q(onetwothree); +$simple = XML::Simple->new( + DataHandler => sub { + my $xs = shift; + my $data = shift; + return(join(',', @$data)); + } +); +$parser = XML::SAX::ParserFactory->parser(Handler => $simple); +my $result = $parser->parse_string($xml); + +is($result, 'one,two,three', "'DataHandler' option works"); + + +# Confirm that 'datahandler' is a synonym for 'DataHandler' + +$simple = XML::Simple->new( + datahandler => sub { + my $xs = shift; + my $data = shift; + return(join(',', reverse(@$data))); + } +); +$parser = XML::SAX::ParserFactory->parser(Handler => $simple); +$result = $parser->parse_string($xml); + +is($result, 'three,two,one', "'datahandler' is a synonym for 'DataHandler'"); + + +# Confirm keeproot logic gets called + +$simple = XML::Simple->new(keeproot => 1); +$parser = XML::SAX::ParserFactory->parser(Handler => $simple); +$opt = $parser->parse_string(''); +is_deeply($opt, {opt => {a => 1, b => 2}}, "keeproot works with SAX pipelines"); + +# Clean up and go + +unlink($CacheFile); +unlink($XMLFile); +exit(0); + diff --git a/t/8_Namespaces.t b/t/8_Namespaces.t new file mode 100644 index 0000000..b4cef66 --- /dev/null +++ b/t/8_Namespaces.t @@ -0,0 +1,230 @@ +# $Id: 8_Namespaces.t,v 1.7 2004/04/05 09:12:51 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use File::Spec; +use IO::File; + +$^W = 1; + + +eval { require XML::SAX; }; +if($@) { + plan skip_all => 'no XML::SAX'; +} + +eval { require XML::NamespaceSupport; }; +if($@) { + plan skip_all => "no XML::NamespaceSupport"; +} +if($XML::NamespaceSupport::VERSION < 1.04) { + plan skip_all => "XML::NamespaceSupport is too old (upgrade to 1.04 or better)"; +} + +plan tests => 8; + + +############################################################################## +# S U P P O R T R O U T I N E S +############################################################################## + +############################################################################## +# Copy a file +# + +sub CopyFile { + my($Src, $Dst) = @_; + + open(IN, $Src) || return(undef); + local($/) = undef; + my $Data = ; + close(IN); + + open(OUT, ">$Dst") || return(undef); + print OUT $Data; + close(OUT); + + return(1); +} + + +############################################################################## +# T E S T R O U T I N E S +############################################################################## + +use XML::Simple; + +# Force default behaviour of using SAX parser if it is available (which it +# is or we wouldn't be here). + +$XML::Simple::PREFERRED_PARSER = ''; + +# Confirm that by default qnames are not expanded on input + +my $xml = q( + + one + two + three + + +); + +my $expected = { + 'perl:list' => { + 'count' => '3', + 'item' => [ + 'one', + 'two', + 'three' + ], + 'perl:type' => 'array', + 'test' => { + 'xmlns:perl' => 'http://www.microsoft.com', + 'perl:tm' => 'trademark', + } + }, + 'xmlns:perl' => 'http://www.perl.com/' +}; + +my $opt = XMLin($xml); +is_deeply($opt, $expected, 'qnames are not expanded by default'); + + +# Try again with nsexpand option set + +$expected = { + '{http://www.perl.com/}list' => { + 'count' => '3', + 'item' => [ + 'one', + 'two', + 'three' + ], + '{http://www.perl.com/}type' => 'array', + 'test' => { + '{http://www.microsoft.com}tm' => 'trademark', + '{http://www.w3.org/2000/xmlns/}perl' => 'http://www.microsoft.com' + } + }, + '{http://www.w3.org/2000/xmlns/}perl' => 'http://www.perl.com/' +}; + +$opt = XMLin($xml, nsexpand => 1); +is_deeply($opt, $expected, 'qnames are expanded on request'); + + +# Confirm that output expansion does not occur by default + +$opt = { + '{http://www.w3.org/2000/xmlns/}perl' => 'http://www.perl.com/', + '{http://www.perl.com/}attr' => 'value', + 'bare' => 'Beer!', + '{http://www.perl.com/}element' => [ 'data' ], +}; + +$xml = XMLout($opt); +like($xml, qr{ + ^\s* + \s*<{http://www.perl.com/}element\s*>data + \s* + \s*$ +}sx, 'clarkian names not converted to qnames on output by default'); + + +# Confirm nsexpand option works on output + +$xml = XMLout($opt, nsexpand => 1); +ok($xml =~ m{ + ^\s* + \s*data + \s* + \s*$ +}sx, 'clarkian names are converted to qnames on output on request'); + + +# Check that default namespace is correctly read in ... + +$xml = q( + + Tom + Dick + Larry + + +); + +$expected = { + 'xmlns' => 'http://www.orgsoc.org/', + '{http://www.orgsoc.org/}list' => { + '{http://www.orgsoc.org/}member' => [ 'Tom', 'Dick', 'Larry' ], + } +}; + +$opt = XMLin($xml, nsexpand => 1); +is_deeply($opt, $expected, 'expansion of default namespace works'); + + +# ... and written out + +$xml = XMLout($opt, nsexpand => 1); +like($xml, qr{ + ^\s* + \s* + \s*Tom + \s*Dick + \s*Larry + \s* + \s* + \s*$ +}sx, 'default namespaces are output correctly too'); + + +# Check that the autogeneration of namespaces works as we expect + +$opt = { + 'xmlns' => 'http://www.orgsoc.org/', + '{http://www.orgsoc.org/}list' => { + '{http://www.orgsoc.org/}member' => [ 'Tom', 'Dick', 'Larry' ], + '{http://www.phantom.com/}director' => [ 'Bill', 'Ben' ], + } +}; + +$xml = XMLout($opt, nsexpand => 1); +my $prefix = ''; +if($xml =~ m{}) { + $prefix = $1; +} + # regex match split in two to workaround 5.8.1/utf8/regex match prob +like($xml, qr{ + \s* + .*? + + \s* +}sx, 'namespace prefixes are generated automatically (part 1)'); + +like($xml, qr{ + (\s*Tom + \s*Dick + \s*Larry + |\s*<${prefix}:director>Bill + \s*<${prefix}:director>Ben){2} + #\s* +}sx, 'namespace prefixes are generated automatically (part 2)'); + + +exit(0); + diff --git a/t/9_Strict.t b/t/9_Strict.t new file mode 100644 index 0000000..48f213c --- /dev/null +++ b/t/9_Strict.t @@ -0,0 +1,341 @@ +# $Id: 9_Strict.t,v 1.6 2007/08/15 10:36:48 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; + +$^W = 1; + +plan tests => 40; + + +############################################################################## +# T E S T R O U T I N E S +############################################################################## + +eval "use XML::Simple qw(:strict);"; +ok(!$@, 'XML::Simple loads ok with qw(:strict)'); + +# Check that the basic functionality still works + +my $xml = q(); + +$@ = ''; +my $opt = eval { + XMLin($xml, forcearray => 1, keyattr => {}); +}; +is($@, '', 'XMLin() did not fail'); + +my $keys = join(' ', sort keys %$opt); + +is($keys, 'name1 name2', 'and managed to produce the expected results'); + + +# Confirm that forcearray cannot be omitted + +eval { + $opt = XMLin($xml, keyattr => {}); +}; + +isnt($@, '', 'omitting forcearray was a fatal error'); +like($@, qr/(?i)No value specified for 'forcearray'/, + 'with the correct error message'); + + +# Confirm that keyattr cannot be omitted + +eval { + $opt = XMLin($xml, forcearray => []); +}; + +isnt($@, '', 'omitting keyattr was a fatal error'); +like($@, qr/(?i)No value specified for 'keyattr'/, + 'with the correct error message'); + + +# Confirm that element names from keyattr cannot be omitted from forcearray + +eval { + $opt = XMLin($xml, keyattr => { part => 'partnum' }, forcearray => 0); +}; + +isnt($@, '', 'omitting forcearray for elements in keyattr was a fatal error'); +like($@, qr/(?i) set in keyattr but not in forcearray/, + 'with the correct error message'); + + +eval { + $opt = XMLin($xml, keyattr => { part => 'partnum' }, forcearray => ['x','y']); +}; + +isnt($@, '', 'omitting keyattr elements from forcearray was a fatal error'); +like($@, qr/(?i) set in keyattr but not in forcearray/, + 'with the correct error message'); + + +# Confirm that missing key attributes are detected + +$xml = q( + + + + + +); + +eval { + $opt = XMLin($xml, keyattr => { part => 'partnum' }, forcearray => 1); +}; + +isnt($@, '', 'key attribute missing from names element was a fatal error'); +like($@, qr/(?i) element has no 'partnum' key attribute/, + 'with the correct error message'); + + +# Confirm that non-unique values in key attributes are detected + +$xml = q( + + + + + +); + +eval { + $opt = XMLin($xml, keyattr => { part => 'partnum' }, forcearray => 1); +}; + +isnt($@, '', 'non-unique key attribute values was a fatal error'); +like($@, qr/(?i) element has non-unique value in 'partnum' key attribute: 12345/, + 'with the correct error message'); + + +# Confirm that stringification of references is trapped + +$xml = q( + + + Bob + 21 + + +); + +eval { + $opt = XMLin($xml, keyattr => { item => 'name' }, forcearray => ['item']); +}; + +isnt($@, '', 'key attribute not a scalar was a fatal error'); +like($@, qr/(?i) element has non-scalar 'name' key attribute/, + 'with the correct error message'); + + +############################################################################## +# Now confirm that XMLout gets checked too +# + + +# Check that the basic functionality still works under :strict + +my $ref = { + person => [ + { name => 'bob' }, + { name => 'kate' }, + ] +}; + +$@ = ''; +$xml = eval { + XMLout($ref, keyattr => {}, rootname => 'list'); +}; +is($@, '', 'XMLout() did not fail'); + +like($xml, qr{ + ^\s* + \s* + \s* + \s*\s*$ + }xs, 'and managed to produce the expected results'); + + +# Confirm that keyattr cannot be omitted + +$@ = ''; +eval { + XMLout($ref, rootname => 'list'); +}; + +isnt($@, '', 'omitting keyattr was a fatal error'); +like($@, qr/(?i)No value specified for 'keyattr'/, + 'with the correct error message'); + + +# Confirm that forcearray can be omitted (only rqd on input) + +$@ = ''; +eval { + XMLout($ref, keyattr => {x => 'y'}); +}; + +is($@, '', 'omitting forcearray was not a fatal error on output'); + + +############################################################################## +# Now repeat all that using the OO syntax +############################################################################## + +# Check that the basic functionality still works + +$xml = q(); + +my $xs = XML::Simple->new(forcearray => 1, keyattr => {}); + +$@ = ''; +$opt = eval { + $xs->XMLin($xml); +}; +is($@, '', '$xs->XMLin() did not fail'); + +$keys = join(' ', sort keys %$opt); + +is($keys, 'name1 name2', 'and managed to produce the expected results'); + +# Confirm that forcearray cannot be omitted + +$xs = XML::Simple->new(keyattr => {}); + +$@ = ''; +eval { + $xs->XMLin($xml); +}; + +isnt($@, '', 'omitting forcearray was a fatal error'); +like($@, qr/(?i)No value specified for 'forcearray'/, + 'with the correct error message'); + + +# Confirm that keyattr cannot be omitted + +$xs = XML::Simple->new(forcearray => []); + +eval { + $xs->XMLin($xml); +}; + +isnt($@, '', 'omitting keyattr was a fatal error'); +like($@, qr/(?i)No value specified for 'keyattr'/, + 'with the correct error message'); + + +# Confirm that element names from keyattr cannot be omitted from forcearray + +$xs = XML::Simple->new(keyattr => { part => 'partnum' }, forcearray => 0); + +eval { + $xs->XMLin($xml); +}; + +isnt($@, '', 'omitting forcearray for elements in keyattr was a fatal error'); +like($@, qr/(?i) set in keyattr but not in forcearray/, + 'with the correct error message'); + + +$xs = XML::Simple->new(keyattr => { part => 'partnum' }, forcearray => ['x','y']); + +eval { + $xs->XMLin($xml); +}; + +isnt($@, '', 'omitting keyattr elements from forcearray was a fatal error'); +like($@, qr/(?i) set in keyattr but not in forcearray/, + 'with the correct error message'); + + +# Confirm that missing key attributes are detected + +$xml = q( + + + + + +); + +$xs = XML::Simple->new(keyattr => { part => 'partnum' }, forcearray => 1); +eval { + $xs->XMLin($xml); +}; + +isnt($@, '', 'key attribute missing from names element was a fatal error'); +like($@, qr/(?i) element has no 'partnum' key attribute/, + 'with the correct error message'); + + +# Confirm that stringification of references is trapped + +$xml = q( + + + Bob + 21 + + +); + +$xs = XML::Simple->new(keyattr => { item => 'name' }, forcearray => ['item']); + +eval { + $xs->XMLin($xml); +}; + +isnt($@, '', 'key attribute not a scalar was a fatal error'); +like($@, qr/(?i) element has non-scalar 'name' key attribute/, + 'with the correct error message'); + + +############################################################################## +# Now confirm that XMLout gets checked too +# + + +# Check that the basic functionality still works under :strict + +$ref = { + person => [ + { name => 'bob' }, + { name => 'kate' }, + ] +}; + +$xs = XML::Simple->new(keyattr => {}, rootname => 'list'); + +$@ = ''; +$xml = eval { + $xs->XMLout($ref); +}; +is($@, '', 'XMLout() did not fail'); + +like($xml, qr{ + ^\s* + \s* + \s* + \s*\s*$ + }xs, 'and managed to produce the expected results'); + + +# Confirm that keyattr cannot be omitted + +$xs = XML::Simple->new(rootname => 'list'); + +eval { + $xs->XMLout($ref); +}; + +isnt($@, '', 'omitting keyattr was a fatal error'); +like($@, qr/(?i)No value specified for 'keyattr'/, + 'with the correct error message'); + + +exit(0); + diff --git a/t/A_XMLParser.t b/t/A_XMLParser.t new file mode 100644 index 0000000..ea33772 --- /dev/null +++ b/t/A_XMLParser.t @@ -0,0 +1,128 @@ +# $Id: A_XMLParser.t,v 1.1 2004/02/29 09:49:18 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use IO::File; +use File::Spec; + +$^W = 1; + + +# Initialise filenames and check they're there + +my $XMLFile = File::Spec->catfile('t', 'test1.xml'); # t/test1.xml + +unless(-e $XMLFile) { + plan skip_all => 'Test data missing'; +} + +eval { require XML::Parser; }; +unless($INC{'XML/Parser.pm'}) { + plan skip_all => 'no XML::Parser'; +} + +plan tests => 14; + +use XML::Simple; + +my $last_warning = ''; +my $opt; + + +# Use environment variable to set preferred parser + +$ENV{XML_SIMPLE_PREFERRED_PARSER} = 'XML::Parser'; + + +# Try using a SAX-only option + +{ + local($SIG{__WARN__}) = \&warn_handler; + + $@ = ''; + $opt = eval { XMLin('', nsexpand => 1) }; +} + +isnt($last_warning, '', "Parsing caused warning (as expected)"); +like($last_warning, qr/'nsexpand' option requires XML::SAX/, + 'Message contained expected text'); +is_deeply($opt, {y => 'z'}, "Parsing was successful"); + + +# Check for deprecation warning + +{ + local($SIG{__WARN__}) = \&warn_handler; + + $@ = ''; + $last_warning = ''; + $opt = eval { XMLin('', ParserOpts => [ ParseParamEnt => 1 ]) }; +} + +isnt($last_warning, '', "Using ParserOpts caused warning (as expected)"); +like($last_warning, qr/'ParserOpts' is deprecated/, + 'Message contained expected text'); +is_deeply($opt, {y => 'z'}, "Parsing was successful"); + + +# Check it doesn't happen if warnings disabled + +{ + local($SIG{__WARN__}) = \&warn_handler; + + $@ = ''; + $last_warning = ''; + local($^W) = 0; + $opt = eval { XMLin('', ParserOpts => [ ParseParamEnt => 1 ]) }; +} + +is($last_warning, '', "ParserOpts warning uppressed successfully"); +is_deeply($opt, {y => 'z'}, "Parsing was successful"); + + + +# Try parsing a string + +$@ = ''; +$opt = eval { + XMLin(q()); +}; + +my $expected = { + name1 => 'value1', + name2 => 'value2', + }; + +is($@, '', "No error when parsing"); +is_deeply($opt, $expected, 'matches expectations (attributes)'); + + +# Try parsing a named external file + +$@ = ''; +$opt = eval{ XMLin($XMLFile); }; +is($@, '', "XML::Parser didn't choke on named external file"); +is_deeply($opt, { + location => 't/test1.xml' +}, 'and contents parsed as expected'); + + +# Try parsing from an IO::Handle + +$@ = ''; +my $fh = new IO::File; +$XMLFile = File::Spec->catfile('t', '1_XMLin.xml'); # t/1_XMLin.xml +eval { + $fh->open($XMLFile) || die "$!"; + $opt = XMLin($fh); +}; +is($@, '', "XML::Parser didn't choke on an IO::File object"); +is($opt->{location}, 't/1_XMLin.xml', 'and it parsed the right file'); + + +exit(0); + +sub warn_handler { + $last_warning = $_[0]; +} diff --git a/t/B_Hooks.t b/t/B_Hooks.t new file mode 100644 index 0000000..cde0b55 --- /dev/null +++ b/t/B_Hooks.t @@ -0,0 +1,136 @@ +# $Id: B_Hooks.t,v 1.2 2006/10/12 08:57:52 grantm Exp $ +# vim: syntax=perl + +use strict; +use Test::More; +use File::Spec; + +plan tests => 12; + +use_ok('XML::Simple'); + +SKIP: { + eval { require Tie::IxHash }; + + skip "Tie::IxHash not installed", 3 if $@; + + $@ = ''; + eval <<'EOF'; + + package SimpleOrder; + + use base qw(XML::Simple); + use Tie::IxHash; + + sub new_hashref { + my $self = shift; + my %hash; + tie %hash, 'Tie::IxHash', @_; + return \%hash; + } +EOF + ok(!$@, 'no errors processing SimpleOrder'); + + my $xs = SimpleOrder->new; + my $xml = q{ + + I + II + III + IV + V + VI + VII + + }; + my $expected = { + 'one' => { 'content' => 'I' }, + 'two' => { 'content' => 'II' }, + 'three' => { 'content' => 'III' }, + 'four' => { 'content' => 'IV' }, + 'five' => { 'content' => 'V' }, + 'six' => { 'content' => 'VI' }, + 'seven' => { 'content' => 'VII' }, + }; + + my $data = $xs->xml_in($xml); + + is_deeply($data->{num}, $expected, 'hash content looks good'); + + is_deeply( + [ keys %{$data->{num}} ], + [ qw(one two three four five six seven) ], + 'order of the hash keys looks good too' + ); + +} + + +my $xs = XML::Simple->new(cache => 'storable'); +my $sx = ElbarotsXS->new(cache => 'storable'); + +isa_ok($sx, 'XML::Simple', 'object of class ElbarotsXS'); + +my $src_file = File::Spec->catfile('t', 'test1.xml'); + +is( + $xs->storable_filename($src_file), + File::Spec->catfile('t', 'test1.stor'), + 'default storable cache filename looks good' +); + +my $cache_file = File::Spec->catfile('t', '1tset.stor'),; +is( + $sx->storable_filename($src_file), + $cache_file, + 'overridden storable cache filename looks good' +); + +SKIP: { + eval { require Storable }; + + skip "Storable not installed", 2 if $@; + + unlink($cache_file), + ok(! -e $cache_file, 'overridden cache file does not exist before parse'); + my $data = $sx->xml_in($src_file); + ok(-e $cache_file, 'overridden cache file does exist after parse'); + unlink($cache_file), +} + +my $data = eval { + $xs = XML::Simple->new(cache => 'floogle'); + $xs->xml_in($src_file); +}; +ok($@, 'bad cache scheme was rejected'); + +$data = eval { + $sx = ElbarotsXS->new(cache => 'floogle'); + $sx->xml_in($src_file); +}; +ok(! $@, 'custom cache scheme was not rejected'); +is_deeply( + $data, + { data => 'floogle' }, + 'custom cache reading method delivered the goods' +); + +exit 0; + + +package ElbarotsXS; + +use base 'XML::Simple'; + +sub storable_filename { + my($self, $path) = @_; + + my($vol, $dir, $file) = File::Spec->splitpath( $path ); + $file =~ s{\.xml$}{}; + + return File::Spec->catpath($vol, $dir, reverse($file) . '.stor'); +} + +sub cache_read_floogle { + return { data => 'floogle' }; +} diff --git a/t/desertnet.src b/t/desertnet.src new file mode 100644 index 0000000..b4148df --- /dev/null +++ b/t/desertnet.src @@ -0,0 +1,13 @@ + + +
10.0.0.101
+
10.0.1.101
+ + +
10.0.0.102
+ + +
10.0.0.103
+
10.0.1.103
+ + diff --git a/t/lib/TagsToUpper.pm b/t/lib/TagsToUpper.pm new file mode 100755 index 0000000..48883f9 --- /dev/null +++ b/t/lib/TagsToUpper.pm @@ -0,0 +1,38 @@ +package TagsToUpper; + +use XML::SAX::Base; + +use vars qw(@ISA); + +@ISA = ('XML::SAX::Base'); + +sub start_element { + my $self = shift; + my $element = shift; + +# print Data::Dumper->Dump([$element], ['element']); + to_upper($element); + foreach (values(%{$element->{Attributes}})) { to_upper($_); } + + $self->SUPER::start_element($element); +} + +sub end_element { + my $self = shift; + my $element = shift; + + to_upper($element); + + $self->SUPER::end_element($element); +} + +sub to_upper { + my $ref = shift; + + $ref->{LocalName} = uc($ref->{LocalName}) if($ref->{LocalName}); + $ref->{Name} = uc($ref->{Name}) if($ref->{LocalName}); + $ref->{Prefix} = uc($ref->{Prefix}) if($ref->{LocalName}); +} + +1; + diff --git a/t/srt.xml b/t/srt.xml new file mode 100644 index 0000000..32e2b53 --- /dev/null +++ b/t/srt.xml @@ -0,0 +1,72 @@ + + + + + + + + /_vt + /save\b + \.bak$ + \.\$\$\$$ + + + + + + + + wwwroot + + + + + + + + + + + wwwroot + + + + + + + + + + + + wwwroot + + \.pdf$ + + + + diff --git a/t/subdir/test2.xml b/t/subdir/test2.xml new file mode 100644 index 0000000..b5da6b4 --- /dev/null +++ b/t/subdir/test2.xml @@ -0,0 +1 @@ + diff --git a/t/test1.xml b/t/test1.xml new file mode 100644 index 0000000..03787f9 --- /dev/null +++ b/t/test1.xml @@ -0,0 +1 @@ + -- 2.7.4