summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLorry <lorry@roadtrain.codethink.co.uk>2012-07-23 15:02:57 +0100
committerLorry <lorry@roadtrain.codethink.co.uk>2012-07-23 15:02:57 +0100
commit5d0bfb3f0fb040f06092caeba89e6ae345fe8492 (patch)
tree7669b9da7bedf01514147ccd3fbd456d720cfb6a
downloadXML-Simple-5d0bfb3f0fb040f06092caeba89e6ae345fe8492.tar.gz
Tarball conversion
Diffstat
-rw-r--r--Changes284
-rw-r--r--LICENSE377
-rw-r--r--MANIFEST29
-rw-r--r--META.json46
-rw-r--r--META.yml23
-rw-r--r--Makefile.PL55
-rw-r--r--README13
-rw-r--r--dist.ini26
-rw-r--r--lib/XML/Simple.pm3337
-rw-r--r--lib/XML/Simple/FAQ.pod646
-rw-r--r--t/0_Config.t62
-rw-r--r--t/1_XMLin.t1510
-rw-r--r--t/1_XMLin.xml1
-rw-r--r--t/2_XMLout.t1211
-rw-r--r--t/3_Storable.t235
-rw-r--r--t/4_MemShare.t151
-rw-r--r--t/5_MemCopy.t159
-rw-r--r--t/6_ObjIntf.t380
-rw-r--r--t/7_SaxStuff.t279
-rw-r--r--t/8_Namespaces.t227
-rw-r--r--t/9_Strict.t373
-rw-r--r--t/A_XMLParser.t129
-rw-r--r--t/B_Hooks.t134
-rw-r--r--t/desertnet.src13
-rwxr-xr-xt/lib/TagsToUpper.pm38
-rw-r--r--t/release-pod-syntax.t15
-rw-r--r--t/srt.xml72
-rw-r--r--t/subdir/test2.xml1
-rw-r--r--t/test1.xml1
29 files changed, 9827 insertions, 0 deletions
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..82f4ffe
--- /dev/null
+++ b/Changes
@@ -0,0 +1,284 @@
+Revision history for XML-Simple
+
+2.20 2012-06-20 22:00:13 Pacific/Auckland
+ - Suppress warning from empty CDATA section (RT#58359 from Juan Antonio
+ Navarro Pérez)
+
+2.19_02 2012-06-19 20:33:53 Pacific/Auckland
+ - Reinstate XML::SAX::Expat dependency
+ - Fix warnings tests (broken in 2.19_01) which rely on global $^W
+
+2.19_01 2012-06-17 23:27:22 Pacific/Auckland
+ - Use lexical filehandles instead of old-style fileglobs (RT#77787 from
+ Quanah)
+ - Restrict scope of :strict mode to calling package (RT#41562 from Hannu
+ Aronsson)
+ - Fix POD typo (RT#45414 from Anirvan Chatterjee)
+ - Update POD to reflect best practise regarding :strict and options
+ - Change minimum Perl requirement to 5.008
+ - Switch to using Dist::Zilla for release management
+
+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/LICENSE b/LICENSE
new file mode 100644
index 0000000..612805d
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,377 @@
+This software is copyright (c) 2012 by Grant McLean.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+Terms of the Perl programming language system itself
+
+a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+b) the "Artistic License"
+
+--- The GNU General Public License, Version 1, February 1989 ---
+
+This software is Copyright (c) 2012 by Grant McLean.
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 1, February 1989
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
+--- The Artistic License 1.0 ---
+
+This software is Copyright (c) 2012 by Grant McLean.
+
+This is free software, licensed under:
+
+ The Artistic License 1.0
+
+The Artistic License
+
+Preamble
+
+The intent of this document is to state the conditions under which a Package
+may be copied, such that the Copyright Holder maintains some semblance of
+artistic control over the development of the package, while giving the users of
+the package the right to use and distribute the Package in a more-or-less
+customary fashion, plus the right to make reasonable modifications.
+
+Definitions:
+
+ - "Package" refers to the collection of files distributed by the Copyright
+ Holder, and derivatives of that collection of files created through
+ textual modification.
+ - "Standard Version" refers to such a Package if it has not been modified,
+ or has been modified in accordance with the wishes of the Copyright
+ Holder.
+ - "Copyright Holder" is whoever is named in the copyright or copyrights for
+ the package.
+ - "You" is you, if you're thinking about copying or distributing this Package.
+ - "Reasonable copying fee" is whatever you can justify on the basis of media
+ cost, duplication charges, time of people involved, and so on. (You will
+ not be required to justify it to the Copyright Holder, but only to the
+ computing community at large as a market that must bear the fee.)
+ - "Freely Available" means that no fee is charged for the item itself, though
+ there may be fees involved in handling the item. It also means that
+ recipients of the item may redistribute it under the same conditions they
+ received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications derived
+from the Public Domain or from the Copyright Holder. A Package modified in such
+a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided that
+you insert a prominent notice in each changed file stating how and when you
+changed that file, and provided that you do at least ONE of the following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or an
+ equivalent medium, or placing the modifications on a major archive site
+ such as ftp.uu.net, or by allowing the Copyright Holder to include your
+ modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict with
+ standard executables, which must also be provided, and provide a separate
+ manual page for each non-standard executable that clearly documents how it
+ differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or executable
+form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where to
+ get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of the Package
+ with your modifications.
+
+ c) accompany any non-standard executables with their corresponding Standard
+ Version executables, giving the non-standard executables non-standard
+ names, and clearly documenting the differences in manual pages (or
+ equivalent), together with instructions on where to get the Standard
+ Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this Package. You
+may not charge a fee for this Package itself. However, you may distribute this
+Package in aggregate with other (possibly commercial) programs as part of a
+larger (possibly commercial) software distribution provided that you do not
+advertise this Package as a product of your own.
+
+6. The scripts and library files supplied as input to or produced as output
+from the programs of this Package do not automatically fall under the copyright
+of this Package, but belong to whomever generated them, and may be sold
+commercially, and may be aggregated with this Package.
+
+7. C or perl subroutines supplied by you and linked into this Package shall not
+be considered part of this Package.
+
+8. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+The End
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..2578206
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,29 @@
+Changes
+LICENSE
+MANIFEST
+META.json
+META.yml
+Makefile.PL
+README
+dist.ini
+lib/XML/Simple.pm
+lib/XML/Simple/FAQ.pod
+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/release-pod-syntax.t
+t/srt.xml
+t/subdir/test2.xml
+t/test1.xml
diff --git a/META.json b/META.json
new file mode 100644
index 0000000..41f6e92
--- /dev/null
+++ b/META.json
@@ -0,0 +1,46 @@
+{
+ "abstract" : "Easily read/write XML (esp config files)",
+ "author" : [
+ "Grant McLean <grantm@cpan.org>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 4.200004, CPAN::Meta::Converter version 2.101670",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "XML-Simple",
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.31"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "XML::NamespaceSupport" : "1.04",
+ "XML::SAX" : "0.15",
+ "XML::SAX::Expat" : 0,
+ "perl" : "5.008"
+ }
+ },
+ "test" : {
+ "requires" : {
+ "Test::More" : "0.88"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "repository" : {
+ "type" : "git",
+ "url" : "git://github.com/grantm/xml-simple.git",
+ "web" : "http://github.com/grantm/xml-simple"
+ }
+ },
+ "version" : "2.20"
+}
+
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..79c77b1
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,23 @@
+---
+abstract: 'Easily read/write XML (esp config files)'
+author:
+ - 'Grant McLean <grantm@cpan.org>'
+build_requires:
+ Test::More: 0.88
+configure_requires:
+ ExtUtils::MakeMaker: 6.31
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 4.200004, CPAN::Meta::Converter version 2.101670'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: XML-Simple
+requires:
+ XML::NamespaceSupport: 1.04
+ XML::SAX: 0.15
+ XML::SAX::Expat: 0
+ perl: 5.008
+resources:
+ repository: git://github.com/grantm/xml-simple.git
+version: 2.20
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..94e41a5
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,55 @@
+
+use strict;
+use warnings;
+
+BEGIN { require 5.008; }
+
+use ExtUtils::MakeMaker 6.31;
+
+
+
+my %WriteMakefileArgs = (
+ 'ABSTRACT' => 'Easily read/write XML (esp config files)',
+ 'AUTHOR' => 'Grant McLean <grantm@cpan.org>',
+ 'BUILD_REQUIRES' => {
+ 'Test::More' => '0.88'
+ },
+ 'CONFIGURE_REQUIRES' => {
+ 'ExtUtils::MakeMaker' => '6.31'
+ },
+ 'DISTNAME' => 'XML-Simple',
+ 'EXE_FILES' => [],
+ 'LICENSE' => 'perl',
+ 'NAME' => 'XML::Simple',
+ 'PREREQ_PM' => {
+ 'XML::NamespaceSupport' => '1.04',
+ 'XML::SAX' => '0.15',
+ 'XML::SAX::Expat' => '0'
+ },
+ 'VERSION' => '2.20',
+ 'test' => {
+ 'TESTS' => 't/*.t'
+ }
+);
+
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) {
+ my $br = delete $WriteMakefileArgs{BUILD_REQUIRES};
+ my $pp = $WriteMakefileArgs{PREREQ_PM};
+ for my $mod ( keys %$br ) {
+ if ( exists $pp->{$mod} ) {
+ $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod};
+ }
+ else {
+ $pp->{$mod} = $br->{$mod};
+ }
+ }
+}
+
+delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
+ unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
+
+WriteMakefile(%WriteMakefileArgs);
+
+
+
diff --git a/README b/README
new file mode 100644
index 0000000..2a0a8e8
--- /dev/null
+++ b/README
@@ -0,0 +1,13 @@
+
+
+This archive contains the distribution XML-Simple,
+version 2.20:
+
+ Easily read/write XML (esp config files)
+
+This software is copyright (c) 2012 by Grant McLean.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+
diff --git a/dist.ini b/dist.ini
new file mode 100644
index 0000000..7d474bc
--- /dev/null
+++ b/dist.ini
@@ -0,0 +1,26 @@
+name = XML-Simple
+author = Grant McLean <grantm@cpan.org>
+version = 2.20
+license = Perl_5
+copyright_holder = Grant McLean
+copyright_year = 2012
+main_module = lib/XML/Simple.pm
+repository = git://github.com/grantm/xml-simple.git
+
+[Repository]
+[@Basic]
+[NextRelease]
+;[PodCoverageTests]
+[PodSyntaxTests]
+[MetaJSON]
+[PkgVersion]
+[@Git]
+
+[Prereqs]
+perl = 5.008
+XML::SAX = 0.15
+XML::SAX::Expat = 0
+XML::NamespaceSupport = 1.04
+
+[Prereqs / TestRequires]
+Test::More = 0.88
diff --git a/lib/XML/Simple.pm b/lib/XML/Simple.pm
new file mode 100644
index 0000000..0686c10
--- /dev/null
+++ b/lib/XML/Simple.pm
@@ -0,0 +1,3337 @@
+package XML::Simple;
+BEGIN {
+ $XML::Simple::VERSION = '2.20';
+}
+
+=head1 NAME
+
+XML::Simple - Easily read/write XML (esp config files)
+
+=head1 SYNOPSIS
+
+ use XML::Simple qw(:strict);
+
+ my $ref = XMLin([<xml file or string>] [, <options>]);
+
+ my $xml = XMLout($hashref [, <options>]);
+
+Or the object oriented way:
+
+ require XML::Simple qw(:strict);
+
+ my $xs = XML::Simple->new([<options>]);
+
+ my $ref = $xs->XMLin([<xml file or string>] [, <options>]);
+
+ my $xml = $xs->XMLout($hashref [, <options>]);
+
+(or see L<"SAX SUPPORT"> for 'the SAX way').
+
+Note, in these examples, the square brackets are used to denote optional items
+not to imply items should be supplied in arrayrefs.
+
+=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);
+$PREFERRED_PARSER = undef;
+
+my %StrictMode = ();
+
+my @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr
+ searchpath forcearray cache suppressempty parseropts
+ grouptags nsexpand datahandler varattr variables
+ normalisespace normalizespace valueattr strictmode);
+
+my @KnownOptOut = qw(keyattr keeproot contentkey noattr
+ rootname xmldecl outputfile noescape suppressempty
+ grouptags nsexpand handler noindent attrindent nosort
+ valueattr numericescape strictmode);
+
+my @DefKeyAttr = qw(name key id);
+my $DefRootName = qq(opt);
+my $DefContentKey = qq(content);
+my $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>);
+
+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
+
+ my($calling_package) = caller();
+ _strict_mode_for_caller(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} = ();
+
+ my %raw_opt = @_;
+ $raw_opt{strictmode} = _strict_mode_for_caller()
+ unless exists $raw_opt{strictmode};
+ 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: _strict_mode_for_caller()
+#
+# Gets or sets the XML::Simple :strict mode flag for the calling namespace.
+# Walks back through call stack to find the calling namespace and sets the
+# :strict mode flag for that namespace if an argument was supplied and returns
+# the flag value if not.
+#
+
+sub _strict_mode_for_caller {
+ my $set_mode = @_;
+ my $frame = 1;
+ while(my($package) = caller($frame++)) {
+ next if $package eq 'XML::Simple';
+ $StrictMode{$package} = 1 if $set_mode;
+ return $StrictMode{$package};
+ }
+ return(0);
+}
+
+
+##############################################################################
+# 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 = <STDIN>;
+ 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
+ open(my $xfh, '<', $filename) || croak qq($filename - $!);
+ $tree = $xp->parse($xfh);
+ }
+ 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 {
+ open(my $out, '>', "$self->{opt}->{outputfile}") ||
+ croak "open($self->{opt}->{outputfile}): $!";
+ binmode($out, ':utf8') if($] >= 5.008);
+ print $out $xml or croak "print: $!";
+ close $out or croak "close: $!";
+ }
+ }
+ 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($opt->{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($opt->{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($opt->{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:
+#
+# <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ]
+#
+# 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 = $self->new_hashref;
+ }
+ 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;
+ $val = '' if not defined $val;
+
+ 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 <element attrname="name">value</element> 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} = $self->new_hashref( %{$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} = $self->new_hashref( %{$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 returns silently if neither strict mode nor warnings
+# are enabled
+#
+# Option 2 looks at the global warnings variable $^W - which is not really
+# appropriate in the modern world of lexical warnings - TODO: Fix
+
+sub die_or_warn {
+ my $self = shift;
+ my $msg = shift;
+
+ croak $msg if($self->{opt}->{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)),
+ '</', $name, ">", $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->new_hashref(
+ $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->new_hashref(
+ $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, '</', $name, ">", $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)),
+ '</', $name, ">$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, '</', $name, ">$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/&/&amp;/sg;
+ $data =~ s/</&lt;/sg;
+ $data =~ s/>/&gt;/sg;
+ $data =~ s/"/&quot;/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 STATUS OF THIS MODULE
+
+The use of this module in new code is discouraged. Other modules are available
+which provide more straightforward and consistent interfaces. In particular,
+L<XML::LibXML> is highly recommended.
+
+The major problems with this module are the large number of options and the
+arbitrary ways in which these options interact - often with unexpected results.
+
+Patches with bug fixes and documentation fixes are welcome, but new features
+are unlikely to be added.
+
+=head1 QUICK START
+
+Say you have a script called B<foo> and a file of configuration options
+called B<foo.xml> containing the following:
+
+ <config logdir="/var/log/foo/" debugfile="/tmp/foo.debug">
+ <server name="sahara" osname="solaris" osversion="2.6">
+ <address>10.0.0.101</address>
+ <address>10.0.1.101</address>
+ </server>
+ <server name="gobi" osname="irix" osversion="6.5">
+ <address>10.0.0.102</address>
+ </server>
+ <server name="kalahari" osname="linux" osversion="2.0.34">
+ <address>10.0.0.103</address>
+ <address>10.0.1.103</address>
+ </server>
+ </config>
+
+The following lines of code in B<foo>:
+
+ use XML::Simple qw(:strict);
+
+ my $config = XMLin(undef, KeyAttr => { server => 'name' }, ForceArray => [ 'server', 'address' ]);
+
+will 'slurp' the configuration options into the hashref $config (because no
+filename or XML string was passed as the first argument to C<XMLin()> 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];
+
+Note: If the mapping between the output of Data::Dumper and the print
+statements above is not obvious to you, then please refer to the 'references'
+tutorial (AKA: "Mark's very short tutorial about references") at L<perlreftut>.
+
+In this example, the C<< ForceArray >> option was used to list elements that
+might occur multiple times and should therefore be represented as arrayrefs
+(even when only one element is present).
+
+The C<< KeyAttr >> option was used to indicate that each C<< <server> >>
+element has a unique identifier in the C<< name >> attribute. This allows you
+to index directly to a particular server record using the name as a hash key
+(as shown above).
+
+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<XMLout()>.
+
+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<XMLin()> and C<XMLout()>. Note: you can explicity
+request the lower case versions of the function names: C<xml_in()> and
+C<xml_out()>.
+
+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<XML::Simple> 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<XMLin()> 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<XMLin()> 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<XMLin()> 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('<opt username="bob" password="flurp" />');
+
+=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<XMLin()>, it should
+return a data structure equivalent to the original (see caveats below).
+
+The C<XMLout()> function can also be used to output the XML as SAX events
+see the C<Handler> 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<XMLout>. (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<XMLout()>. 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<XML::Simple> 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<XML::Simple> does not support dumping binary data.
+
+If you break these rules, the current implementation of C<XMLout()> will
+simply emit non-compliant XML which will be rejected if you try to read it
+back in. (A later version of B<XML::Simple> 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<XMLout()> 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<XMLout()> and with C<XMLin()>. If you still don't get the
+expected results, you may prefer to use L<XML::Dumper> which is designed for
+exactly that purpose.
+
+Refer to L<"WHERE TO FROM HERE?"> if C<XMLout()> is too simple for your needs.
+
+
+=head1 OPTIONS
+
+B<XML::Simple> supports a number of options (in fact as each release of
+B<XML::Simple> 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<ForceArray> because you'll almost certainly want to turn it on
+
+=item *
+
+make sure you know what the C<KeyAttr> option does and what its default value is
+because it may surprise you otherwise (note in particular that 'KeyAttr'
+affects both C<XMLin> and C<XMLout>)
+
+=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<in>' if they are recognised by C<XMLin()> and
+'I<out>' if they are recognised by C<XMLout()>.
+
+=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<XMLout()>, 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<XML::Parser> module and parsing an XML file can consume a
+significant number of CPU cycles, it is often desirable to cache the output of
+C<XMLin()> for later reuse.
+
+When parsing from a named file, B<XML::Simple> 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<Storable.pm> 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<XML::Simple> 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<Storable.pm> 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('<opt one="1">Text</opt>', ContentKey => 'text')
+
+will parse to:
+
+ { 'one' => 1, 'text' => 'Text' }
+
+instead of:
+
+ { 'one' => 1, 'content' => 'Text' }
+
+C<XMLout()> 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<XMLin()> try a little harder to eliminate unnecessary 'content' keys after
+array folding. For example:
+
+ XMLin(
+ '<opt><item name="one">First</item><item name="two">Second</item></opt>',
+ 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<XML::Simple> object as a SAX handler, it will return a
+'simple tree' data structure in the same format as C<XMLin()> 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<XML::Simple> 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:
+
+ <opt>
+ <name>value</name>
+ </opt>
+
+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<XMLin()> 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('<opt><x>text1</x><y a="2">text2</y></opt>', 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:
+
+ <opt>
+ <searchpath>
+ <dir>/usr/bin</dir>
+ <dir>/usr/local/bin</dir>
+ <dir>/usr/X11/bin</dir>
+ </searchpath>
+ </opt>
+
+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<< <searchpath> >> 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<KeyAttr>, the array
+folding will occur first and then the grouped element names will be eliminated.
+
+C<XMLout> 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<XMLout()> 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<XMLin()> 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('<config tempdir="/tmp" />', KeepRoot => 1)
+
+You'll be able to reference the tempdir as
+C<$config-E<gt>{config}-E<gt>{tempdir}> instead of the default
+C<$config-E<gt>{tempdir}>.
+
+Similarly, setting the 'KeepRoot' option to '1' will tell C<XMLout()> 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:
+
+ <opt>
+ <user login="grep" fullname="Gary R Epstein" />
+ <user login="stty" fullname="Simon T Tyson" />
+ </opt>
+
+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<XMLin()> will attempt to match attribute names in the order
+supplied. C<XMLout()> 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 set 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<ForceArray> 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<XMLin()> 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:
+
+ <opt>
+ <user login="grep" fullname="Gary R Epstein" />
+ <user login="stty" fullname="Simon T Tyson" />
+ </opt>
+
+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<XMLout> will ignore hash keys starting with a '-'.
+
+=head2 NoAttr => 1 I<# in+out - handy>
+
+When used with C<XMLout()>, the generated XML will contain no attributes.
+All hash key/values will be represented as nested elements instead.
+
+When used with C<XMLin()>, any attributes in the XML will be ignored.
+
+=head2 NoEscape => 1 I<# out - seldom used>
+
+By default, C<XMLout()> will translate the characters 'E<lt>', 'E<gt>', '&' and
+'"' to '&lt;', '&gt;', '&amp;' and '&quot' 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<XMLout()>'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<XMLin()> 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<Note: You must be using a SAX parser for this option to work (ie: it does not
+work with XML::Parser)>.
+
+This option also controls whether C<XMLout()> 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<XMLout> will emit XML which is not well formed.
+
+I<Note: You must have the XML::NamespaceSupport module installed if you want
+C<XMLout()> 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: &#8364;) 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 => <file specifier> I<# out - handy>
+
+The default behaviour of C<XMLout()> 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<IO::Handle> - it simply assumes the object
+supports a C<print> method.
+
+=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this>
+
+I<Note: This option is now officially deprecated. If you find it useful, email
+the author with an example of what you use it for. Do not use this option to
+set the ProtocolEncoding, that's just plain wrong - fix the XML>.
+
+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<XMLout()> 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<XMLin()>.
+Nevertheless, the option has been found to be useful in certain circumstances.
+
+=head2 SearchPath => [ list ] I<# in - handy>
+
+If you pass C<XMLin()> 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<XMLin()> but SearchPath is not defined, the
+file is assumed to be in the current directory.
+
+If the first parameter to C<XMLin()> 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 StrictMode => 1 | 0 I<# in+out seldom used>
+
+This option allows you to turn L<STRICT MODE> on or off for a particular call,
+regardless of whether it was enabled at the time XML::Simple was loaded.
+
+=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy>
+
+This option controls what C<XMLin()> 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<XMLout()> 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:
+
+ <opt>
+ <colour value="red" />
+ <size value="XXL" />
+ </opt>
+
+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<XMLout()> -
+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<XMLout()>.
+
+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<XMLout>).
+
+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<Variables>, 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<VarAttr>
+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<Variables> option. For
+example:
+
+ XMLin( '<opt>
+ <dir name="prefix">/usr/local/apache</dir>
+ <dir name="exec_prefix">${prefix}</dir>
+ <dir name="bindir">${exec_prefix}/bin</dir>
+ </opt>',
+ 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<XMLout()> to start with the optional XML
+declaration, simply set the option to '1'. The default XML declaration is:
+
+ <?xml version='1.0' standalone='yes'?>
+
+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<XMLin()> or C<XMLout()>
+
+=item *
+
+to override methods in B<XML::Simple> 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<XML::Simple>'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<XMLin()> or C<XMLout()> 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<XMLin()> and C<XMLout()> routines may be
+called as C<xml_in()> or C<xml_out()>. 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<xml_in()> 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<xml_in()> 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<xml_in()> method but assumes the first argument is
+the name of a file containing XML.
+
+=item parse_fh(file_handle)
+
+Works exactly like the C<xml_in()> 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<XMLout()>
+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<XMLin()> (default: C<$0.xml>).
+
+=item build_simple_tree(filename, string)
+
+Called from C<XMLin()> or any of the parsing methods. Takes either a file name
+as the first argument or C<undef> 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<XMLout()> 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<XMLout()>, takes a string and returns a copy of the string with
+XML character escaping rules applied.
+
+=item numeric_escape(string)
+
+Called from C<escape_value()>, to handle non-ASCII characters (depending on the
+value of the NumericEscape option).
+
+=item copy_hash(hashref, extra_key => value, ...)
+
+Called from C<XMLout()>, 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<MLDBM> module. First, you would add a
+C<cache_read_dbm()> 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<cache_read_dbm()> 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<XML::Simple> 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<KeyAttr> option - if you can't be bothered
+reading about this option, turn it off with: KeyAttr => [ ]
+
+=item *
+
+Failing to explicitly set the C<ForceArray> 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 E<lt>partE<gt> 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 E<lt>partE<gt> 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<XML::Simple> 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<XML::Simple> 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<XMLout()>:
+
+ 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<XML::Simple> 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<Note: In this last example, the 'Handler' option was specified in the call to
+C<XMLout()> but it could also have been specified in the constructor>.
+
+=head1 ENVIRONMENT
+
+If you don't care which parser module B<XML::Simple> uses then skip this
+section entirely (it looks more complicated than it really is).
+
+B<XML::Simple> will default to using a B<SAX> parser if one is available or
+B<XML::Parser> 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<XML::Simple> 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<XML::Parser> will be used (or C<XMLin()> will die if L<XML::Parser> 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<XML::SAX::ParserFactory.>
+If L<XML::SAX> is not installed, or the requested parser module is not
+installed, then C<XMLin()> will die.
+
+=item *
+
+If the 'preferred parser' is not defined at all (the normal default
+state), an attempt will be made to load L<XML::SAX>. If L<XML::SAX> is
+installed, then a parser module will be selected according to
+L<XML::SAX::ParserFactory>'s normal rules (which typically means the last SAX
+parser installed).
+
+=item *
+
+if the 'preferred parser' is not defined and B<XML::SAX> is not
+installed, then B<XML::Parser> will be used. C<XMLin()> will die if
+L<XML::Parser> is not installed.
+
+=back
+
+Note: The B<XML::SAX> distribution includes an XML parser written entirely in
+Perl. It is very portable but it is not very fast. You should consider
+installing L<XML::LibXML> or L<XML::SAX::Expat> 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<XML::Simple> 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<XMLin()> 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<eval> 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<XMLin()> reads the following very simple piece of XML:
+
+ <opt username="testuser" password="frodo"></opt>
+
+it returns the following data structure:
+
+ {
+ 'username' => 'testuser',
+ 'password' => 'frodo'
+ }
+
+The identical result could have been produced with this alternative XML:
+
+ <opt username="testuser" password="frodo" />
+
+Or this (although see 'ForceArray' option for variations):
+
+ <opt>
+ <username>testuser</username>
+ <password>frodo</password>
+ </opt>
+
+Repeated nested elements are represented as anonymous arrays:
+
+ <opt>
+ <person firstname="Joe" lastname="Smith">
+ <email>joe@smith.com</email>
+ <email>jsmith@yahoo.com</email>
+ </person>
+ <person firstname="Bob" lastname="Smith">
+ <email>bob@smith.com</email>
+ </person>
+ </opt>
+
+ {
+ '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<KeyAttr>
+option):
+
+ <opt>
+ <person key="jsmith" firstname="Joe" lastname="Smith" />
+ <person key="tsmith" firstname="Tom" lastname="Smith" />
+ <person key="jbloggs" firstname="Joe" lastname="Bloggs" />
+ </opt>
+
+ {
+ 'person' => {
+ 'jbloggs' => {
+ 'firstname' => 'Joe',
+ 'lastname' => 'Bloggs'
+ },
+ 'tsmith' => {
+ 'firstname' => 'Tom',
+ 'lastname' => 'Smith'
+ },
+ 'jsmith' => {
+ 'firstname' => 'Joe',
+ 'lastname' => 'Smith'
+ }
+ }
+ }
+
+
+The <anon> tag can be used to form anonymous arrays:
+
+ <opt>
+ <head><anon>Col 1</anon><anon>Col 2</anon><anon>Col 3</anon></head>
+ <data><anon>R1C1</anon><anon>R1C2</anon><anon>R1C3</anon></data>
+ <data><anon>R2C1</anon><anon>R2C2</anon><anon>R2C3</anon></data>
+ <data><anon>R3C1</anon><anon>R3C2</anon><anon>R3C3</anon></data>
+ </opt>
+
+ {
+ '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:
+
+ <opt>
+ <anon><anon>Col 1</anon><anon>Col 2</anon></anon>
+ <anon><anon>R1C1</anon><anon>R1C2</anon></anon>
+ <anon><anon>R2C1</anon><anon>R2C2</anon></anon>
+ </opt>
+
+ [
+ [ '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<ContentKey> option):
+
+ <opt>
+ <one>first</one>
+ <two attr="value">second</two>
+ </opt>
+
+ {
+ '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<XML::Simple> 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<http://perl-xml.sourceforge.net/faq/>
+
+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<XML::Twig> and more standards based DOM implementations - preferably one with
+XPath support such as L<XML::LibXML>.
+
+
+=head1 SEE ALSO
+
+B<XML::Simple> requires either L<XML::Parser> or L<XML::SAX>.
+
+To generate documents with namespaces, L<XML::NamespaceSupport> is required.
+
+The optional caching functions require L<Storable>.
+
+Answers to Frequently Asked Questions about XML::Simple are bundled with this
+distribution as: L<XML::Simple::FAQ>
+
+=head1 COPYRIGHT
+
+Copyright 1999-2004 Grant McLean E<lt>grantm@cpan.orgE<gt>
+
+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..4c5c904
--- /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:
+
+ <document>
+ <para>This is <em>mixed</em> content.</para>
+ </document>
+
+This is said to be mixed content, because the E<lt>paraE<gt> element contains
+both character data (text content) and nested elements.
+
+Here's some more XML:
+
+ <person>
+ <first_name>Joe</first_name>
+ <last_name>Bloggs</last_name>
+ <dob>25-April-1969</dob>
+ </person>
+
+This second example is not generally considered to be mixed content. The
+E<lt>first_nameE<gt>, E<lt>last_nameE<gt> and E<lt>dobE<gt> elements contain
+only character data and the E<lt>personE<gt> 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:
+
+ <person>
+ <first_name>Joe</first_name>
+ <last_name>Bloggs</last_name>
+ <hobbie>bungy jumping</hobbie>
+ <hobbie>sky diving</hobbie>
+ <hobbie>knitting</hobbie>
+ </person>
+
+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 E<lt>first_nameE<gt> and E<lt>last_nameE<gt> elements are represented as
+simple scalar values which you could refer to like this:
+
+ print "$person->{first_name} $person->{last_name}\n";
+
+The E<lt>hobbieE<gt> 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 E<lt>hobbieE<gt>
+element, it will be represented as a simple scalar (just like
+E<lt>first_nameE<gt> and E<lt>last_nameE<gt>). 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 E<lt>first_nameE<gt> and
+E<lt>last_nameE<gt> 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:
+
+ <person first_name="Jane" last_name="Bloggs">
+ <hobbie>motorcycle maintenance</hobbie>
+ </person>
+
+On the other hand, if you prefer not to use attributes, then you could
+specify that any E<lt>hobbieE<gt> 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:
+
+ <catalog>
+ <part partnum="1842334" desc="High pressure flange" price="24.50" />
+ <part partnum="9344675" desc="Threaded gasket" price="9.25" />
+ <part partnum="5634896" desc="Low voltage washer" price="12.00" />
+ </catalog>
+
+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 E<lt>partE<gt> 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:
+
+ <catalog>
+ <part>
+ <partnum>1842334</partnum>
+ <desc>High pressure flange</desc>
+ <price>24.50</price>
+ </part>
+ <part>
+ <partnum>9344675</partnum>
+ <desc>Threaded gasket</desc>
+ <price>9.25</price>
+ </part>
+ <part>
+ <partnum>5634896</partnum>
+ <desc>Low voltage washer</desc>
+ <price>12.00</price>
+ </part>
+ </catalog>
+
+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 E<lt>catalogE<gt> example above would be:
+
+ my $catalog = XMLin($xml, keyattr => { part => 'partnum'},
+ forcearray => ['part']);
+
+By using the hashref for keyattr, you can specify that only E<lt>partE<gt>
+elements should be folded on the 'partnum' attribute (and that the
+E<lt>partE<gt> 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 E<lt>partE<gt>. 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<and> 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 E<lt>nameE<gt> 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<ParserOpts> 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<ProtocolEncoding> 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/t/0_Config.t b/t/0_Config.t
new file mode 100644
index 0000000..1fcbf54
--- /dev/null
+++ b/t/0_Config.t
@@ -0,0 +1,62 @@
+
+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..eb38280
--- /dev/null
+++ b/t/1_XMLin.t
@@ -0,0 +1,1510 @@
+
+use strict;
+use warnings;
+use Test::More;
+use IO::File;
+use File::Spec;
+
+
+# The suppress-able warnings still check the global flag
+
+$^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, '<Changes') {
+ while(<$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(<opt name1="value1" name2="value2"></opt>));
+
+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(
+ <opt>
+ <name1>value1</name1>
+ <name2>value2</name2>
+ </opt>
+));
+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(<opt name1="value1"
+ name2="value2" />));
+is_deeply($opt, $expected, 'attributes in empty element');
+
+
+# Try something with two lists of nested values
+
+$opt = XMLin(q(
+ <opt>
+ <name1>value1.1</name1>
+ <name1>value1.2</name1>
+ <name1>value1.3</name1>
+ <name2>value2.1</name2>
+ <name2>value2.2</name2>
+ <name2>value2.3</name2>
+ </opt>)
+);
+
+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(
+ <opt>
+ <item name1="value1" name2="value2" />
+ </opt>)
+);
+
+is_deeply($opt, {
+ item => { name1 => 'value1', name2 => 'value2' }
+}, 'nested element gives hash');
+
+
+# Now a list of nested hashes
+
+$opt = XMLin(q(
+ <opt>
+ <item name1="value1" name2="value2" />
+ <item name1="value3" name2="value4" />
+ </opt>)
+);
+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(
+ <opt>
+ <item name="item1" attr1="value1" attr2="value2" />
+ <item name="item2" attr1="value3" attr2="value4" />
+ </opt>
+);
+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(
+ <opt>
+ <item key="item1" attr1="value1" attr2="value2" />
+ <item key="item2" attr1="value3" attr2="value4" />
+ </opt>
+), @cont_key);
+is_deeply($opt, {
+ item => {
+ item1 => { attr1 => 'value1', attr2 => 'value2' },
+ item2 => { attr1 => 'value3', attr2 => 'value4' }
+ }
+}, "folded on default key 'key'");
+
+
+$opt = XMLin(q(
+ <opt>
+ <item id="item1" attr1="value1" attr2="value2" />
+ <item id="item2" attr1="value3" attr2="value4" />
+ </opt>
+), @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(
+ <opt>
+ <item xname="item1" attr1="value1" attr2="value2" />
+ <item xname="item2" attr1="value3" attr2="value4" />
+ </opt>);
+
+$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(
+<opt>
+ <item id="one" value="1" name="a" />
+ <item id="two" value="2" />
+ <item id="three" value="3" />
+</opt>
+);
+
+$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(
+<opt>
+ <car license="SH6673" make="Ford" id="1">
+ <option key="1" pn="6389733317-12" desc="Electric Windows"/>
+ <option key="2" pn="3735498158-01" desc="Leather Seats"/>
+ <option key="3" pn="5776155953-25" desc="Sun Roof"/>
+ </car>
+ <car license="LW1804" make="GM" id="2">
+ <option key="1" pn="9926543-1167" desc="Steering Wheel"/>
+ </car>
+</opt>
+);
+
+$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(
+ <opt>
+ <item>
+ <name><firstname>Bob</firstname></name>
+ <age>21</age>
+ </item>
+ <item>
+ <name><firstname>Kate</firstname></name>
+ <age>22</age>
+ </item>
+ </opt>);
+
+$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{<item> 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{<item> 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(<opt>
+ <item name="color">red</item>
+ <item name="mass">heavy</item>
+ <item nime="disposition">ornery</item>
+ </opt>);
+ 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: <item> 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(<opt>
+ <item name="color">red</item>
+ <item name="mass">heavy</item>
+ <item name="disposition">ornery</item>
+ <item name="color">green</item>
+ </opt>);
+ $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: <item> 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: <item> 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("<opt>$xml</opt>", 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{<opt><cdata><![CDATA[<greeting>Hello, world!</greeting>]]></cdata></opt>};
+$opt = XMLin($xml, @cont_key);
+is_deeply($opt, {
+ 'cdata' => '<greeting>Hello, world!</greeting>'
+}, 'CDATA section parsed correctly');
+
+$xml = q{<opt><x><![CDATA[<y>one</y>]]><![CDATA[<y>two</y>]]></x></opt>};
+$opt = XMLin($xml, @cont_key);
+is_deeply($opt, {
+ 'x' => '<y>one</y><y>two</y>'
+}, '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{
+ <opt>
+ <row>
+ <anon>0.0</anon><anon>0.1</anon><anon>0.2</anon>
+ </row>
+ <row>
+ <anon>1.0</anon><anon>1.1</anon><anon>1.2</anon>
+ </row>
+ <row>
+ <anon>2.0</anon><anon>2.1</anon><anon>2.2</anon>
+ </row>
+ </opt>
+};
+
+$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{
+ <opt>
+ <anon>one</anon>
+ <anon>two</anon>
+ <anon>three</anon>
+ </opt>
+}, @cont_key);
+is_deeply($opt, [
+ qw(one two three)
+], 'top level anonymous array returned arrayref');
+
+
+$opt = XMLin(q(
+ <opt>
+ <anon>1</anon>
+ <anon>
+ <anon>2.1</anon>
+ <anon>
+ <anon>2.2.1</anon>
+ <anon>2.2.2</anon>
+ </anon>
+ </anon>
+ </opt>
+), @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(
+ <opt>
+ <item attr="value">text</item>
+ </opt>
+);
+
+$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(<opt attr="value">text content</opt>);
+
+$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(<opt><x>text1</x><y a="2">text2</y></opt>);
+$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(<opt><x y="one">First</x><x y="two">Second</x></opt>);
+$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(<opt><x y="one">First</x><x y="two">Second</x></opt>);
+$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(<opt>
+ <p1 class="mixed">Text with a <b>bold</b> word</p1>
+ <p2>Mixed <b>but</b> no attributes</p2>
+</opt>);
+
+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(
+ <opt>
+ <name>value</name>
+ </opt>
+);
+$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>
+ <inner name="one" value="1" />
+</opt>);
+
+$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(<opt zero="0">
+ <one>i</one>
+ <two>ii</two>
+ <three>iii</three>
+ <three>3</three>
+ <three>c</three>
+</opt>
+);
+
+$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(<opt zero="0">
+ <one>i</one>
+ <two>ii</two>
+ <three>iii</three>
+ <four>iv</four>
+ <five>v</five>
+</opt>
+);
+
+$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(<opt name="user" password="foobar">
+ <nest attr="value">text</nest>
+</opt>
+);
+
+$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{<opt>
+ <item><key>a</key><value>alpha</value></item>
+ <item><key>b</key><value>beta</value></item>
+ <item><key>g</key><value>gamma</value></item>
+</opt>
+};
+
+
+$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(<body>
+ <name>bob</name>
+ <outer attr="value">
+ <inner1 />
+ <inner2></inner2>
+ </outer>
+</body>);
+
+$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(<body>
+ <outer attr="value">
+ <inner1 />
+ <inner2></inner2>
+ </outer>
+</body>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir>/usr/bin</dir>
+ <dir>/usr/local/bin</dir>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir>/usr/bin</dir>
+ <dir>/usr/local/bin</dir>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir>/usr/bin</dir>
+ <dir>/usr/local/bin</dir>
+ </dirs>
+ <infix>between</infix>
+ <terms>
+ <term>vt100</term>
+ <term>xterm</term>
+ </terms>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir name="first">/usr/bin</dir>
+ <dir name="second">/usr/local/bin</dir>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir name="first">/usr/bin</dir>
+ <dir name="second">/usr/local/bin</dir>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir name="first">/usr/bin</dir>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <dir name="first">/usr/bin</dir>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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(<opt>
+ <file name="config_file">${conf_dir}/appname.conf</file>
+ <file name="log_file">${log_dir}/appname.log</file>
+ <file name="debug_file">${log_dir}/appname.dbg</file>
+ <opt docs="${have_docs}" />
+ <bogus value="${undef}" />
+</opt>);
+
+$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(<opt>
+ <dir xsvar="conf_dir">/etc</dir>
+ <dir xsvar="log_dir">/var/log</dir>
+ <cfg xsvar="have_docs">false</cfg>
+ <cfg xsvar="host.domain">search.perl.org</cfg>
+ <cfg xsvar="bad/name">bogus</cfg>
+ <file name="config_file">${conf_dir}/appname.conf</file>
+ <file name="log_file">${log_dir}/appname.log</file>
+ <file name="debug_file">${log_dir}/appname.dbg</file>
+ <file name="bogus_file">${bad/name}</file>
+ <opt docs="${have_docs}" />
+ <site url="http://${host.domain}/" />
+</opt>);
+
+$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(<opt>
+ <dir xsvar="log_dir">/var/log</dir>
+ <file name="config_file">${conf_dir}/appname.conf</file>
+ <file name="log_file">${log_dir}/appname.log</file>
+ <file name="debug_file">${log_dir}/appname.dbg</file>
+</opt>);
+
+$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(<opt>
+ <dirs>
+ <dir name="prefix">/usr/local/apache</dir>
+ <dir name="exec_prefix">${prefix}</dir>
+ <dir name="bin_dir">${exec_prefix}/bin</dir>
+ </dirs>
+</opt>);
+
+$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(<opt>
+ <prefix>before</prefix>
+ <dirs>
+ <lib>/usr/bin</lib>
+ <lib>/usr/local/bin</lib>
+ </dirs>
+ <suffix>after</suffix>
+</opt>);
+
+$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('<x y="z" />', rootname => 'fred') }; # not valid for XMLin()
+is($_, undef, 'invalid options are trapped');
+like($@, qr/Unrecognised option:/, 'with correct error message');
+
+$@='';
+$_ = eval { XMLin('<x y="z" />', '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(<opt>
+ <user name=" Joe
+ Bloggs " id=" one two "/>
+ <user>
+ <name> Jane
+ Doe </name>
+ <id>
+ three
+ four
+ </id>
+ </user>
+</opt>);
+
+$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(<opt>
+ <anon> one two </anon><anon> three
+ four five </anon><anon> six </anon><anon> seveneightnine </anon>
+</opt>);
+
+$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(<graphics>
+ <today value="today.png"/>
+ <nav-prev value="prev.png"/>
+ <nav-home value="home.png"/>
+ <nav-next value="next.png"/>
+</graphics>);
+
+$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(<graphics>
+ <today xxx="today.png"/>
+ <nav-prev yyy="prev.png"/>
+ <nav-home zzz="home.png"/>
+ <nav-next value="next.png"/>
+</graphics>);
+
+$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(<graphics>
+ <today xxx="today.png"/>
+ <nav-prev value="prev.png"/>
+ <nav-home yyy="home.png"/>
+ <nav-next value="next.png"/>
+</graphics>);
+
+$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(<graphics>
+ <today value="today.png"/>
+ <animal name="lion" age="7"/>
+ <animal name="elephant" age="97"/>
+ <colour rgb="#FF0000">red</colour>
+</graphics>);
+
+$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 @@
+<opt location="t/1_XMLin.xml" />
diff --git a/t/2_XMLout.t b/t/2_XMLout.t
new file mode 100644
index 0000000..5069c8d
--- /dev/null
+++ b/t/2_XMLout.t
@@ -0,0 +1,1211 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+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:
+# <opt one="1" two="II" three="..." />
+
+$_ = 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:
+# <opt>
+# <array>one</array>
+# <array>two</array>
+# <array>three</array>
+# </opt>
+
+$_ = XMLout($ref);
+is_deeply(XMLin($_), $ref, 'encoded a hash with nested array');
+ok(s{<array>one</array>\s*
+ <array>two</array>\s*
+ <array>three</array>}{}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:
+# <opt value="555 1234">
+# <hash1 one="1" />
+# <hash2 two="2" />
+# </opt>
+
+$_ = XMLout($ref);
+is_deeply(XMLin($_), $ref, 'encoded nested hashes');
+
+ok(s{<hash1 one="1" />\s*}{}s, 'nested hash 1 ok');
+ok(s{<hash2 two="2" />\s*}{}s, 'nested hash 2 ok');
+like($_, qr{^<(\w+)\s+value="555 1234"\s*>\s*</\1>\s*$}s, 'whole OK');
+
+
+# Now try encoding an anonymous array
+
+$ref = [ qw(1 two III) ];
+# Expect:
+# <opt>
+# <anon>1</anon>
+# <anon>two</anon>
+# <anon>III</anon>
+# </opt>
+
+$_ = XMLout($ref);
+is_deeply(XMLin($_), $ref, 'encoded anonymous array');
+
+like($_, qr{
+ ^<(\w+)\s*>
+ \s*<anon>1</anon>
+ \s*<anon>two</anon>
+ \s*<anon>III</anon>
+ \s*</\1>\s*$}sx, 'output matches expectations');
+
+
+# Now try encoding a nested anonymous array
+
+$ref = [ [ qw(1.1 1.2) ], [ qw(2.1 2.2) ] ];
+# Expect:
+# <opt>
+# <anon>
+# <anon>1.1</anon>
+# <anon>1.2</anon>
+# </anon>
+# <anon>
+# <anon>2.1</anon>
+# <anon>2.2</anon>
+# </anon>
+# </opt>
+
+$_ = XMLout($ref);
+is_deeply(XMLin($_), $ref, 'encoded nested anonymous arrays');
+
+like($_, qr{
+ <(\w+)\s*>
+ \s*<anon\s*>
+ \s*<anon\s*>1\.1</anon\s*>
+ \s*<anon\s*>1\.2</anon\s*>
+ \s*</anon\s*>
+ \s*<anon\s*>
+ \s*<anon\s*>2\.1</anon\s*>
+ \s*<anon\s*>2\.2</anon\s*>
+ \s*</anon\s*>
+ \s*</\1\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:
+# <opt>
+# <country>
+# <England capital="London" />
+# <France capital="Paris" />
+# <Turkey capital="Istanbul" />
+# </country>
+# </opt>
+
+$_ = XMLout($ref, keyattr => []);
+is_deeply(XMLin($_), $ref, 'encoded hash of hashes with folding disabled');
+ok(s{<England\s+capital="London"\s*/>\s*}{}s, 'nested hash 1 ok');
+ok(s{<France\s+capital="Paris"\s*/>\s*}{}s, 'nested hash 2 ok');
+ok(s{<Turkey\s+capital="Istanbul"\s*/>\s*}{}s, 'nested hash 3 ok');
+ok(s{<country\s*>\s*</country>}{}s, 'container hash ok');
+ok(s{^<(\w+)\s*>\s*</\1>$}{}s, 'document ok');
+
+
+# Try encoding same again with key folding set to non-standard value
+
+# Expect:
+# <opt>
+# <country fullname="England" capital="London" />
+# <country fullname="France" capital="Paris" />
+# <country fullname="Turkey" capital="Istanbul" />
+# </opt>
+
+my $expected = qr{
+ ^<(\w+)\s*>\s*
+ (
+ <country(\s*fullname="Turkey"|\s*capital="Istanbul"){2}\s*/>\s*
+ |<country(\s*fullname="France"|\s*capital="Paris"){2}\s*/>\s*
+ |<country(\s*fullname="England"|\s*capital="London"){2}\s*/>\s*
+ ){3}
+ </\1>$
+}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:
+# <opt>
+# <country name="England" capital="London" />
+# <country name="France" capital="Paris" />
+# <country name="Turkey" capital="Istanbul" />
+# </opt>
+
+$expected = qr{
+ ^<(\w+)\s*>\s*
+ (
+ <country(\s*name="Turkey"|\s*capital="Istanbul"){2}\s*/>\s*
+ |<country(\s*name="France"|\s*capital="Paris"){2}\s*/>\s*
+ |<country(\s*name="England"|\s*capital="London"){2}\s*/>\s*
+ ){3}
+ </\1>$
+}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:
+# <opt>
+# <country name="England" capital="London" />
+# </opt>
+
+$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{<countryukuk\s*/>\s*}{}s, 'element ok');
+ok(s{^<(\w+)\s*>\s*</\1>$}{}s, 'document ok');
+
+
+# Check that default XML declaration works
+#
+# Expect:
+# <?xml version='1.0' standalone='yes'?>
+# <opt one="1" />
+
+$ref = { one => 1 };
+
+$_ = XMLout($ref, xmldecl => 1);
+is_deeply(XMLin($_), $ref, 'generated doc with XML declaration');
+ok(s{^\Q<?xml version='1.0' standalone='yes'?>\E}{}s, 'XML declaration OK');
+like($_, qr{^\s*<opt\s+one="1"\s*/>}s, 'data OK too');
+
+
+# Check that custom XML declaration works
+#
+# Expect:
+# <?xml version='1.0' standalone='yes'?>
+# <opt one="1" />
+
+$_ = XMLout($ref, xmldecl => "<?xml version='1.0' standalone='yes'?>");
+is_deeply(XMLin($_), $ref, 'generated doc with custom XML declaration');
+ok(s{^\Q<?xml version='1.0' standalone='yes'?>\E}{}s, 'XML declaration OK');
+like($_, qr{^\s*<opt\s+one="1"\s*/>}s, 'data OK too');
+
+
+# Check that special characters do get escaped
+
+$ref = { a => '<A>', b => '"B"', c => '&C&' };
+$_ = XMLout($ref);
+is_deeply(XMLin($_), $ref, 'generated document with escaping');
+ok(s{a="&lt;A&gt;"}{}s, 'angle brackets escaped OK');
+ok(s{b="&quot;B&quot;"}{}s, 'double quotes escaped OK');
+ok(s{c="&amp;C&amp;"}{}s, 'ampersands escaped OK');
+ok(s{^<(\w+)\s*/>$}{}s, 'data OK too');
+
+
+# unless we turn escaping off
+
+$ref = { a => '<A>', b => '"B"', c => ['&C&'] };
+$_ = XMLout($ref, noescape => 1);
+ok(s{a="<A>"}{}s, 'generated unescaped angle brackets');
+ok(s{b=""B""}{}s, 'generated unescaped double quotes');
+ok(s{<c>&C&</c>}{}s, 'generated unescaped ampersands');
+ok(s{^<(\w+)\s*>\s*</\1>$}{}s, 'data OK too');
+
+# same again but with a scalar
+
+$xml = XMLout("<scalar>", noescape => 1);
+like($xml, qr{^<(\w+)><scalar></\1>}, "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{^
+<opt>
+ (
+ \s*<a\s+alpha="1"\s*/>
+ |
+ \s*<b\s+alpha="1"\s*/>
+ ){2}
+\s*</opt>
+}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*<TOM>scalar<\/TOM>\s*$/si, 'XML as expected');
+
+
+# Next try encoding a hash
+
+# Expect:
+# <DICK one="1" two="II" three="..." />
+
+$_ = 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/^<DICK\s+\/>/, 'XML looks OK');
+
+
+# Now try encoding a hash with a nested array
+
+$ref = {array => [qw(one two three)]};
+# Expect:
+# <LARRY>
+# <array>one</array>
+# <array>two</array>
+# <array>three</array>
+# </LARRY>
+
+$_ = XMLout($ref, rootname => 'LARRY');
+is_deeply(XMLin($_), $ref, 'same again but with array in hash');
+ok(s{<array>one</array>\s*
+ <array>two</array>\s*
+ <array>three</array>}{}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:
+# <CURLY value="555 1234">
+# <hash1 one="1" />
+# <hash2 two="2" />
+# </CURLY>
+
+$_ = XMLout($ref, rootname => 'CURLY');
+is_deeply(XMLin($_), $ref, 'same again but with nested hashes');
+
+ok(s{<hash1 one="1" />\s*}{}s, 'hash 1 encoded OK');
+ok(s{<hash2 two="2" />\s*}{}s, 'hash 2 encoded OK');
+like($_, qr{^<(CURLY)\s+value="555 1234"\s*>\s*</\1>\s*$}s, 'document OK');
+
+
+# Now try encoding an anonymous array
+
+$ref = [ qw(1 two III) ];
+# Expect:
+# <MOE>
+# <anon>1</anon>
+# <anon>two</anon>
+# <anon>III</anon>
+# </MOE>
+
+$_ = XMLout($ref, rootname => 'MOE');
+is_deeply(XMLin($_), $ref, 'same again but with nested anonymous array');
+like($_, qr{
+ ^<(MOE)\s*>
+ \s*<anon>1</anon>
+ \s*<anon>two</anon>
+ \s*<anon>III</anon>
+ \s*</\1>\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:
+# <one>1</one>
+# <two>II</two>
+# <three>...</three>
+
+$_ = XMLout($hashref1, rootname => '');
+is_deeply(XMLin("<opt>$_</opt>"), $hashref1,
+ 'generated doc with no root element from hash');
+ok(s/<one>1<\/one>//, 'first key encoded OK');
+ok(s/<two>II<\/two>//, 'second key encoded OK');
+ok(s/<three>...<\/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:
+# <value>555 1234</value>
+# <hash1 one="1" />
+# <hash2 two="2" />
+
+$_ = XMLout($ref, rootname => '');
+is_deeply(XMLin("<opt>$_</opt>"), $ref,
+ 'generated docucment with no root element from nested hashes');
+ok(s{<value>555 1234<\/value>\s*}{}s, 'first element OK');
+ok(s{<hash1 one="1" />\s*}{}s, 'second element OK');
+ok(s{<hash2 two="2" />\s*}{}s, 'third element OK');
+like($_, qr{^\s*$}s, 'document OK');
+
+
+# Now try encoding an anonymous array
+
+$ref = [ qw(1 two III) ];
+# Expect:
+# <anon>1</anon>
+# <anon>two</anon>
+# <anon>III</anon>
+
+$_ = XMLout($ref, rootname => '');
+is_deeply(XMLin("<opt>$_</opt>"), $ref,
+ 'generated doc with no root name from array');
+like($_, qr{
+ ^\s*<anon>1</anon>
+ \s*<anon>two</anon>
+ \s*<anon>III</anon>
+ \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*<opt\s+a="one"\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:
+# <opt>
+# <car license="LW1804" id="2" make="GM">
+# <option key="1" pn="9926543-1167" desc="Steering Wheel" />
+# </car>
+# <car license="SH6673" id="1" make="Ford">
+# <option key="2" pn="6389733317-12" desc="Electric Windows" />
+# <option key="3" pn="3735498158-01" desc="Leather Seats" />
+# <option key="4" pn="5776155953-25" desc="Sun Roof" />
+# </car>
+# </opt>
+
+$_ = 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*<cargmgmgm>\s*<optionoptoptopt\s*/>\s*</car>}{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*<option111}{<option}s, 'element 2.1 OK');
+ok(s{\s*desc="Leather Seats"}{2}s, 'element 2.2 attribute 1 OK');
+ok(s{\s*pn="3735498158-01"}{2}s, 'element 2.2 attribute 2 OK');
+ok(s{\s*key="3"}{2}s, 'element 2.2 attribute 3 OK');
+ok(s{\s*<option222}{<option}s, 'element 2.2 OK');
+ok(s{\s*desc="Sun Roof"}{3}s, 'element 2.3 attribute 1 OK');
+ok(s{\s*pn="5776155953-25"}{3}s, 'element 2.3 attribute 2 OK');
+ok(s{\s*key="4"}{3}s, 'element 2.3 attribute 3 OK');
+ok(s{\s*<option333}{<option}s, 'element 2.3 OK');
+ok(s{\s*<carfordfordford>\s*(<option\s*/>\s*){3}</car>}{CAR}s, 'element 2 OK');
+ok(s{^<(\w+)\s*>\s*CAR\s*CAR\s*</\1>$}{}s, 'document OK');
+
+
+# Check that empty hashes translate to empty tags
+
+$ref = {
+ 'one' => {
+ 'attr1' => 'avalue1',
+ 'nest1' => [ 'nvalue1' ],
+ 'nest2' => {}
+ },
+ two => {}
+};
+
+$_ = XMLout($ref);
+ok(s{<nest2\s*></nest2\s*>\s*}{<NNN>}, 'nested empty hash OK');
+ok(s{<nest1\s*>nvalue1</nest1\s*>\s*}{<NNN>}, 'array OK');
+ok(s{<one\s*attr1\s*=\s*"avalue1">\s*}{<one>}, 'scalar OK');
+ok(s{<one\s*>\s*<NNN>\s*<NNN>\s*</one>}{<nnn>}, 'nesting OK');
+ok(s{<two\s*></two\s*>\s*}{<nnn>}, 'empty hash OK');
+like($_, qr{^\s*<(\w+)\s*>\s*<nnn>\s*<nnn>\s*</\1\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*<tag\s*></tag\s*>\s*</\1\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*<one\s*>1</one\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*<a\s*>one</a\s*>
+ \s*<a\s*></a\s*>
+ \s*<a\s*>three</a\s*>
+ \s*</\1\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*<a\s*>one</a\s*>
+ \s*<a\s*>three</a\s*>
+ \s*</\1\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: <opt one="1">text</opt>
+
+$ref = { 'one' => 1, 'content' => 'text' };
+
+$_ = XMLout($ref);
+
+like($_, qr{^\s*<opt\s+one="1">text</opt>\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*<opt\s+one="1">text</opt>\s*$}s, 'even when name changed');
+
+
+# and also if we add the '-' prefix
+
+$_ = XMLout($ref, contentkey => '-text_content');
+
+like($_, qr{^\s*<opt\s+one="1">text</opt>\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*<column\s+name="title"\s*>A\sTitle</column>
+ \s*<column\s+name="sponsor"\s*></column>
+ \s*
+ </\1>$
+ }sx, "undef does not cause content tags in output"
+ );
+}
+
+
+# Check 'noattr' option
+
+$ref = {
+ attr1 => 'value1',
+ attr2 => 'value2',
+ nest => [ qw(one two three) ]
+};
+
+# Expect:
+#
+# <opt>
+# <attr1>value1</attr1>
+# <attr2>value2</attr2>
+# <nest>one</nest>
+# <nest>two</nest>
+# <nest>three</nest>
+# </opt>
+#
+
+$_ = XMLout($ref, noattr => 1);
+
+unlike($_, qr{=}s, 'generated document with no attributes');
+is_deeply(XMLin($_), $ref, 'parses ok');
+ok(s{\s*<(attr1)>value1</\1>\s*}{NEST}s, 'scalar 1 mapped ok');
+ok(s{\s*<(attr2)>value2</\1>\s*}{NEST}s, 'scalar 2 mapped ok');
+ok(s{\s*<(nest)>one</\1>\s*<\1>two</\1>\s*<\1>three</\1>}{NEST}s,
+'array mapped ok');
+like($_, qr{^<(\w+)\s*>(NEST\s*){3}</\1>$}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:
+#
+# <opt>
+# <number>
+# <dec>21</dec>
+# <word>twenty one</word>
+# <hex>0x15</hex>
+# </number>
+# <number>
+# <dec>32</dec>
+# <word>thirty two</word>
+# <hex>0x20</hex>
+# </number>
+# </opt>
+#
+
+$_ = 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</\1>\s*}{21}s, 'scalar 1.1 mapped OK');
+ok(s{\s*<(hex)>0x15</\1>\s*}{21}s, 'scalar 1.2 mapped OK');
+ok(s{\s*<(word)>twenty one</\1>\s*}{21}s, 'scalar 1.3 mapped OK');
+ok(s{\s*<(number)>212121</\1>\s*}{NUM}s, 'element 1 OK');
+ok(s{\s*<(dec)>32</\1>\s*}{32}s, 'scalar 2.1 mapped OK');
+ok(s{\s*<(hex)>0x20</\1>\s*}{32}s, 'scalar 2.1 mapped OK');
+ok(s{\s*<(word)>thirty two</\1>\s*}{32}s, 'scalar 2.1 mapped OK');
+ok(s{\s*<(number)>323232</\1>\s*}{NUM}s, 'element 2 OK');
+like($_, qr{^<(\w+)\s*>NUMNUM</\1>$}, 'document OK');
+
+
+# Check grouped tags get ungrouped correctly
+
+$ref = {
+ prefix => 'before',
+ dirs => [ '/usr/bin', '/usr/local/bin' ],
+ suffix => 'after',
+};
+
+# Expect:
+#
+# <opt>
+# <prefix>before</prefix>
+# <dirs>
+# <dir>/usr/bin</dir>
+# <dir>/usr/local/bin</dir>
+# </dirs>
+# <suffix>after</suffix>
+# </opt>
+#
+
+$@ = '';
+$_ = 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</\1>\s*}{ELEM}s, 'prefix OK');
+ok(s{\s*<(suffix)>after</\1>\s*}{ELEM}s, 'suffix OK');
+ok(s{\s*<dir>/usr/bin</dir>\s*<dir>/usr/local/bin</dir>\s*}{LIST}s, 'list OK');
+ok(s{\s*<dirs>LIST</dirs>\s*}{ELEM}s, 'group OK');
+like($_, qr{^<(\w+)\s*>ELEMELEMELEM</\1>$}, '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:
+#
+# <opt>
+# <dirs>
+# <dir>/usr/bin</dir>
+# <dir>/usr/local/bin</dir>
+# </dirs>
+# <terms>
+# <term>vt100</term>
+# <term>xterm</term>
+# </terms>
+# </opt>
+#
+
+$_ = XMLout($ref, grouptags => {dirs => 'dir', terms => 'term'}, noattr => 1);
+
+ok(s{\s*<dir>/usr/bin</dir>\s*<dir>/usr/local/bin</dir>\s*}{LIST}s, 'list 1 OK');
+ok(s{\s*<dirs>LIST</dirs>\s*}{ELEM}s, 'group 1 OK');
+ok(s{\s*<term>vt100</term>\s*<term>xterm</term>\s*}{LIST}s, 'list 2 OK');
+ok(s{\s*<terms>LIST</terms>\s*}{ELEM}s, 'group 2 OK');
+like($_, qr{^<(\w+)\s*>ELEMELEM</\1>$}, 'document OK');
+
+
+# Confirm unfolding and grouping work together
+
+$ref = {
+ dirs => {
+ first => { content => '/usr/bin' },
+ second => { content => '/usr/local/bin' },
+ },
+};
+
+# Expect:
+#
+# <opt>
+# <dirs>
+# <dir name="first">/usr/bin</dir>
+# <dir name="second">/usr/local/bin</dir>
+# </dirs>
+# </opt>
+#
+
+$_ = XMLout($ref,
+ grouptags => {dirs => 'dir'}, keyattr => {dir => 'name'},
+);
+
+ok(s{\s*<dir\s+name="first">/usr/bin</dir>\s*}{ITEM}s, 'item 1 OK');
+ok(s{\s*<dir\s+name="second">/usr/local/bin</dir>\s*}{ITEM}s, 'item 2 OK');
+ok(s{\s*<dirs>ITEMITEM</dirs>\s*}{GROUP}s, 'group OK');
+like($_, qr{^<(\w+)\s*>GROUP</\1>$}, 'document OK');
+
+
+# Combine unfolding, grouping and stripped content - watch it fail :-(
+
+$ref = {
+ dirs => {
+ first => '/usr/bin',
+ second => '/usr/local/bin'
+ },
+};
+
+# Expect:
+#
+# <opt>
+# <dirs first="/usr/bin" second="/usr/local/bin" />
+# </opt>
+#
+
+$_ = XMLout($ref,
+ grouptags => {dirs => 'dir'}, keyattr => {dir => 'name'},
+ contentkey => '-content'
+);
+
+like($_, qr{
+ ^<(\w+)>\s*
+ <dirs>\s*
+ <dir
+ (?:
+ \s+first="/usr/bin"
+ |\s+second="/usr/local/bin"
+ ){2}\s*
+ />\s*
+ </dirs>\s*
+ </\1>$
+}x, 'Failed to unwrap/group stripped content - as expected');
+
+
+# Check 'NoIndent' option
+
+$ref = {
+ nest => [ qw(one two three) ]
+};
+
+# Expect:
+#
+# <opt><nest>one</nest><nest>two</nest><nest>three</nest></opt>
+#
+
+$_ = XMLout($ref, NoIndent => 1);
+
+is_deeply(XMLin($_), $ref, 'parses ok');
+is($_, '<opt><nest>one</nest><nest>two</nest><nest>three</nest></opt>',
+'NoIndent worked ok');
+
+
+# Check 'NoIndent' works with KeyAttr
+
+$ref = {
+ person => {
+ bob => { age => 25 },
+ kate => { age => 22 },
+ },
+};
+
+# Expect:
+#
+# <opt><person name="bob" age="25"><person name="kate" age="22"></opt>
+#
+
+$_ = XMLout($ref, NoIndent => 1, KeyAttr => {person => 'name'});
+
+is_deeply(XMLin($_), $ref, 'parses ok');
+like($_, qr{
+ <opt>
+ (
+ <person(\s+name="bob"|\s+age="25"){2}\s*/>
+ |<person(\s+name="kate"|\s+age="22"){2}\s*/>
+ ){2}
+ </opt>
+}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($_, '<opt alpha="1"
+ beta="2"
+ gamma="3">
+ <colours green="#00ff00"
+ red="#ff0000" />
+</opt>
+', 'AttrIndent seems to work');
+
+
+# Test the attribute/element sorting algorithm
+
+$xml = q{
+<opt>
+ <test id="beta" animal="elephant" vegetable="carrot" />
+ <test id="gamma" animal="tiger" vegetable="turnip" />
+ <test id="alpha" animal="giraffe" vegetable="pumpkin" />
+ <box size="small" key="a" />
+ <box size="medium" id="b" />
+</opt>
+};
+
+$ref = XMLin($xml);
+
+$_ = XMLout($ref, RootName => 'opt');
+
+is($_, qq(<opt>\n) .
+ qq( <box name="a" size="small" />\n) .
+ qq( <box name="b" size="medium" />\n) .
+ qq( <test name="alpha" animal="giraffe" vegetable="pumpkin" />\n) .
+ qq( <test name="beta" animal="elephant" vegetable="carrot" />\n) .
+ qq( <test name="gamma" animal="tiger" vegetable="turnip" />\n) .
+ qq(</opt>\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(<opt>\n) .
+ qq( <box size="medium" id="b" />\n) .
+ qq( <box size="small" key="a" />\n) .
+ qq( <test vegetable="carrot" animal="elephant" id="beta" />\n) .
+ qq( <test vegetable="pumpkin" animal="giraffe" id="alpha" />\n) .
+ qq( <test vegetable="turnip" animal="tiger" id="gamma" />\n) .
+ qq(</opt>\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{^<opt>\s*
+ (
+ (
+ <test\s+animal="elephant"\s+id="beta"\s+vegetable="carrot"\s*/>\s*
+ <test\s+animal="tiger"\s+id="gamma"\s+vegetable="turnip"\s*/>\s*
+ <test\s+animal="giraffe"\s+id="alpha"\s+vegetable="pumpkin"\s*/>\s*
+ )
+ |(
+ <box\s+key="a"\s+size="small"\s*/>\s*
+ <box\s+id="b"\s+size="medium"\s*/>\s*
+ )
+ ){2}
+</opt>\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{
+ ^<opt\sJan="1"\sFeb="2"\sMar="3"\sApr="4"\sMay="5">\s+
+ <func(\sb="2"|\sname="X"){2}\s/>\s+
+ <func(\sc="3"|\sname="A"){2}\s/>\s+
+ <func(\sa="1"|\sname="Z"){2}\s/>\s+
+ <func(\sf="6"|\sname="M"){2}\s/>\s+
+ <func(\se="4"|\sname="K"){2}\s/>\s+
+ <func(\sd="5"|\sname="O"){2}\s/>\s+
+ </opt>\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{
+ ^<opt\s+two="2"\s*>
+ (
+ \s*<one\s+value="1"\s*/>
+ | \s*<six\s+num="6"\s*/>
+ ){2}
+ \s*</opt>$
+ }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..a98c6b4
--- /dev/null
+++ b/t/3_Storable.t
@@ -0,0 +1,235 @@
+
+use strict;
+use warnings;
+use Test::More;
+use File::Spec;
+
+
+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 = <IN>;
+ 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(<opt one="1" two="2"></opt>\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..2259eec
--- /dev/null
+++ b/t/4_MemShare.t
@@ -0,0 +1,151 @@
+
+use strict;
+use warnings;
+use Test::More;
+use File::Spec;
+
+
+# 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 = <IN>;
+ 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(<opt one="1" two="2"></opt>\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..4601a85
--- /dev/null
+++ b/t/5_MemCopy.t
@@ -0,0 +1,159 @@
+
+use strict;
+use warnings;
+use Test::More;
+use File::Spec;
+
+
+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 = <IN>;
+ 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(<opt one="1" two="2"></opt>\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..3a2e1ea
--- /dev/null
+++ b/t/6_ObjIntf.t
@@ -0,0 +1,380 @@
+
+use strict;
+use warnings;
+
+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 = '<![CDATA[' . $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(<cddatabase>
+ <disc id="9362-45055-2" cddbid="960b750c">
+ <artist>R.E.M.</artist>
+ <album>Automatic For The People</album>
+ <track number="1">Drive</track>
+ <track number="2">Try Not To Breathe</track>
+ <track number="3">The Sidewinder Sleeps Tonite</track>
+ <track number="4">Everybody Hurts</track>
+ <track number="5">New Orleans Instrumental No. 1</track>
+ <track number="6">Sweetness Follows</track>
+ <track number="7">Monty Got A Raw Deal</track>
+ <track number="8">Ignoreland</track>
+ <track number="9">Star Me Kitten</track>
+ <track number="10">Man On The Moon</track>
+ <track number="11">Nightswimming</track>
+ <track number="12">Find The River</track>
+ </disc>
+</cddatabase>
+);
+
+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{<track number="1">Drive</track>} {<NEST/>}, 't1');
+ok(s{<track number="2">Try Not To Breathe</track>} {<NEST/>}, 't2');
+ok(s{<track number="3">The Sidewinder Sleeps Tonite</track>} {<NEST/>}, 't3');
+ok(s{<track number="4">Everybody Hurts</track>} {<NEST/>}, 't4');
+ok(s{<track number="5">New Orleans Instrumental No. 1</track>}{<NEST/>}, 't5');
+ok(s{<track number="6">Sweetness Follows</track>} {<NEST/>}, 't6');
+ok(s{<track number="7">Monty Got A Raw Deal</track>} {<NEST/>}, 't7');
+ok(s{<track number="8">Ignoreland</track>} {<NEST/>}, 't8');
+ok(s{<track number="9">Star Me Kitten</track>} {<NEST/>}, 't9');
+ok(s{<track number="10">Man On The Moon</track>} {<NEST/>}, 't10');
+ok(s{<track number="11">Nightswimming</track>} {<NEST/>}, 't11');
+ok(s{<track number="12">Find The River</track>} {<NEST/>}, 't12');
+ok(s{<album>Automatic For The People</album>} {<NEST/>}, '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{<disc(\s+ATTR){3}\s*>(\s*<NEST/>){13}\s*</disc>}{<DISC/>}s, 'disc');
+ok(m{^\s*<(cddatabase)>\s*<DISC/>\s*</\1>\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(<opt>
+ <server>
+ <name>Apollo</name>
+ <address>10 Downing Street</address>
+ </server>
+</opt>
+);
+
+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{<opt>\s*
+ <server\s+address="<!\[CDATA\[12->14\s+"Puf&Stuf"\s+Drive\]\]>"\s*/>\s*
+</opt>}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(<opt>
+ <dir xsvar="log_dir">/var/log</dir>
+ <file name="config_file">${conf_dir}/appname.conf</file>
+ <file name="log_file">${log_dir}/appname.log</file>
+ <file name="debug_file">${log_dir}/appname.dbg</file>
+</opt>);
+
+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(<opt>
+ <file name="config_file">${conf_dir}/appname.conf</file>
+ <file name="log_file">${log_dir}/appname.log</file>
+ <file name="debug_file">${log_dir}/appname.dbg</file>
+</opt>);
+
+$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..8f70832
--- /dev/null
+++ b/t/7_SaxStuff.t
@@ -0,0 +1,279 @@
+
+use strict;
+use warnings;
+use Test::More;
+use File::Spec;
+use IO::File;
+
+
+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 = <IN>;
+ 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 = <XMLFILE>;
+ 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(<opt><anon>one</anon><anon>two</anon><anon>three</anon></opt>);
+$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('<opt a="1" b="2" />');
+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..9c83f3d
--- /dev/null
+++ b/t/8_Namespaces.t
@@ -0,0 +1,227 @@
+
+use strict;
+use warnings;
+use Test::More;
+use File::Spec;
+use IO::File;
+
+
+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 = <IN>;
+ 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(<config xmlns:perl="http://www.perl.com/">
+ <perl:list count="3" perl:type="array">
+ <item>one</item>
+ <item>two</item>
+ <item>three</item>
+ <test xmlns:perl="http://www.microsoft.com" perl:tm="trademark" />
+ </perl:list>
+</config>);
+
+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*<opt
+ (\s+{http://www.w3.org/2000/xmlns/}perl="http://www.perl.com/"
+ |\s+{http://www.perl.com/}attr="value"
+ |\s+bare="Beer!"){3}
+ \s*>
+ \s*<{http://www.perl.com/}element\s*>data</{http://www.perl.com/}element\s*>
+ \s*</opt>
+ \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*<opt
+ (\s+xmlns:perl="http://www.perl.com/"
+ |\s+perl:attr="value"
+ |\s+bare="Beer!"){3}
+ \s*>
+ \s*<perl:element\s*>data</perl:element\s*>
+ \s*</opt>
+ \s*$
+}sx, 'clarkian names are converted to qnames on output on request');
+
+
+# Check that default namespace is correctly read in ...
+
+$xml = q(<opt xmlns="http://www.orgsoc.org/">
+ <list>
+ <member>Tom</member>
+ <member>Dick</member>
+ <member>Larry</member>
+ </list>
+</opt>
+);
+
+$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*<opt
+ \s+xmlns="http://www.orgsoc.org/"
+ \s*>
+ \s*<list>
+ \s*<member>Tom</member>
+ \s*<member>Dick</member>
+ \s*<member>Larry</member>
+ \s*</list>
+ \s*</opt>
+ \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{<list\s+xmlns:(\w+)="http://www.phantom.com/"\s*>}) {
+ $prefix = $1;
+}
+ # regex match split in two to workaround 5.8.1/utf8/regex match prob
+like($xml, qr{
+ \s*<opt
+ \s+xmlns="http://www.orgsoc.org/"
+ \s*>
+ .*?
+ </list>
+ \s*</opt>
+}sx, 'namespace prefixes are generated automatically (part 1)');
+
+like($xml, qr{
+ (\s*<member>Tom</member>
+ \s*<member>Dick</member>
+ \s*<member>Larry</member>
+ |\s*<${prefix}:director>Bill</${prefix}:director>
+ \s*<${prefix}:director>Ben</${prefix}:director>){2}
+ #\s*</list>
+}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..db57841
--- /dev/null
+++ b/t/9_Strict.t
@@ -0,0 +1,373 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+plan tests => 44;
+
+
+##############################################################################
+# 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(<opt name1="value1" name2="value2"></opt>);
+
+$@ = '';
+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)<part> 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)<part> set in keyattr but not in forcearray/,
+ 'with the correct error message');
+
+
+# Confirm that missing key attributes are detected
+
+$xml = q(
+<opt>
+ <part partnum="12345" desc="Thingy" />
+ <part partnum="67890" desc="Wotsit" />
+ <part desc="Fnurgle" />
+</opt>
+);
+
+eval {
+ $opt = XMLin($xml, keyattr => { part => 'partnum' }, forcearray => 1);
+};
+
+isnt($@, '', 'key attribute missing from names element was a fatal error');
+like($@, qr/(?i)<part> element has no 'partnum' key attribute/,
+ 'with the correct error message');
+
+
+# Confirm that non-unique values in key attributes are detected
+
+$xml = q(
+<opt>
+ <part partnum="12345" desc="Thingy" />
+ <part partnum="67890" desc="Wotsit" />
+ <part partnum="12345" desc="Springy" />
+</opt>
+);
+
+eval {
+ $opt = XMLin($xml, keyattr => { part => 'partnum' }, forcearray => 1);
+};
+
+isnt($@, '', 'non-unique key attribute values was a fatal error');
+like($@, qr/(?i)<part> element has non-unique value in 'partnum' key attribute: 12345/,
+ 'with the correct error message');
+
+
+# Confirm that stringification of references is trapped
+
+$xml = q(
+<opt>
+ <item>
+ <name><firstname>Bob</firstname></name>
+ <age>21</age>
+ </item>
+</opt>
+);
+
+eval {
+ $opt = XMLin($xml, keyattr => { item => 'name' }, forcearray => ['item']);
+};
+
+isnt($@, '', 'key attribute not a scalar was a fatal error');
+like($@, qr/(?i)<item> 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*<list\s*>
+ \s*<person\s+name="bob"\s*/>
+ \s*<person\s+name="kate"\s*/>
+ \s*</list\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(<opt name1="value1" name2="value2"></opt>);
+
+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)<part> 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)<part> set in keyattr but not in forcearray/,
+ 'with the correct error message');
+
+
+# Confirm that missing key attributes are detected
+
+$xml = q(
+<opt>
+ <part partnum="12345" desc="Thingy" />
+ <part partnum="67890" desc="Wotsit" />
+ <part desc="Fnurgle" />
+</opt>
+);
+
+$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)<part> element has no 'partnum' key attribute/,
+ 'with the correct error message');
+
+
+# Confirm that stringification of references is trapped
+
+$xml = q(
+<opt>
+ <item>
+ <name><firstname>Bob</firstname></name>
+ <age>21</age>
+ </item>
+</opt>
+);
+
+$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)<item> 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*<list\s*>
+ \s*<person\s+name="bob"\s*/>
+ \s*<person\s+name="kate"\s*/>
+ \s*</list\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');
+
+
+# Confirm that code in other modules can still call XMLin without having
+# strict mode forced upon them.
+
+$xml = q(<opt name1="value1" name2="value2"></opt>);
+
+eval {
+ $opt = SimpleWrapper::XMLin($xml, keyattr => {});
+};
+
+is($@, '', 'other namespaces do not have strict mode forced upon them');
+
+# Unless those calls explicitly enable strict mode
+
+eval {
+ $opt = SimpleWrapper::XMLin($xml, StrictMode => 1, keyattr => {});
+};
+
+isnt($@, '', 'other namespaces do not have strict mode forced upon them');
+like($@, qr/(?i)No value specified for 'forcearray'/,
+ 'with the correct error message');
+
+# And calls in this namespace can turn strict mode off
+
+eval {
+ $opt = XMLin($xml, StrictMode => 0, keyattr => {});
+};
+
+is($@, '', 'other namespaces do not have strict mode forced upon them');
+
+exit(0);
+
+
+package SimpleWrapper;
+
+sub XMLin {
+ XML::Simple::XMLin(@_);
+}
diff --git a/t/A_XMLParser.t b/t/A_XMLParser.t
new file mode 100644
index 0000000..faa4ce3
--- /dev/null
+++ b/t/A_XMLParser.t
@@ -0,0 +1,129 @@
+
+use strict;
+use warnings;
+use Test::More;
+use IO::File;
+use File::Spec;
+
+
+# The suppress-able warnings still check the global flag
+
+$^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('<x y="z" />', 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('<x y="z" />', 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('<x y="z" />', 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(<opt name1="value1" name2="value2"></opt>));
+};
+
+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..9b66c2d
--- /dev/null
+++ b/t/B_Hooks.t
@@ -0,0 +1,134 @@
+
+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{
+ <nums>
+ <num id="one">I</num>
+ <num id="two">II</num>
+ <num id="three">III</num>
+ <num id="four">IV</num>
+ <num id="five">V</num>
+ <num id="six">VI</num>
+ <num id="seven">VII</num>
+ </nums>
+ };
+ 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 @@
+<config>
+ <server name="sahara" osname="solaris" osversion="2.6">
+ <address>10.0.0.101</address>
+ <address>10.0.1.101</address>
+ </server>
+ <server name="gobi" osname="irix" osversion="6.5">
+ <address>10.0.0.102</address>
+ </server>
+ <server name="kalahari" osname="linux" osversion="2.0.34">
+ <address>10.0.0.103</address>
+ <address>10.0.1.103</address>
+ </server>
+</config>
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/release-pod-syntax.t b/t/release-pod-syntax.t
new file mode 100644
index 0000000..d46a955
--- /dev/null
+++ b/t/release-pod-syntax.t
@@ -0,0 +1,15 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{RELEASE_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for release candidate testing');
+ }
+}
+
+use Test::More;
+
+eval "use Test::Pod 1.41";
+plan skip_all => "Test::Pod 1.41 required for testing POD" if $@;
+
+all_pod_files_ok();
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 @@
+<?xml version='1.0' standalone='yes'?>
+
+<!--
+
+ This is an example of what a simple config file used by the System Release
+ Tool (SRT) might look like. The file itself doesn't do anything other
+ than serve as a moderately complex test case for t/1_XMLin.t.
+
+ If you would like to find out more about the SRT, email the author at:
+
+ grantm@cpan.org
+
+-->
+
+<opt>
+ <global tempdir="C:/Temp"
+ httpproxy="http://10.1.1.5:8080/"
+ proxyuser="foo"
+ proxypswd="bar" >
+
+ <exclude>/_vt</exclude>
+ <exclude>/save\b</exclude>
+ <exclude>\.bak$</exclude>
+ <exclude>\.\$\$\$$</exclude>
+
+ </global>
+
+ <pubpath name="test1" title="web_source -&gt; web_target1">
+ <source label="web_source"
+ root="C:/webshare/web_source" />
+ <target label="web_target1"
+ root="C:/webshare/web_target1"
+ temp="C:/webshare/web_target1/temp" />
+
+ <dir>wwwroot</dir>
+
+ <package name="images" dir="wwwroot/images" />
+
+ </pubpath>
+
+ <pubpath name="test2" title="web_source -&gt; web_target1 &amp; web_target2">
+ <source label="web_source"
+ root="C:/webshare/web_source" />
+ <target label="web_target1"
+ root="C:/webshare/web_target1"
+ temp="C:/webshare/web_target1/temp" />
+ <target label="web_target2"
+ root="C:/webshare/web_target2"
+ temp="C:/webshare/web_target2/temp" />
+
+ <dir>wwwroot</dir>
+
+ <package name="images" dir="wwwroot/images" />
+ <package name="templates" dir="wwwroot/templates" />
+ <package name="bios" dir="wwwroot/staff/bios" />
+
+ </pubpath>
+
+ <pubpath name="test3" title="web_source -&gt; web_target1 via HTTP">
+ <source label="web_source"
+ root="C:/webshare/web_source" />
+ <target label="web_target1"
+ root="http://127.0.0.1/cgi-bin/srt_slave.plx"
+ noproxy="1" />
+
+ <dir>wwwroot</dir>
+
+ <addexclude>\.pdf$</addexclude>
+
+ </pubpath>
+
+</opt>
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 @@
+<opt location="t/subdir/test2.xml" />
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 @@
+<opt location="t/test1.xml" />
View Lorry Controller Status