# $Id: Simple.pm,v 1.23 2005/01/29 04:16:10 grantm Exp $



package XML::Simple;



=head1 NAME



XML::Simple - Easy API to maintain XML (esp config files)



=head1 SYNOPSIS



    use XML::Simple;



    my $ref = XMLin([<xml file or string>] [, <options>]);



    my $xml = XMLout($hashref [, <options>]);



Or the object oriented way:



    require XML::Simple;



    my $xs = new XML::Simple(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').



To catch common errors:



    use XML::Simple qw(:strict);



(see L<"STRICT MODE"> for more details).



=cut



# See after __END__ for more POD documentation





# Load essentials here, other modules loaded on demand later



use strict;

use Carp;

require Exporter;





##############################################################################

# Define some constants

#



use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);



@ISA               = qw(Exporter);

@EXPORT            = qw(XMLin XMLout);

@EXPORT_OK         = qw(xml_in xml_out);

$VERSION           = '2.14';

$PREFERRED_PARSER  = undef;



my $StrictMode     = 0;

my %CacheScheme    = (

                       storable => [ \&StorableSave, \&StorableRestore ],

                       memshare => [ \&MemShareSave, \&MemShareRestore ],

                       memcopy  => [ \&MemCopySave,  \&MemCopyRestore  ]

                     );



my @KnownOptIn     = qw(keyattr keeproot forcecontent contentkey noattr

                        searchpath forcearray cache suppressempty parseropts

                        grouptags nsexpand datahandler varattr variables

                        normalisespace normalizespace valueattr);



my @KnownOptOut    = qw(keyattr keeproot contentkey noattr

                        rootname xmldecl outputfile noescape suppressempty

                        grouptags nsexpand handler noindent attrindent nosort

                        valueattr numericescape);



my @DefKeyAttr     = qw(name key id);

my $DefRootName    = qq(opt);

my $DefContentKey  = qq(content);

my $DefXmlDecl     = qq(<?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

  

  $StrictMode = 1 if grep(/^:strict$/, @_);



  # Pass everything else to Exporter.pm



  __PACKAGE__->export_to_level(1, grep(!/^:strict$/, @_));

}





##############################################################################

# Constructor for optional object interface.

#



sub new {

  my $class = shift;



  if(@_ % 2) {

    croak "Default options must be name=>value pairs (odd number supplied)";

  }



  my %known_opt;

  @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100;



  my %raw_opt = @_;

  my %def_opt;

  while(my($key, $val) = each %raw_opt) {

    my $lkey = lc($key);

    $lkey =~ s/_//g;

    croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));

    $def_opt{$lkey} = $val;

  }

  my $self = { def_opt => \%def_opt };



  return(bless($self, $class));

}





##############################################################################

# Sub/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 {



  # If this is not a method call, create an object



  my $self;

  if($_[0]  and  UNIVERSAL::isa($_[0], 'XML::Simple')) {

    $self = shift;

  }

  else {

    $self = new XML::Simple();

  }





  my $string = shift;



  $self->handle_options('in', @_);





  # If no XML or filename supplied, look for scriptname.xml in script directory



  unless(defined($string))  {

    

    # Translate scriptname[.suffix] to scriptname.xml



    require File::Basename;



    my($ScriptName, $ScriptDir, $Extension) =

      File::Basename::fileparse($0, '\.[^\.]+');



    $string = $ScriptName . '.xml';





    # Add script directory to searchpath

    

    if($ScriptDir) {

      unshift(@{$self->{opt}->{searchpath}}, $ScriptDir);

    }

  }

  



  # Are we parsing from a file?  If so, is there a valid cache available?



  my($filename, $scheme);

  unless($string =~ m{<.*?>}s  or  ref($string)  or  $string eq '-') {



    require File::Basename;

    require File::Spec;



    $filename = $self->find_xml_file($string, @{$self->{opt}->{searchpath}});



    if($self->{opt}->{cache}) {

      foreach $scheme (@{$self->{opt}->{cache}}) {

        croak "Unsupported caching scheme: $scheme"

          unless($CacheScheme{$scheme});



        my $opt = $CacheScheme{$scheme}->[1]->($filename);

        return($opt) if($opt);

      }

    }

  }

  else {

    delete($self->{opt}->{cache});

    if($string eq '-') {

      # Read from standard input



      local($/) = undef;

      $string = <STDIN>;

    }

  }





  # Parsing is required, so let's get on with it



  my $tree =  $self->build_tree($filename, $string);





  # Now work some magic on the resulting parse tree



  my($ref);

  if($self->{opt}->{keeproot}) {

    $ref = $self->collapse({}, @$tree);

  }

  else {

    $ref = $self->collapse(@{$tree->[1]});

  }



  if($self->{opt}->{cache}) {

    $CacheScheme{$self->{opt}->{cache}->[0]}->[0]->($ref, $filename);

  }



  return($ref);

}





##############################################################################

# 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 'string' as argument 1 or a filename as

# argument 2.  The 'string' might be a string of XML 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)) {

      $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 = new XML::Parser(Style => 'Tree', @{$self->{opt}->{parseropts}});

  my($tree);

  if($filename) {

    # $tree = $xp->parsefile($filename);  # Changed due to prob w/mod_perl

    local(*XML_FILE);

    open(XML_FILE, '<', $filename) || croak qq($filename - $!);

    $tree = $xp->parse(*XML_FILE);

    close(XML_FILE);

  }

  else {

    $tree = $xp->parse($string);

  }



  return($tree);

}





##############################################################################

# Sub: StorableSave()

#

# Wrapper routine for invoking Storable::nstore() to cache a parsed data

# structure.

#



sub StorableSave {

  my($data, $filename) = @_;



  my $cachefile = $filename;

  $cachefile =~ s{(\.xml)?$}{.stor};



  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);

  }

  

}





##############################################################################

# Sub: StorableRestore()

#

# 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 StorableRestore {

  my($filename) = @_;

  

  my $cachefile = $filename;

  $cachefile =~ s{(\.xml)?$}{.stor};



  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));

  }

  

}





##############################################################################

# Sub: MemShareSave()

#

# Takes the supplied data structure reference and stores it away in a global

# hash structure.

#



sub MemShareSave {

  my($data, $filename) = @_;



  $MemShareCache{$filename} = [time(), $data];

}





##############################################################################

# Sub: MemShareRestore()

#

# Takes a filename and looks in a global hash for a cached parsed version.

#



sub MemShareRestore {

  my($filename) = @_;

  

  return unless($MemShareCache{$filename});

  return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);



  return($MemShareCache{$filename}->[1]);

  

}





##############################################################################

# Sub: MemCopySave()

#

# Takes the supplied data structure and stores a copy of it in a global hash

# structure.

#



sub MemCopySave {

  my($data, $filename) = @_;



  require Storable;           # We didn't need it until now

  

  $MemCopyCache{$filename} = [time(), Storable::dclone($data)];

}





##############################################################################

# Sub: MemCopyRestore()

#

# 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 MemCopyRestore {

  my($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 {



  # If this is not a method call, create an object



  my $self;

  if($_[0]  and  UNIVERSAL::isa($_[0], 'XML::Simple')) {

    $self = shift;

  }

  else {

    $self = new XML::Simple();

  }



  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})) {

      return($self->{opt}->{outputfile}->print($xml));

    }

    else {

      local(*OUT);

      open(OUT, '>', "$self->{opt}->{outputfile}") ||

        croak "open($self->{opt}->{outputfile}): $!";

      binmode(OUT, ':utf8') if($] >= 5.008);

      print OUT $xml || croak "print: $!";

      close(OUT);

    }

  }

  elsif($self->{opt}->{handler}) {

    require XML::SAX;

    my $sp = XML::SAX::ParserFactory->parser(

               Handler => $self->{opt}->{handler}

             );

    return($sp->parse_string($xml));

  }

  else {

    return($xml);

  }

}





##############################################################################

# Method: handle_options()

#

# Helper routine for both XMLin() and XMLout().  Both routines handle their

# first argument and assume all other args are options handled by this routine.

# Saves a hash of options in $self->{opt}.

#

# If default options were passed to the constructor, they will be retrieved

# here and merged with options supplied to the method call.

#

# First argument should be the string 'in' or the string 'out'.

#

# Remaining arguments should be name=>value pairs.  Sets up default values

# for options not supplied.  Unrecognised options are a fatal error.

#



sub handle_options  {

  my $self = shift;

  my $dirn = shift;





  # Determine valid options based on context



  my %known_opt; 

  if($dirn eq 'in') {

    @known_opt{@KnownOptIn} = @KnownOptIn;

  }

  else {

    @known_opt{@KnownOptOut} = @KnownOptOut;

  }





  # Store supplied options in hashref and weed out invalid ones



  if(@_ % 2) {

    croak "Options must be name=>value pairs (odd number supplied)";

  }

  my %raw_opt  = @_;

  my $opt      = {};

  $self->{opt} = $opt;



  while(my($key, $val) = each %raw_opt) {

    my $lkey = lc($key);

    $lkey =~ s/_//g;

    croak "Unrecognised option: $key" unless($known_opt{$lkey});

    $opt->{$lkey} = $val;

  }





  # Merge in options passed to constructor



  foreach (keys(%known_opt)) {

    unless(exists($opt->{$_})) {

      if(exists($self->{def_opt}->{$_})) {

        $opt->{$_} = $self->{def_opt}->{$_};

      }

    }

  }





  # Set sensible defaults if not supplied

  

  if(exists($opt->{rootname})) {

    unless(defined($opt->{rootname})) {

      $opt->{rootname} = '';

    }

  }

  else {

    $opt->{rootname} = $DefRootName;

  }

  

  if($opt->{xmldecl}  and  $opt->{xmldecl} eq '1') {

    $opt->{xmldecl} = $DefXmlDecl;

  }



  if(exists($opt->{contentkey})) {

    if($opt->{contentkey} =~ m{^-(.*)$}) {

      $opt->{contentkey} = $1;

      $opt->{collapseagain} = 1;

    }

  }

  else {

    $opt->{contentkey} = $DefContentKey;

  }



  unless(exists($opt->{normalisespace})) {

    $opt->{normalisespace} = $opt->{normalizespace};

  }

  $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));



  # Cleanups for values assumed to be arrays later



  if($opt->{searchpath}) {

    unless(ref($opt->{searchpath})) {

      $opt->{searchpath} = [ $opt->{searchpath} ];

    }

  }

  else  {

    $opt->{searchpath} = [ ];

  }



  if($opt->{cache}  and !ref($opt->{cache})) {

    $opt->{cache} = [ $opt->{cache} ];

  }

  if($opt->{cache}) {

    $_ = lc($_) foreach (@{$opt->{cache}});

  }

  

  if(exists($opt->{parseropts})) {

    if($^W) {

      carp "Warning: " .

           "'ParserOpts' is deprecated, contact the author if you need it";

    }

  }

  else {

    $opt->{parseropts} = [ ];

  }



  

  # Special cleanup for {forcearray} which could be regex, arrayref or boolean

  # or left to default to 0



  if(exists($opt->{forcearray})) {

    if(ref($opt->{forcearray}) eq 'Regexp') {

      $opt->{forcearray} = [ $opt->{forcearray} ];

    }



    if(ref($opt->{forcearray}) eq 'ARRAY') {

      my @force_list = @{$opt->{forcearray}};

      if(@force_list) {

        $opt->{forcearray} = {};

        foreach my $tag (@force_list) {

          if(ref($tag) eq 'Regexp') {

            push @{$opt->{forcearray}->{_regex}}, $tag;

          }

          else {

            $opt->{forcearray}->{$tag} = 1;

          }

        }

      }

      else {

        $opt->{forcearray} = 0;

      }

    }

    else {

      $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );

    }

  }

  else {

    if($StrictMode  and  $dirn eq 'in') {

      croak "No value specified for 'ForceArray' option in call to XML$dirn()";

    }

    $opt->{forcearray} = 0;

  }





  # Special cleanup for {keyattr} which could be arrayref or hashref or left

  # to default to arrayref



  if(exists($opt->{keyattr}))  {

    if(ref($opt->{keyattr})) {

      if(ref($opt->{keyattr}) eq 'HASH') {



        # Make a copy so we can mess with it



        $opt->{keyattr} = { %{$opt->{keyattr}} };



        

        # Convert keyattr => { elem => '+attr' }

        # to keyattr => { elem => [ 'attr', '+' ] } 



        foreach my $el (keys(%{$opt->{keyattr}})) {

          if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {

            $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];

            if($StrictMode  and  $dirn eq 'in') {

              next if($opt->{forcearray} == 1);

              next if(ref($opt->{forcearray}) eq 'HASH'

                      and $opt->{forcearray}->{$el});

              croak "<$el> set in KeyAttr but not in ForceArray";

            }

          }

          else {

            delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)

          }

        }

      }

      else {

        if(@{$opt->{keyattr}} == 0) {

          delete($opt->{keyattr});

        }

      }

    }

    else {

      $opt->{keyattr} = [ $opt->{keyattr} ];

    }

  }

  else  {

    if($StrictMode) {

      croak "No value specified for 'KeyAttr' option in call to XML$dirn()";

    }

    $opt->{keyattr} = [ @DefKeyAttr ];

  }





  # Special cleanup for {valueattr} which could be arrayref or hashref



  if(exists($opt->{valueattr})) {

    if(ref($opt->{valueattr}) eq 'ARRAY') {

      $opt->{valueattrlist} = {};

      $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });

    }

  }



  # make sure there's nothing weird in {grouptags}



  if($opt->{grouptags} and !UNIVERSAL::isa($opt->{grouptags}, 'HASH')) {

    croak "Illegal value for 'GroupTags' option - expected a hashref";

  }





  # 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 = @_;





  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 = {};

  }

  elsif($self->{opt}->{normalisespace} == 2) {

    while(my($key, $value) = each %$attr) {

      $attr->{$key} = $self->normalise_space($value)

    }

  }





  # Do variable substitutions



  if(my $var = $self->{_var_values}) {

    while(my($key, $val) = each(%$attr)) {

      $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;

      $attr->{$key} = $val;

    }

  }





  # Roll up 'value' attributes (but only if no nested elements)



  if(!@_  and  keys %$attr == 1) {

    my($k) = keys %$attr;

    if($self->{opt}->{valueattrlist}  and $self->{opt}->{valueattrlist}->{$k}) {

      return $attr->{$k};

    }

  }





  # Add any nested elements



  my($key, $val);

  while(@_) {

    $key = shift;

    $val = shift;



    if(ref($val)) {

      $val = $self->collapse(@$val);

      next if(!defined($val)  and  $self->{opt}->{suppressempty});

    }

    elsif($key eq '0') {

      next if($val =~ m{^\s*$}s);  # Skip all whitespace content



      $val = $self->normalise_space($val)

        if($self->{opt}->{normalisespace} == 2);



      # do variable substitutions



      if(my $var = $self->{_var_values}) { 

        $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;

      }



      

      # look for variable definitions



      if(my $var = $self->{opt}->{varattr}) { 

        if(exists $attr->{$var}) {

          $self->set_var($attr->{$var}, $val);

        }

      }





      # Collapse text content in element with no attributes to a string



      if(!%$attr  and  !@_) {

        return($self->{opt}->{forcecontent} ? 

          { $self->{opt}->{contentkey} => $val } : $val

        );

      }

      $key = $self->{opt}->{contentkey};

    }





    # Combine duplicate attributes into arrayref if required



    if(exists($attr->{$key})) {

      if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {

        push(@{$attr->{$key}}, $val);

      }

      else {

        $attr->{$key} = [ $attr->{$key}, $val ];

      }

    }

    elsif(defined($val)  and  UNIVERSAL::isa($val, 'ARRAY')) {

      $attr->{$key} = [ $val ];

    }

    else {

      if( $key ne $self->{opt}->{contentkey} 

          and (

            ($self->{opt}->{forcearray} == 1)

            or ( 

              (ref($self->{opt}->{forcearray}) eq 'HASH')

              and (

                $self->{opt}->{forcearray}->{$key}

                or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})

              )

            )

          )

        ) {

        $attr->{$key} = [ $val ];

      }

      else {

        $attr->{$key} = $val;

      }

    }



  }





  # Turn arrayrefs into hashrefs if key fields present



  if($self->{opt}->{keyattr}) {

    while(($key,$val) = each %$attr) {

      if(defined($val)  and  UNIVERSAL::isa($val, 'ARRAY')) {

        $attr->{$key} = $self->array_to_hash($key, $val);

      }

    }

  }





  # disintermediate grouped tags



  if($self->{opt}->{grouptags}) {

    while(my($key, $val) = each(%$attr)) {

      next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));

      next unless(exists($self->{opt}->{grouptags}->{$key}));



      my($child_key, $child_val) =  %$val;



      if($self->{opt}->{grouptags}->{$key} eq $child_key) {

        $attr->{$key}= $child_val;

      }

    }

  }





  # Fold hashes containing a single anonymous array up into just the array



  my $count = scalar keys %$attr;

  if($count == 1 

     and  exists $attr->{anon}  

     and  UNIVERSAL::isa($attr->{anon}, 'ARRAY')

  ) {

    return($attr->{anon});

  }





  # Do the right thing if hash is empty, otherwise just return it



  if(!%$attr  and  exists($self->{opt}->{suppressempty})) {

    if(defined($self->{opt}->{suppressempty})  and

       $self->{opt}->{suppressempty} eq '') {

      return('');

    }

    return(undef);

  }





  # Roll up named elements with named nested 'value' attributes



  if($self->{opt}->{valueattr}) {

    while(my($key, $val) = each(%$attr)) {

      next unless($self->{opt}->{valueattr}->{$key});

      next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));

      my($k) = keys %$val;

      next unless($k eq $self->{opt}->{valueattr}->{$key});

      $attr->{$key} = $val->{$k};

    }

  }



  return($attr)



}





##############################################################################

# Method: set_var()

#

# Called when a variable definition is encountered in the XML.  (A variable

# definition looks like <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  = {};



  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)) {

          if($StrictMode) {

            croak "<$name> element has non-scalar '$key' key attribute";

          }

          if($^W) {

            carp "Warning: <$name> element has non-scalar '$key' key attribute";

          }

          return($arrayref);

        }

        $val = $self->normalise_space($val)

          if($self->{opt}->{normalisespace} == 1);

        $hashref->{$val} = { %{$arrayref->[$i]} };

        $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');

        delete $hashref->{$val}->{$key} unless($flag eq '+');

      }

      else {

        croak "<$name> element has no '$key' key attribute" if($StrictMode);

        carp "Warning: <$name> element has no '$key' key attribute" if($^W);

        return($arrayref);

      }

    }

  }





  # Or assume keyattr => [ .... ]



  else {

    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};

          return($arrayref) if(ref($val));

          $val = $self->normalise_space($val)

            if($self->{opt}->{normalisespace} == 1);

          $hashref->{$val} = { %{$arrayref->[$i]} };

          delete $hashref->{$val}->{$key};

          next ELEMENT;

        }

      }



      return($arrayref);    # No keyfield matched

    }

  }

  

  # collapse any hashes which now only have a 'content' key



  if($self->{opt}->{collapseagain}) {

    $hashref = $self->collapse_content($hashref);

  }

 

  return($hashref);

}





##############################################################################

# Method: 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->{opt}->{grouptags}->{$key} => $val };

        }

      }

    }





    # Scan for namespace declaration attributes



    my $nsdecls = '';

    my $default_ns_uri;

    if($self->{nsup}) {

      $ref = $self->copy_hash($ref);

      $self->{nsup}->push_context();



      # Look for default namespace declaration first



      if(exists($ref->{xmlns})) {

        $self->{nsup}->declare_prefix('', $ref->{xmlns});

        $nsdecls .= qq( xmlns="$ref->{xmlns}"); 

        delete($ref->{xmlns});

      }

      $default_ns_uri = $self->{nsup}->get_uri('');





      # Then check all the other keys



      foreach my $qname (keys(%$ref)) {

        my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);

        if($uri) {

          if($uri eq $xmlns_ns) {

            $self->{nsup}->declare_prefix($lname, $ref->{$qname});

            $nsdecls .= qq( xmlns:$lname="$ref->{$qname}"); 

            delete($ref->{$qname});

          }

        }

      }



      # Translate any remaining Clarkian names



      foreach my $qname (keys(%$ref)) {

        my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);

        if($uri) {

          if($default_ns_uri  and  $uri eq $default_ns_uri) {

            $ref->{$lname} = $ref->{$qname};

            delete($ref->{$qname});

          }

          else {

            my $prefix = $self->{nsup}->get_prefix($uri);

            unless($prefix) {

              # $self->{nsup}->declare_prefix(undef, $uri);

              # $prefix = $self->{nsup}->get_prefix($uri);

              $prefix = $self->{ns_prefix}++;

              $self->{nsup}->declare_prefix($prefix, $uri);

              $nsdecls .= qq( xmlns:$prefix="$uri"); 

            }

            $ref->{"$prefix:$lname"} = $ref->{$qname};

            delete($ref->{$qname});

          }

        }

      }

    }





    my @nested = ();

    my $text_content = undef;

    if($named) {

      push @result, $indent, '<', $name, $nsdecls;

    }



    if(keys %$ref) {

      my $first_arg = 1;

      foreach my $key ($self->sorted_keys($name, $ref)) {

        my $value = $ref->{$key};

        next if(substr($key, 0, 1) eq '-');

        if(!defined($value)) {

          next if $self->{opt}->{suppressempty};

          unless(exists($self->{opt}->{suppressempty})

             and !defined($self->{opt}->{suppressempty})

          ) {

            carp 'Use of uninitialized value' if($^W);

          }

          if($key eq $self->{opt}->{contentkey}) {

            $text_content = '';

          }

          else {

            $value = exists($self->{opt}->{suppressempty}) ? {} : '';

          }

        }



        if(!ref($value)  

           and $self->{opt}->{valueattr}

           and $self->{opt}->{valueattr}->{$key}

        ) {

          $value = { $self->{opt}->{valueattr}->{$key} => $value };

        }



        if(ref($value)  or  $self->{opt}->{noattr}) {

          push @nested,

            $self->value_to_xml($value, $key, "$indent  ");

        }

        else {

          $value = $self->escape_value($value) unless($self->{opt}->{noescape});

          if($key eq $self->{opt}->{contentkey}) {

            $text_content = $value;

          }

          else {

            push @result, "\n$indent " . ' ' x length($name)

              if($self->{opt}->{attrindent}  and  !$first_arg);

            push @result, ' ', $key, '="', $value , '"';

            $first_arg = 0;

          }

        }

      }

    }

    else {

      $text_content = '';

    }



    if(@nested  or  defined($text_content)) {

      if($named) {

        push @result, ">";

        if(defined($text_content)) {

          push @result, $text_content;

          $nested[0] =~ s/^\s+// if(@nested);

        }

        else {

          push @result, $nl;

        }

        if(@nested) {

          push @result, @nested, $indent;

        }

        push @result, '</', $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) {

      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 QUICK START



Say you have a script called B<foo> and a file of configuration options

called B<foo.xml> containing this:



  <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;



  my $config = XMLin();



will 'slurp' the configuration options into the hashref $config (because no

arguments are passed 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];



What could be simpler?  (Rhetorical).



For simple requirements, that's really all there is to it.  If you want to

store your XML in a different directory or file, or pass it in as a string or

even pass it in via some derivative of an IO::Handle, you'll need to check out

L<"OPTIONS">.  If you want to turn off or tweak the array folding feature (that

neat little transformation that produced $config->{server}) you'll find options

for that as well.



If you want to generate XML (for example to write a modified version of

$config back out as XML), check out C<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 = new IO::File('/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 setting this option

to an empty list to disable the feature.



Note 2: If you wish to use this option, you should also enable the

C<ForceArray> option.  Without 'ForceArray',