#############################################################################
## Name: Data.pm
## Purpose: XML::Smart::Data - Generate XML data.
## Author: Graciliano M. P.
## Modified by: Harish Madabushi
## Created: 28/09/2003
## RCS-ID:
## Copyright: (c) 2003 Graciliano M. P.
## Licence: This program is free software; you can redistribute it and/or
## modify it under the same terms as Perl itself
#############################################################################
package XML::Smart::Data ;
use strict ;
use warnings ;
require Exporter ;
use XML::Smart::Entity qw(_add_basic_entity) ;
use XML::Smart::Shared qw( _unset_sig_warn _reset_sig_warn ) ;
our ($VERSION , @ISA) ;
$VERSION = '0.05' ;
@ISA = qw(Exporter) ;
our @EXPORT = qw(data) ;
our @EXPORT_OK = @EXPORT ;
########
# DATA #
########
sub data {
_unset_sig_warn() ;
my $this = shift ;
my ( %args ) = @_ ;
my $tree ;
if( $args{tree} ) {
$tree = $args{ tree } ;
} else {
$tree = $this->tree ;
}
{
my $addroot ;
if ( $args{root} || ref $tree ne 'HASH' ) { $addroot = 1 ;}
else {
my $ks = keys %$tree ;
my $n = 1 ;
if (ref $$tree{'/nodes'} eq 'HASH') { ++$n ;}
if (ref $$tree{'/order'} eq 'ARRAY') { ++$n ;}
#if (ref $$tree{'/nodes'} eq 'HASH') { ++$n if (keys %{$$tree{'/nodes'}}) ;}
#if (ref $$tree{'/order'} eq 'ARRAY') { ++$n if @{$$tree{'/order'}} ;}
if ($ks > $n) { $addroot = 1 ;}
else {
my $k = (keys %$tree)[0] ;
if (ref $$tree{$k} eq 'ARRAY' && $#{$$tree{$k}} > 0) {
my ($c,$ok) ;
foreach my $i ( @{$$tree{$k}} ) {
if ( $i && &is_valid_tree($i) ) { $c++ ; $ok = $i ;}
if ($c > 1) { $addroot = 1 ; last ;}
}
if (!$addroot && $ok) { $$tree{$k} = $ok ;}
}
elsif (ref $$tree{$k} =~ /^(?:HASH|)$/) {$addroot = 1 ;}
}
}
if ($addroot) {
my $root = $args{root} || 'root' ;
$tree = {$root => $tree} ;
}
}
if ( $args{lowtag} ) { $args{lowtag} = 1 ;}
if ( $args{upertag} ) { $args{lowtag} = 2 ;}
if ( $args{lowarg} ) { $args{lowarg} = 1 ;}
if ( $args{uperarg} ) { $args{lowarg} = 2 ;}
my ($data,$unicode) ;
{
my $parsed = {} ;
&_data( $args{decode}, \$data , $tree , '' , -1 , {} , $parsed , undef , undef , $args{noident} , $args{nospace} , $args{lowtag} , $args{lowarg} , $args{wild} , $args{sortall} ) ;
$data .= "\n" if !$args{nospace} ;
if ( &_is_unicode($data) ) { $unicode = 1 ;}
}
my $enc = 'iso-8859-1' ;
if ($unicode) { $enc = 'UTF-8' ;}
my $meta ;
if ( $args{meta} ) {
my @metas ;
if (ref($args{meta}) eq 'ARRAY') { @metas = @{$args{meta}} ;}
elsif (ref($args{meta}) eq 'HASH') { @metas = $args{meta} ;}
else { @metas = $args{meta} ;}
foreach my $metas_i ( @metas ) {
if (ref($metas_i) eq 'HASH') {
my $meta ;
foreach my $Key (sort keys %$metas_i ) {
$meta .= " $Key=" . &_add_quote($$metas_i{$Key}) ;
}
$metas_i = $meta ;
}
}
foreach my $meta ( @metas ) {
$meta =~ s/^[<\?\s*]//s ;
$meta =~ s/[\s\?>]*$//s ;
$meta =~ s/^meta\s+//s ;
$meta = "<?meta $meta ?>" ;
}
$meta = "\n" . join ("\n", @metas) ;
}
my $wild = $args{wild} ? ' [format: wild]' : '' ;
my $metagen = qq`\n<?meta name="GENERATOR" content="XML::Smart/$XML::Smart::VERSION$wild Perl/$] [$^O]" ?>` ;
if ( $args{nometagen} ) { $metagen = '' ;}
my $length ;
if ( $args{length} ) {
$length = ' length="' . (length($metagen) + length($meta) + length($data)) . '"' ;
}
my $xml = qq`<?xml version="1.0" encoding="$enc"$length ?>` ;
if ( $args{noheader} ) { $xml = '' ; $metagen = '' if $args{nometagen} eq '' ;}
my $dtd ;
if ( !$args{nodtd} && $$this->{DTD} ) {
$dtd = ref $$this->{DTD} ? $$this->{DTD}->CutDTD : $$this->{DTD} ;
$dtd =~ s/\s*$// ;
$dtd = "\n$dtd" if $dtd ne '' && !$args{nospace} ;
}
$data = $xml . $metagen . $meta . $dtd . $data ;
if ($xml eq '') { $data =~ s/^\s+//gs ;}
if (wantarray) {
_reset_sig_warn() ;
return($data , $unicode) ;
}
_reset_sig_warn() ;
return($data) ;
}
#################
# IS_VALID_TREE #
#################
sub is_valid_tree {
_unset_sig_warn() ;
my ( $tree ) = @_ ;
my $found ;
if (ref($tree) eq 'HASH') {
foreach my $Key (sort keys %$tree ) {
if ($Key eq '' || $Key eq '/order' || $Key eq '/nodes') { next ;}
if (ref($$tree{$Key})) { $found = &is_valid_tree($$tree{$Key}) ;}
elsif ($$tree{$Key} ne '') { $found = 1 ;}
if ($found) { last ;}
}
}
elsif (ref($tree) eq 'ARRAY') {
foreach my $value (@$tree) {
if (ref($value)) { $found = &is_valid_tree($value) ;}
elsif ($value ne '') { $found = 1 ;}
if ($found) { last ;}
}
}
elsif (ref($tree) eq 'SCALAR' && $$tree ne '') { $found = 1 ;}
_reset_sig_warn() ;
return $found ;
}
###############
# _IS_UNICODE #
###############
sub _is_unicode {
_unset_sig_warn() ;
if ($] >= 5.008001) {
if ( utf8::is_utf8($_[0])) {
_reset_sig_warn() ;
return 1 ;
}
}
elsif ($] >= 5.008) {
require Encode ;
if ( Encode::is_utf8($_[0])) {
_reset_sig_warn() ;
return 1 ;
}
}
elsif ( $] >= 5.007 ) {
_reset_sig_warn() ;
my $is = eval(q`
if ( $_[0] =~ /[\x{100}-\x{10FFFF}]/s) { return 1 ;}
return undef ;
`);
$@ = undef ;
return 1 if $is ;
}
else {
## No Perl internal support for UTF-8! ;-/
## Is better to handle as Latin1.
_reset_sig_warn() ;
return undef ;
}
_reset_sig_warn() ;
return undef ;
}
#########
# _DATA #
#########
sub _data {
_unset_sig_warn() ;
my ( $decode, $data , $tree , $tag , $level , $prev_tree , $parsed , $ar_i , $node_type , @stat ) = @_ ;
if (ref($tree) eq 'XML::Smart') { $tree = defined $$tree->{content} ? $$tree->{content} : $$tree->{point} ;}
if ( ref($tree) ) {
if ($$parsed{"$tree"}) {
_reset_sig_warn() ;
return ;
}
++$$parsed{"$tree"} ;
}
my $ident = "\n" ;
$ident .= ' ' x $level if !$stat[0] ;
if ($stat[1]) { $ident = '' ;}
$stat[1] -= 2 if $stat[1] > 1 ;
my $tag_org = $tag ;
$tag = $stat[4] ? $tag : &_check_tag($tag) ;
if ($stat[2] == 1) { $tag = "\L$tag\E" ;}
elsif ($stat[2] == 2) { $tag = "\U$tag\E" ;}
if (ref($tree) eq 'HASH') {
my ($args,$args_end,$tags,$cont,$stat_1) ;
my (@all_keys , %multi_keys) ;
if ( !$stat[5] && $tree->{'/order'} ) {
my %keys ;
foreach my $keys_i ( @{$tree->{'/order'}} ) {
if ( exists $$tree{$keys_i} && (!ref($$tree{$keys_i}) || ref($$tree{$keys_i}) eq 'HASH' || ref($$tree{$keys_i}) eq 'XML::Smart' || (ref($$tree{$keys_i}) eq 'ARRAY' && exists $$tree{$keys_i}[ $keys{$keys_i} ] ) ) ) {
push(@all_keys , $keys_i) ;
if ( ++$keys{$keys_i} == 2 && ref $$tree{$keys_i} eq 'ARRAY' ) {
my @val = map { ( $_ ne '' ? 1 : () ) } @{ $$tree{$keys_i} } ;
$multi_keys{$keys_i} = 1 if $#val > 0 ;
}
}
}
foreach my $keys_i ( sort keys %$tree ) {
if ( !$keys{$keys_i} && exists $$tree{$keys_i} ) { push(@all_keys , $keys_i) ;}
}
}
else { @all_keys = sort keys %$tree ;}
my %array_i ;
foreach my $Key ( @all_keys ) {
if ($Key eq '' || $Key eq '/order' || $Key eq '/nodes') { next ;}
if ( $Key eq '!--' && (!ref($$tree{$Key}) || ( ref($$tree{$Key}) eq 'HASH' && (keys %{$$tree{$Key}}) == 1 && (defined $$tree{$Key}{CONTENT} || defined $$tree{$Key}{content}) ) ) ) {
my $ct = $$tree{$Key} ;
if (ref $$tree{$Key}) { $ct = defined $$tree{$Key}{CONTENT} ? $$tree{$Key}{CONTENT} : $$tree{$Key}{content} ;} ;
if ( $ct ne '' ) { $tags .= "$ident<!--$ct-->" ;}
}
elsif (ref($$tree{$Key})) {
my $k = $$tree{$Key} ;
my $i ;
if (ref $k eq 'XML::Smart') {
$k = defined ${$$tree{$Key}}->{content} ? ${$$tree{$Key}}->{content} : ${$$tree{$Key}}->{point} ;
}
elsif ( ref $k eq 'ARRAY' && $multi_keys{$Key} ) {
$i = $array_i{$Key}++ if $#{$k} > 0 ;
}
$args .= &_data($decode, \$tags,$k,$Key, $level+1 , $tree , $parsed , $i , $$tree{'/nodes'}{$Key} , @stat) if $array_i{$Key} ne 'ok' ;
$array_i{$Key} = 'ok' if $i eq '' && ref $k eq 'ARRAY' ;
}
elsif ( $$tree{'/nodes'}{$Key} ) {
my $k = [$$tree{$Key}] ;
$args .= &_data($decode, \$tags,$k,$Key, $level+1 , $tree , $parsed , undef , $$tree{'/nodes'}{$Key} , @stat) ;
}
elsif (lc($Key) eq 'content') {
if ( tied($$tree{$Key}) && $$tree{$Key} =~ /\S/s ) {
$ident = '' ; $stat[1] += 2 ;
}
next if tied($$tree{$Key}) ;
if ( $$tree{$Key} ne '' ) {
my $p0 = length($tags) ;
$tags .= $$tree{$Key} ;
$cont = [$p0, length($tags) - $p0] ;
}
}
elsif ($Key =~ /^\/\.CONTENT\/\d+$/) { $tags .= $$tree{$Key} ;}
elsif ( $stat[4] && $$tree{$Key} eq '') { $args_end .= " $Key" ;}
else {
my $tp = _data_type($$tree{$Key}) ;
if ($tp == 1) {
my $k = $stat[4] ? $Key : &_check_key($Key) ;
if ($stat[3] == 1) { $k = "\L$Key\E" ;}
elsif ($stat[3] == 2) { $k = "\U$Key\E" ;}
$args .= " $k=" . &_add_quote($$tree{$Key}) ;
}
else {
my $k = $stat[4] ? $Key : &_check_key($Key) ;
if ($stat[2] == 1) { $k = "\L$Key\E" ;}
elsif ($stat[2] == 2) { $k = "\U$Key\E" ;}
if ($tp == 2) {
my $cont = $$tree{$Key} ; &_add_basic_entity($cont) ;
$tags .= qq`$ident<$k>$cont</$k>` ;
}
elsif ($tp == 3) { $tags .= qq`$ident<$k><![CDATA[$$tree{$Key}]]></$k>`;}
elsif ($tp == 4) {
require XML::Smart::Base64 ;
my $base64 = &XML::Smart::Base64::encode_base64($$tree{$Key}) ;
$base64 =~ s/\s$//s ;
$tags .= qq`$ident<$k dt:dt="binary.base64">$base64</$k>`;
}
}
}
} # foreach my $Key ( @all_keys ) { -- Contains if ($Key eq '' || $Key eq '/order' || $Key eq '/nodes') { next ;}
foreach my $Key ( keys %array_i ) {
if ( $array_i{$Key} ne 'ok' && $#{ $$tree{$Key} } >= $array_i{$Key} ) {
for my $i ( $array_i{$Key} .. $#{ $$tree{$Key} } ) {
$args .= &_data($decode, \$tags, $$tree{$Key} ,$Key, $level+1 , $tree , $parsed , $i , $$tree{'/nodes'}{$Key} , @stat) ;
}
}
}
if ( $cont ne '' ) {
my ( $po , $p1 ) = @$cont ;
my $cont = substr($tags , $po , $p1) ;
my $tp = _data_type($cont) ;
if ( $node_type =~ /^(\w+),(\d+),(\d*)$/ ) {
my ( $node_tp , $node_set ) = ($1,$2) ;
if ( !$node_set ) {
if ( $tp == 3 && $node_tp eq 'cdata' ) { $tp = 0 ;}
elsif ( $tp == 4 && $node_tp eq 'binary' ) { $tp = 0 ;}
}
else {
if ( $node_tp eq 'cdata' ) { $tp = 3 ;}
elsif ( $node_tp eq 'binary' ) { $tp = 4 ;}
}
}
if ( $tp == 3 ) { $cont = "<![CDATA[$cont]]>" ;}
elsif ( $tp == 4 ) {
require XML::Smart::Base64 ;
$cont = &XML::Smart::Base64::encode_base64($cont) ;
$cont =~ s/\s$//s ;
$args .= ' dt:dt="binary.base64"' ;
}
else { &_add_basic_entity($cont) ;}
my $pe = $po + $p1 ;
my $px = $pe ;
while( substr($tags , $px , 1) =~ /\s/ ) { ++$px ;}
if ( $px > $pe ) { substr($tags , $pe , $px-$pe) = '' ;}
substr($tags , $po , $p1) = $cont ;
}
# print STDERR "***$tag>> $args,$args_end,$tags,$cont,$stat_1 [@all_keys]\n" ;
if ($args_end ne '') {
$args .= $args_end ;
$args_end = undef ;
}
if (!@all_keys) {
$$data .= qq`$ident<$tag/>` if $tag ne '' ;
}
elsif ($args ne '' && $tags ne '') {
if( $args =~ /dt\:dt="binary.base64"/ and $decode ) {
$$data .= qq`$ident<$tag>` if $tag ne '' ;
require XML::Smart::Base64 ;
$$data .= &XML::Smart::Base64::decode_base64( $tags ) ;
} else {
$$data .= qq`$ident<$tag$args>` if $tag ne '' ;
$$data .= $tags ;
}
$$data .= $ident if !$cont ;
$$data .= qq`</$tag>` if $tag ne '' ;
}
elsif ($args ne '') {
$$data .= qq`$ident<$tag$args/>`;
}
elsif ($tags ne '') {
$$data .= qq`$ident<$tag>` if $tag ne '' ;
$$data .= $tags ;
$$data .= $ident if !$cont ;
$$data .= qq`</$tag>` if $tag ne '' ;
}
else {
$$data .= qq`$ident<$tag></$tag>` if $tag ne '' ;
}
}
elsif (ref($tree) eq 'ARRAY') {
my ($c,$v,$tags) ;
foreach my $value_i ( ($ar_i ne '' ? $$tree[$ar_i] : @$tree) ) {
my $value = $value_i ;
if (ref $value_i eq 'XML::Smart') { $value = $$value_i->{point} ;}
my $do_val = 1 ;
if ( $tag_org eq '!--' && ( !ref($value) || ( ref($value) eq 'HASH' && keys %{$value} == 1 && (defined $$value{CONTENT} || defined $$value{content}) ) ) ) {
$c++ ;
my $ct = $value ;
if (ref $value) { $ct = defined $$value{CONTENT} ? $$value{CONTENT} : $$value{content} ;} ;
$tags .= $ident . '<!--' . $ct . '-->' ;
$v = $ct if $c == 1 ;
$do_val = 0 ;
}
elsif (ref($value)) {
if (ref($value) eq 'HASH') {
$c = 2 ;
&_data($decode, \$tags,$value,$tag,$level, $tree , $parsed , undef , undef , @stat) ;
$do_val = 0 ;
}
elsif (ref($value) eq 'SCALAR') { $value = $$value ;}
elsif (ref($value) ne 'ARRAY') { $value = "$value" ;}
}
if ( $do_val && $value ne '') {
my $tp = _data_type($value) ;
if ( $node_type =~ /^(\w+),(\d+),(\d*)$/ ) {
my ( $node_tp , $node_set ) = ($1,$2) ;
if ( !$node_set ) {
if ( $tp == 3 && $node_tp eq 'cdata' ) { $tp = 0 ;}
elsif ( $tp == 4 && $node_tp eq 'binary' ) { $tp = 0 ;}
}
else {
if ( $node_tp eq 'cdata' ) { $tp = 3 ;}
elsif ( $node_tp eq 'binary' ) { $tp = 4 ;}
}
}
if ($tp <= 2) {
$c++ ;
my $cont = $value ; &_add_basic_entity($value) ;
&_add_basic_entity($cont) ;
$tags .= qq`$ident<$tag>$cont</$tag>`;
$v = $cont if $c == 1 ;
}
elsif ($tp == 3) {
$c++ ;
$tags .= qq`$ident<$tag><![CDATA[$value]]></$tag>`;
$v = $value if $c == 1 ;
}
elsif ($tp == 4) {
$c++ ;
require XML::Smart::Base64 ;
my $base64 = &XML::Smart::Base64::encode_base64($value) ;
$base64 =~ s/\s$//s ;
$tags .= qq`$ident<$tag dt:dt="binary.base64">$base64</$tag>`;
$v = $value if $c == 1 ;
}
}
}
if ( $ar_i eq '' && $c <= 1 && ! $$prev_tree{'/nodes'}{$tag}) {
my $k = $stat[4] ? $tag : &_check_key($tag) ;
if ($stat[3] == 1) { $k = "\L$k\E" ;}
elsif ($stat[3] == 2) { $k = "\U$k\E" ;}
delete $$parsed{"$tree"} if ref($tree) ;
my $return_val = " $k=" . &_add_quote($v) ;
_reset_sig_warn() ;
return $return_val ;
}
else { $$data .= $tags ;}
}
elsif (ref($tree) eq 'SCALAR') {
my $k = $stat[4] ? $tag : &_check_key($tag) ;
if ($stat[3] == 1) { $k = "\L$k\E" ;}
elsif ($stat[3] == 2) { $k = "\U$k\E" ;}
delete $$parsed{"$tree"} if ref($tree) ;
my $return_val = " $k=" . &_add_quote($$tree) ;
_reset_sig_warn() ;
return $return_val ;
}
elsif (ref($tree)) {
my $k = $stat[4] ? $tag : &_check_key($tag) ;
if ($stat[3] == 1) { $k = "\L$k\E" ;}
elsif ($stat[3] == 2) { $k = "\U$k\E" ;}
delete $$parsed{"$tree"} if ref($tree) ;
my $return_val = " $k=" . &_add_quote("$tree") ;
_reset_sig_warn() ;
return $return_val ;
}
else {
my $k = $stat[4] ? $tag : &_check_key($tag) ;
if ($stat[3] == 1) { $k = "\L$k\E" ;}
elsif ($stat[3] == 2) { $k = "\U$k\E" ;}
delete $$parsed{"$tree"} if ref($tree) ;
my $return_val = " $k=" . &_add_quote($tree) ;
_reset_sig_warn() ;
return $return_val ;
}
delete $$parsed{"$tree"} if ref($tree) ;
_reset_sig_warn() ;
return ;
}
##############
# _DATA_TYPE #
##############
## 4 binary
## 3 CDATA
## 2 content
## 1 value
sub _data_type { &XML::Smart::_data_type ;}
##############
# _CHECK_TAG #
##############
sub _check_tag { &_check_key ;}
##############
# _CHECK_KEY #
##############
sub _check_key {
_unset_sig_warn() ;
if ($_[0] =~ /(?:^[.:-]|[^\w\:\.\-])/s) {
my $k = $_[0] ;
$k =~ s/^[.:-]+//s ;
$k =~ s/[^\w\:\.\-]+/_/gs ;
return( $k ) ;
}
my $return_val = $_[0] ;
_reset_sig_warn() ;
return( $return_val ) ;
}
##############
# _ADD_QUOTE #
##############
sub _add_quote {
_unset_sig_warn() ;
my ($data) = @_ ;
$data =~ s/\\$/\\\\/s ;
&_add_basic_entity($data) ;
my $q1 = ($data =~ /"/s) ? 1 : undef ;
my $q2 = ($data =~ /'/s) ? 1 : undef ;
if (!$q1 && !$q2) {
_reset_sig_warn() ;
return( qq`"$data"` ) ;
}
if ($q1 && $q2) {
$data =~ s/"/"/gs ;
_reset_sig_warn() ;
return( qq`"$data"` ) ;
}
if ($q1) {
_reset_sig_warn() ;
return( qq`'$data'` ) ;
}
if ($q2) {
_reset_sig_warn() ;
return( qq`"$data"` ) ;
}
_reset_sig_warn() ;
return( qq`"$data"` ) ;
}
#######
# END #
#######
1;