Description :
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
use strict;
use Carp;
require Exporter;
use vars qw($VERSION AATTISA AATTEXPORT AATTEXPORT_OK $PREFERRED_PARSER);
AATTISA = qw(Exporter);
AATTEXPORT = qw(XMLin XMLout);
AATTEXPORT_OK = qw(xml_in xml_out);
$VERSION = \'2.09\';
$PREFERRED_PARSER = undef;
my $StrictMode = 0;
my %CacheScheme = (
storable => [ \\&StorableSave, \\&StorableRestore ],
memshare => [ \\&MemShareSave, \\&MemShareRestore ],
memcopy => [ \\&MemCopySave, \\&MemCopyRestore ]
);
my AATTKnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr
searchpath forcearray cache suppressempty parseropts
grouptags nsexpand datahandler varattr variables
normalisespace normalizespace);
my AATTKnownOptOut = qw(keyattr keeproot contentkey noattr
rootname xmldecl outputfile noescape suppressempty
grouptags nsexpand handler noindent);
my AATTDefKeyAttr = 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
my %MemShareCache = ();
my %MemCopyCache = ();
sub import {
$StrictMode = 1 if grep(/^:strict$/, AATT_);
__PACKAGE__->export_to_level(1, grep(!/^:strict$/, AATT_));
}
sub new {
my $class = shift;
if(AATT_ % 2) {
croak \"Default options must be name=>value pairs (odd number supplied)\";
}
my %known_opt;
AATTknown_opt{AATTKnownOptIn, AATTKnownOptOut} = (undef) x 100;
my %raw_opt = AATT_;
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 XMLin {
my $self;
if($_[0] and UNIVERSAL::isa($_[0], \'XML::Simple\')) {
$self = shift;
}
else {
$self = new XML::Simple();
}
my $string = shift;
$self->handle_options(\'in\', AATT_);
unless(defined($string)) {
require File::Basename;
my($ScriptName, $ScriptDir, $Extension) =
File::Basename::fileparse($0, \'\\.[^\\.]+\');
$string = $ScriptName . \'.xml\';
if($ScriptDir) {
unshift(AATT{$self->{opt}->{searchpath}}, $ScriptDir);
}
}
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, AATT{$self->{opt}->{searchpath}});
if($self->{opt}->{cache}) {
foreach $scheme (AATT{$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 \'-\') {
local($/) = undef;
$string = < STDIN>
}
}
my $tree = $self->build_tree($filename, $string);
my($ref);
if($self->{opt}->{keeproot}) {
$ref = $self->collapse({}, AATT$tree);
}
else {
$ref = $self->collapse(AATT{$tree->[1]});
}
if($self->{opt}->{cache}) {
$CacheScheme{$self->{opt}->{cache}->[0]}->[0]->($ref, $filename);
}
return($ref);
}
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($AATT) { # 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);
}
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($AATT) {
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\', AATT{$self->{opt}->{parseropts}});
my($tree);
if($filename) {
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 {
my($data, $filename) = AATT_;
my $cachefile = $filename;
$cachefile =~ s{(\\.xml)?$}{.stor};
require Storable; # We didn\'t need it until now
Storable::lock_nstore($data, $cachefile);
}
sub StorableRestore {
my($filename) = AATT_;
my $cachefile = $filename;
$cachefile =~ s{(\\.xml)?$}{.stor};
return unless(-r $cachefile);
return unless((stat($cachefile))[9] > (stat($filename))[9]);
unless($INC{\'Storable.pm\'}) {
require Storable; # We didn\'t need it until now
}
return(Storable::lock_retrieve($cachefile));
}
sub MemShareSave {
my($data, $filename) = AATT_;
$MemShareCache{$filename} = [time(), $data];
}
sub MemShareRestore {
my($filename) = AATT_;
return unless($MemShareCache{$filename});
return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);
return($MemShareCache{$filename}->[1]);
}
sub MemCopySave {
my($data, $filename) = AATT_;
unless($INC{\'Storable.pm\'}) {
require Storable; # We didn\'t need it until now
}
$MemCopyCache{$filename} = [time(), Storable::dclone($data)];
}
sub MemCopyRestore {
my($filename) = AATT_;
return unless($MemCopyCache{$filename});
return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);
return(Storable::dclone($MemCopyCache{$filename}->[1]));
}
sub XMLout {
my $self;
if($_[0] and UNIVERSAL::isa($_[0], \'XML::Simple\')) {
$self = shift;
}
else {
$self = new XML::Simple();
}
my $ref = shift;
$self->handle_options(\'out\', AATT_);
if($self->{opt}->{nsexpand}) {
require XML::NamespaceSupport;
$self->{nsup} = XML::NamespaceSupport->new();
$self->{ns_prefix} = \'aaa\';
}
if(UNIVERSAL::isa($ref, \'ARRAY\')) {
$ref = { anon => $ref };
}
if($self->{opt}->{keeproot}) {
my(AATTkeys) = keys(%$ref);
if(AATTkeys == 1) {
$ref = $ref->{$keys[0]};
$self->{opt}->{rootname} = $keys[0];
}
}
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->{$_} ];
}
}
}
}
$self->{_ancestors} = [];
my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, \'\');
delete $self->{_ancestors};
if($self->{opt}->{xmldecl}) {
$xml = $self->{opt}->{xmldecl} . \"\
\" . $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}): $!\";
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);
}
}
sub handle_options {
my $self = shift;
my $dirn = shift;
my %known_opt;
if($dirn eq \'in\') {
AATTknown_opt{AATTKnownOptIn} = AATTKnownOptIn;
}
else {
AATTknown_opt{AATTKnownOptOut} = AATTKnownOptOut;
}
if(AATT_ % 2) {
croak \"Options must be name=>value pairs (odd number supplied)\";
}
my %raw_opt = AATT_;
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;
}
if($self->{def_opt}) {
foreach (keys(%known_opt)) {
unless(exists($opt->{$_})) {
if(exists($self->{def_opt}->{$_})) {
$opt->{$_} = $self->{def_opt}->{$_};
}
}
}
}
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}));
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 (AATT{$opt->{cache}});
}
if(exists($opt->{parseropts})) {
if($^W) {
carp \"Warning: \" .
\"\'ParserOpts\' is deprecated, contact the author if you need it\";
}
}
else {
$opt->{parseropts} = [ ];
}
if(exists($opt->{forcearray})) {
if(ref($opt->{forcearray}) eq \'Regexp\') {
$opt->{forcearray} = [ $opt->{forcearray} ];
}
if(ref($opt->{forcearray}) eq \'ARRAY\') {
my AATTforce_list = AATT{$opt->{forcearray}};
if(AATTforce_list) {
$opt->{forcearray} = {};
foreach my $tag (AATTforce_list) {
if(ref($tag) eq \'Regexp\') {
push AATT{$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;
}
if(exists($opt->{keyattr})) {
if(ref($opt->{keyattr})) {
if(ref($opt->{keyattr}) eq \'HASH\') {
$opt->{keyattr} = { %{$opt->{keyattr}} };
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(AATT{$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} = [ AATTDefKeyAttr ];
}
if($opt->{grouptags} and !UNIVERSAL::isa($opt->{grouptags}, \'HASH\')) {
croak \"Illegal value for \'GroupTags\' option - expected a hashref\";
}
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} = {};
}
}
sub find_xml_file {
my $self = shift;
my $file = shift;
my AATTsearch_path = AATT_;
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 (AATTsearch_path) {
my $fullpath = File::Spec->catfile($path, $file);
return($fullpath) if(-e $fullpath);
}
}
if(!AATTsearch_path) {
if(-e $file) {
return($file);
}
croak \"File does not exist: $file\";
}
croak \"Could not find $file in \", join(\':\', AATTsearch_path);
}
sub collapse {
my $self = shift;
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)
}
}
if(my $var = $self->{_var_values}) {
while(my($key, $val) = each(%$attr)) {
$val =~ s{\\$\\{(\\w+)\\}}{ $self->get_var($1) }ge;
$attr->{$key} = $val;
}
}
my($key, $val);
while(AATT_) {
$key = shift;
$val = shift;
if(ref($val)) {
$val = $self->collapse(AATT$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);
if(my $var = $self->{_var_values}) {
$val =~ s{\\$\\{(\\w+)\\}}{ $self->get_var($1) }ge;
}
if(my $var = $self->{opt}->{varattr}) {
if(exists $attr->{$var}) {
$self->set_var($attr->{$var}, $val);
}
}
if(!%$attr and !AATT_) {
return($self->{opt}->{forcecontent} ?
{ $self->{opt}->{contentkey} => $val } : $val
);
}
$key = $self->{opt}->{contentkey};
}
if(exists($attr->{$key})) {
if(UNIVERSAL::isa($attr->{$key}, \'ARRAY\')) {
push(AATT{$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 =~ $_, AATT{$self->{opt}->{forcearray}->{_regex}})
)
)
)
) {
$attr->{$key} = [ $val ];
}
else {
$attr->{$key} = $val;
}
}
}
my $count = 0;
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);
}
$count++;
}
}
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;
}
}
}
if($count == 1
and exists $attr->{anon}
and UNIVERSAL::isa($attr->{anon}, \'ARRAY\')
) {
return($attr->{anon});
}
if(!%$attr and exists($self->{opt}->{suppressempty})) {
if(defined($self->{opt}->{suppressempty}) and
$self->{opt}->{suppressempty} eq \'\') {
return(\'\');
}
return(undef);
}
return($attr)
}
sub set_var {
my($self, $name, $value) = AATT_;
$self->{_var_values}->{$name} = $value;
}
sub get_var {
my($self, $name) = AATT_;
my $value = $self->{_var_values}->{$name};
return $value if(defined($value));
return \'${\' . $name . \'}\';
}
sub normalise_space {
my($self, $text) = AATT_;
$text =~ s/^\\s+//s;
$text =~ s/\\s+$//s;
$text =~ s/\\s\\s+/ /sg;
return $text;
}
sub array_to_hash {
my $self = shift;
my $name = shift;
my $arrayref = shift;
my $hashref = {};
my($i, $key, $val, $flag);
if(ref($self->{opt}->{keyattr}) eq \'HASH\') {
return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
($key, $flag) = AATT{$self->{opt}->{keyattr}->{$name}};
for($i = 0; $i < AATT$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);
}
}
}
else {
ELEMENT: for($i = 0; $i < AATT$arrayref; $i++) {
return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], \'HASH\'));
foreach $key (AATT{$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
}
}
if($self->{opt}->{collapseagain}) {
$hashref = $self->collapse_content($hashref);
}
return($hashref);
}
sub collapse_content {
my $self = shift;
my $hashref = shift;
my $contentkey = $self->{opt}->{contentkey};
foreach my $val (values %$hashref) {
return $hashref unless ( (ref($val) eq \'HASH\')
and (keys %$val == 1)
and (exists $val->{$contentkey})
);
}
foreach my $key (keys %$hashref) {
$hashref->{$key}= $hashref->{$key}->{$contentkey};
}
return $hashref;
}
sub value_to_xml {
my $self = shift;;
my($ref, $name, $indent) = AATT_;
my $named = (defined($name) and $name ne \'\' ? 1 : 0);
my $nl = \"\
\";
if($self->{opt}->{noindent}) {
$indent = \'\';
$nl = \'\';
}
if(ref($ref)) {
croak \"circular data structures not supported\"
if(grep($_ == $ref, AATT{$self->{_ancestors}}));
push AATT{$self->{_ancestors}}, $ref;
}
else {
if($named) {
return(join(\'\',
$indent, \'< \', $name, \'>\',
($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
\'< /\', $name, \">\", $nl
));
}
else {
return(\"$ref$nl\");
}
}
if(UNIVERSAL::isa($ref, \'HASH\') # It is a hash
and %$ref # and it\'s not empty
and $self->{opt}->{keyattr} # and folding is enabled
and $indent # and its not the root element
) {
$ref = $self->hash_to_array($name, $ref);
}
my AATTresult = ();
my($key, $value);
if(UNIVERSAL::isa($ref, \'HASH\')) {
if($self->{opt}->{grouptags}) {
while(my($key, $val) = each %$ref) {
if($self->{opt}->{grouptags}->{$key}) {
$ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val };
}
}
}
my $nsdecls = \'\';
my $default_ns_uri;
if($self->{nsup}) {
$ref = { %$ref }; # Make a copy before we mess with it
$self->{nsup}->push_context();
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(\'\');
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});
}
}
}
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) {
$prefix = $self->{ns_prefix}++;
$self->{nsup}->declare_prefix($prefix, $uri);
$nsdecls .= qq( xmlns:$prefix=\"$uri\");
}
$ref->{\"$prefix:$lname\"} = $ref->{$qname};
delete($ref->{$qname});
}
}
}
}
my AATTnested = ();
my $text_content = undef;
if($named) {
push AATTresult, $indent, \'< \', $name, $nsdecls;
}
if(keys %$ref) {
while(($key, $value) = each(%$ref)) {
next if(substr($key, 0, 1) eq \'-\');
if(!defined($value)) {
unless(exists($self->{opt}->{suppressempty})
and !defined($self->{opt}->{suppressempty})
) {
carp \'Use of uninitialized value\' if($^W);
}
$value = {};
}
if(ref($value) or $self->{opt}->{noattr}) {
push AATTnested,
$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 AATTresult, \' \', $key, \'=\"\', $value , \'\"\';
}
}
}
}
else {
$text_content = \'\';
}
if(AATTnested or defined($text_content)) {
if($named) {
push AATTresult, \">\";
if(defined($text_content)) {
push AATTresult, $text_content;
$nested[0] =~ s/^\\s+// if(AATTnested);
}
else {
push AATTresult, $nl;
}
if(AATTnested) {
push AATTresult, AATTnested, $indent;
}
push AATTresult, \'< /\', $name, \">\", $nl;
}
else {
push AATTresult, AATTnested; # Special case if no root elements
}
}
else {
push AATTresult, \" />\", $nl;
}
$self->{nsup}->pop_context() if($self->{nsup});
}
elsif(UNIVERSAL::isa($ref, \'ARRAY\')) {
foreach $value (AATT$ref) {
if(!ref($value)) {
push AATTresult,
$indent, \'< \', $name, \'>\',
($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
\'< /\', $name, \">$nl\";
}
elsif(UNIVERSAL::isa($value, \'HASH\')) {
push AATTresult, $self->value_to_xml($value, $name, $indent);
}
else {
push AATTresult,
$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 AATT{$self->{_ancestors}} if(ref($ref));
return(join(\'\', AATTresult));
}
sub escape_value {
my($self, $data) = AATT_;
return \'\' unless(defined($data));
$data =~ s/&/&/sg;
$data =~ s/< /</sg;
$data =~ s/>/>/sg;
$data =~ s/\"/"/sg;
return($data);
}
sub hash_to_array {
my $self = shift;
my $parent = shift;
my $hashref = shift;
my $arrayref = [];
my($key, $value);
foreach $key (keys(%$hashref)) {
$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(AATT$arrayref, { $self->{opt}->{keyattr}->{$parent}->[0] => $key,
%$value });
}
else {
push(AATT$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
}
}
return($arrayref);
}
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 AATT{ $self->{lists} }, $self->{curlist};
push AATT{ $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 AATT$clist, 0 => $text;
}
}
sub end_element {
my $self = shift;
$self->{curlist} = pop AATT{ $self->{lists} };
}
sub end_document {
my $self = shift;
delete($self->{curlist});
delete($self->{lists});
my $tree = $self->{tree};
delete($self->{tree});
return($tree) if($self->{nocollapse});
if($self->{opt}->{keeproot}) {
$tree = $self->collapse({}, AATT$tree);
}
else {
$tree = $self->collapse(AATT{$tree->[1]});
}
if($self->{opt}->{datahandler}) {
return($self->{opt}->{datahandler}->($self, $tree));
}
return($tree);
}
*xml_in = \\&XMLin;
*xml_out = \\&XMLout;
1;
__END__
|
