File Coverage

blib/lib/XML/Smart.pm

Criterion	Covered	Total	%
statement	441	685	64.3
branch	200	334	59.8
condition	82	168	48.8
subroutine	40	73	54.7
pod	43	55	78.1
total	806	1315	61.2

#############################################################################
## Name:        Smart.pm
## Purpose:     XML::Smart
## Author:      Graciliano M. P.
## Modified by: Harish Madabushi
## Created:     10/05/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                                             ;

use 5.006                                                      ;

use strict                                                     ;
use warnings                                                   ;

use Carp                                                       ;

use Object::MultiType                                          ;

use XML::Smart::Shared qw( _unset_sig_warn _reset_sig_warn )   ;

use vars qw(@ISA)                                              ;
@ISA = qw(Object::MultiType)                                   ;

use XML::Smart::Tie                                            ;
use XML::Smart::Tree                                           ;


=head1 NAME

XML::Smart - A smart, easy and powerful way to access or create XML from fiels, data and URLs.

=head1 VERSION

Version 1.78

=cut

our $VERSION = '1.78' ;

=head1 SYNOPSIS

This module provides an easy way to access/create XML data. It's based on a HASH
tree created from the XML data, and enables dynamic access to it through the
standard Perl syntax for Hash and Array, without necessarily caring about which
you are working with. In other words, B
an Array at the same time>!

This module additionally provides special resources such as: search for nodes by
attribute, select an attribute value in each multiple node,  change the returned
format, and so on.

The module also automatically handles binary data (encoding/decoding to/from base64),
CDATA (like contents with ) and Unicode. It can be used to create XML files,
load XML from the Web ( just by using an URL as the file path ) and has an easy
way to send XML data through sockets - just adding the length of the data in
the  header.

You can use I with L, or with the 2 standard parsers of
XML::Smart:

=over 10

=item I

=item I.

=back

I can be used to load/parse wild/bad XML data, or HTML tags.

=head1 Tutorial and F.A.Q.

You can find some extra documents about I at:

=over 2

=item L - Tutorial and examples for XML::Smart.

=item L      - Frequently Asked Questions about XML::Smart.

=back

=cut

=head1 USAGE

  ## Create the object and load the file:
  my $XML = XML::Smart->new('file.xml') ;

  ## Force the use of the parser 'XML::Smart::Parser'.
  my $XML = XML::Smart->new('file.xml' , 'XML::Smart::Parser') ;

  ## Get from the web:
  my $XML = XML::Smart->new('http://www.perlmonks.org/index.pl?node_id=16046') ;

  ## Cut the root:
  $XML = $XML->cut_root ;

  ## Or change the root:
  $XML = $XML->{hosts} ;

  ## Get the address [0] of server [0]:
  my $srv0_addr0 = $XML->{server}[0]{address}[0] ;
  ## ...or...
  my $srv0_addr0 = $XML->{server}{address} ;

  ## Get the server where the attibute 'type' eq 'suse':
  my $server = $XML->{server}('type','eq','suse') ;

  ## Get the address again:
  my $addr1 = $server->{address}[1] ;
  ## ...or...
  my $addr1 = $XML->{server}('type','eq','suse'){address}[1] ;

  ## Get all the addresses of a server:
  my @addrs = @{$XML->{server}{address}} ;
  ## ...or...
  my @addrs = $XML->{server}{address}('@') ;

  ## Get a list of types of all the servers:
  my @types = $XML->{server}('[@]','type') ;

  ## Add a new server node:
  my $newsrv = {
  os      => 'Linux' ,
  type    => 'Mandrake' ,
  version => 8.9 ,
  address => [qw(192.168.3.201 192.168.3.202)]
  } ;

  push(@{$XML->{server}} , $newsrv) ;

  ## Get/rebuild the XML data:
  my $xmldata = $XML->data ;

  ## Save in some file:
  $XML->save('newfile.xml') ;

  ## Send through a socket:
  print $socket $XML->data(length => 1) ; ## show the 'length' in the XML header to the
                                          ## socket know the amount of data to read.

  __DATA__



      192.168.0.1
      192.168.0.2


      192.168.1.10
      192.168.1.20




=cut

###############
# AUTOLOADERS #
###############

## Lead to mem leak? ##

sub data {
    require XML::Smart::Data ;
    _unset_sig_warn() ;
    *data = \&XML::Smart::Data::data ;
    _reset_sig_warn() ;
    &XML::Smart::Data::data(@_) ;
}

sub apply_dtd {
    require XML::Smart::DTD ;
    _unset_sig_warn() ;
    *apply_dtd = \&XML::Smart::DTD::apply_dtd ;
    _reset_sig_warn() ;
    &XML::Smart::DTD::apply_dtd(@_) ;
}

sub xpath { _load_xpath() ; &XML::Smart::XPath::xpath(@_) ;}
sub XPath { _load_xpath() ; &XML::Smart::XPath::XPath(@_) ;}
sub xpath_pointer { _load_xpath() ; &XML::Smart::XPath::xpath_pointer(@_) ;}
sub XPath_pointer { _load_xpath() ; &XML::Smart::XPath::XPath_pointer(@_) ;}

sub _load_xpath {

    require XML::Smart::XPath ;
    _unset_sig_warn() ;
    *xpath = \&XML::Smart::XPath::xpath ;
    *XPath = \&XML::Smart::XPath::XPath ;
    *xpath_pointer = \&XML::Smart::XPath::xpath_pointer ;
    *XPath_pointer = \&XML::Smart::XPath::XPath_pointer ;
    *_load_xpath = sub {} ;
    _reset_sig_warn() ;

}

#################
# NO_XML_PARSER #
#################

sub NO_XML_PARSER {
    $XML::Smart::Tree::NO_XML_PARSER = !@_ ? 1 : ( $_[0] ? 1 : undef ) ;
}

#######
# NEW #
#######

sub new {

    my $class = shift ;
    my $file  = shift ;
    my $parser = ($_[0] and $_[0] !~ /^(?:uper|low|arg|on|no|use)\w+$/i) ? shift(@_) : '' ;

    my $this = Object::MultiType->new(
	boolsub   => \&boolean ,
	scalarsub => \&content ,
	tiearray  => 'XML::Smart::Tie::Array' ,
	tiehash   => 'XML::Smart::Tie::Hash' ,
	tieonuse  => 1 ,
	code      => \&find_arg ,
	) ;


    $$this->{ parser } = $parser ;

    $parser = &XML::Smart::Tree::load($parser) ;

    if ( !($file) or $file eq '') { $$this->{tree} = {} ;}
    else {
	eval {
	    $$this->{tree} = &XML::Smart::Tree::parse($file,$parser,@_) ;
	}; croak( $@ ) if( $@ );
    }

    $$this->{point} = $$this->{tree} ;
    bless($this,$class) ;

    return $this ;

}

#########
# CLONE #
#########

sub clone {

    my $saver = shift ;

    my ($pointer , $back , $array , $key , $i , $null_clone) ;

    if ($#_ == 0 && !ref $_[0]) {
	my $nullkey = shift ;
	$pointer = {} ;
	$back = {} ;
	$null_clone = 1 ;

	($i) = ( $nullkey =~ /(?:^|\/)\/\[(\d+)\]$/s );
	($key) = ( $nullkey =~ /(.*?)(?:\/\/\[\d+\])?$/s );
	if ($key =~ /^\/\[\d+\]$/) { $key = undef ;}
    }

    else {
	$pointer = shift ;
	$back = shift ;
	$array = shift ;
	$key = shift ;
	$i = shift ;
    }

    my $clone = Object::MultiType->new(
	boolsub   => \&boolean ,
	scalarsub => \&content ,
	tiearray  => 'XML::Smart::Tie::Array' ,
	tiehash   => 'XML::Smart::Tie::Hash' ,
	tieonuse  => 1 ,
	code      => \&find_arg ,
	) ;
    bless($clone,__PACKAGE__) ;

    if ( !$saver->is_saver ) { $saver = $$saver ;}

    if (!$back) {
	if (!$pointer) { $back = $saver->{back} ;}
	else { $back = $saver->{point} ;}
    }

    if (!$array && !$pointer) { $array = $saver->{array} ;}

    my @keyprev ;

    if (defined $key) { @keyprev = $key ;}
    elsif (defined $i) { @keyprev = "[$i]" ;}

    if (!defined $key) { $key = $saver->{key} ;}
    if (!defined $i) { $i = $saver->{i} ;}

    if (!$pointer) { $pointer = $saver->{point} ;}

    # my @call = caller ;
    # print STDERR "CLONE>> $key , $i >> @{$saver->{keyprev}} >> @_\n" ;


    $$clone->{tree} = $saver->{tree} ;
    $$clone->{point} = $pointer ;
    $$clone->{back} = $back ;
    $$clone->{array} = $array ;
    $$clone->{key} = $key ;
    $$clone->{i} = $i ;

    if ( @keyprev ) {
	$$clone->{keyprev} = ( $saver->{keyprev} ) ? [@{$saver->{keyprev}}]  : [] ;
	push(@{$$clone->{keyprev}} , @keyprev) ;
    }

    if (defined $_[0]) { $$clone->{content} = \$_[0] ;}

    if ( $null_clone || $saver->{null} ) {
	$$clone->{null} = 1 ;
	## $$clone->{self} = $clone ;
    }

    $$clone->{XPATH} = $saver->{XPATH} if $saver->{XPATH} ;

    return( $clone ) ;

}

###########
# BOOLEAN #
###########

sub boolean {

    my $this = shift ;

    if ( $this->null ) {
	return 0 ;
    } else {
	return 1 ;
    }

}

########
# NULL #
########

sub null {

    my $this = shift ;

    if( $$this->{null} ) {
	return 1 ;
    }

    if( (keys %{$$this->{tree}}) < 1 ) {
	return 1 ;
    }

    return ;

}

########
# BASE #
########

sub base {

    my $this = shift ;

    my $base = Object::MultiType->new(
	boolsub   => \&boolean ,
	scalarsub => \&content ,
	tiearray  => 'XML::Smart::Tie::Array' ,
	tiehash   => 'XML::Smart::Tie::Hash' ,
	tieonuse  => 1 ,
	code      => \&find_arg ,
	) ;

    bless($base,__PACKAGE__) ;

    $$base->{tree} = $this->tree ;
    $$base->{point} = $$base->{tree} ;

    return( $base ) ;

}

########
# BACK #
########

sub back {

    my $this = shift ;

    my @tree ;
    if( $$this->{keyprev} ) {
	@tree = @{$$this->{keyprev}} ;
    }

    if( !@tree ) {
	return $this ;
    }

    my $last = pop(@tree) ;
    my $i = 0 ;
    if( $last =~ /^\[(\d+)\]$/ ) {
	$i = $1 ;
	$last = pop(@tree) ;
    }

    my $back = $this->base ;

    foreach my $tree_i ( @tree ) {
	if ($tree_i =~ /^\[(\d+)\]$/) {
	    my $i = $1 ;
	    $back = $back->[$i] ;
	} else {
	    $back = $back->{$tree_i} ;
	}
    }

    if ( wantarray ) {
	return( $back , $last , $i ) ;
    }

    return( $back ) ;

}

########
# PATH #
########

sub path {

    my $this = shift ;
    my @tree = @{$$this->{keyprev}} ;

    my $path ;

    foreach my $tree_i ( @tree ) {
	$path .= '/' if $tree_i !~ /^\[\d+\]$/ ;
	$path .= $tree_i ;
    }

    return $path ;

}

#################
# PATH_AS_XPATH #
#################

sub path_as_xpath {

    my $this = shift ;
    my @tree = @{$$this->{keyprev}} ;

    my $path ;

    foreach my $tree_i ( @tree ) {
	if ( $tree_i =~ /^\[(\d+)\]$/ ) {
	    my $i = $1 + 1 ;
	    $path .= "[$i]" ;
	} else {
	    $path .= "/$tree_i" ;
	}
    }

    $path =~ s/\[1\]$// ;

    my $t = $this->is_node ;

    if ( !$this->is_node ) {
	$path =~ s/\/([^\/]+)$/\/\@$1/s ;
    }

    return $path ;

}

########
# ROOT #
########

sub root {

    my $this = shift ;

    my $root = ( $this->base->nodes_keys )[0] ;

    return $root ;

}

#######
# KEY #
#######

sub key {

    my $this = shift ;
    my $k = @{$$this->{keyprev}}[ $#{$$this->{keyprev}} ] ;
    if ($k =~ /^\[(\d+)\]$/) {
	$k = @{$$this->{keyprev}}[ $#{$$this->{keyprev}} -1 ] ;
    }

    return $k ;

}

#####
# I #
#####

sub i {

    my $this = shift ;
    my $i = $$this->{i} ;

    return $i ;
}

########
# COPY #
########

sub copy {

    my $this = shift ;

    my $data = $this->data( noheader => 1 ) ;
    my $copy = XML::Smart->new( $data, $$this->{ parser } ) ;


    if( $$this->{keyprev} ) {
	my @old_array = @{ $$this->{keyprev} } ;
	my @new_array = @old_array             ;
	$$copy->{keyprev} = \@new_array        ;
    }

    my ( $back , $key , $i ) = $copy->back ;

    _unset_sig_warn() ;
    if( $key ne '' ) {
	$copy = $back->{$key} ;
	$copy = $back->[$i] if $i ;
    }
    _reset_sig_warn() ;

    return $copy ;

}

##############
# _COPY_HASH #
##############

sub _copy_hash {

    my ( $ref ) = @_ ;
    my $copy         ;

    if( ref $ref eq 'HASH' ) {
	$copy = {} ;
	foreach my $Key ( keys %$ref ) {
	    if( ref $$ref{$Key} ) {
		$$copy{$Key} =&_copy_hash($$ref{$Key}) ;
	    } else {
		$$copy{$Key} = $$ref{$Key} ;
	    }
	}
    } elsif( ref $ref eq 'ARRAY' ) {
	$copy = [] ;
	foreach my $i ( @$ref ) {
	    if( ref $i ) {
		push( @$copy, &_copy_hash($i) ) ;
	    } else {
		push( @$copy, $i ) ;
	    }
	}
    } elsif( ref $ref eq 'SCALAR' ) {
	my $copy = $$ref ;
	return( \$copy ) ;
    } else {
	return( {} ) ;
    }

    return( $copy ) ;

}

###########
# TREE_OK #
###########

sub tree_ok {
    return _tree_ok_parse( &tree ) ;
}

##############
# POINTER_OK #
##############

sub pointer_ok {
    return _tree_ok_parse( &pointer ) ;
}

sub tree_pointer_ok {
    &pointer_ok ;
}

##################
# _TREE_OK_PARSE #
##################

sub _tree_ok_parse {

    my ( $ref ) = @_ ;
    my $copy         ;

    if( ref $ref eq 'HASH' ) {
	$copy = {} ;
	foreach my $Key ( keys %$ref ) {
	    next if $Key eq '/order' || $Key eq '/nodes' || $Key =~ /\/\.CONTENT\// ;
	    if( ref $$ref{$Key} ) {
		$$copy{$Key} =&_tree_ok_parse($$ref{$Key}) ;
	    } else {
		$$copy{$Key} = $$ref{$Key} ;
	    }
	}
    } elsif( ref $ref eq 'ARRAY' ) {
	$copy = [] ;
	foreach my $i ( @$ref ) {
	    if( ref $i ) {
		push( @$copy, &_tree_ok_parse($i) ) ;
	    } else {
		push( @$copy, $i                  ) ;
	    }
	}
    } elsif( ref $ref eq 'SCALAR' ) {
	my $copy = $$ref ;
	return( \$copy ) ;
    } else {
	return( {} ) ;
    }

    return( $copy ) ;

}

########
# TREE #
########

sub tree {

    my $hash_to_return = ${$_[0]}->{tree} ;

    return ( $hash_to_return ) ;

}

sub tree_pointer {
    &pointer ;
}

#############
# DUMP_TREE #
#############

sub dump_tree {
    require Data::Dumper ;
    local $Data::Dumper::Sortkeys = 1 ;
    return Data::Dumper::Dumper( &tree ) ;
}

sub dump_tree_ok {
    require Data::Dumper ;
    local $Data::Dumper::Sortkeys = 1 ;
    return Data::Dumper::Dumper( &tree_ok ) ;
}


################
# DUMP_POINTER #
################

sub dump_pointer {
    require Data::Dumper ;
    local $Data::Dumper::Sortkeys = 1 ;
    return Data::Dumper::Dumper( &pointer ) ;
}

sub dump_pointer_ok {
    require Data::Dumper ;
    local $Data::Dumper::Sortkeys = 1 ;
    return Data::Dumper::Dumper( &pointer_ok ) ;
}


sub dump_tree_pointer {
    &dump_pointer ;
}

sub dump_tree_pointer_ok {
    &dump_pointer_ok ;
}

###########
# POINTER #
###########

sub pointer {

    my $hash_to_return ;

    if ( ${$_[0]}->{content} ) {
	$hash_to_return = ${${$_[0]}->{content}} ;
    } else {
	$hash_to_return = ${$_[0]}->{point}      ;
    }

    return ( $hash_to_return ) ;
}

############
# CUT_ROOT #
############

sub cut_root {

    my $this = shift ;

    my @nodes = $this->nodes_keys ;

    if( $#nodes > 0 ) {
	return $this ;
    }

    my $root = $nodes[0] ;
    return( $this->{$root} ) ;

}

###########
# IS_NODE #
###########

sub is_node {

    my $this = shift ;

    return if $this->null ;

    my $key  = $this->key  ;
    my $back = $this->back ;

    return 1 if( $back->{'/nodes'}{$key} || $back->{$key}->nodes_keys ) ;
    return undef ;

}

########
# ARGS #
########

sub args {

    my $this = shift ;

    return () if $this->null ;

    my @args ;

    my $nodes   = $this->back->{'/nodes'} ;
    my $pointer = $$this->{point}         ;

    foreach my $Key ( keys %$this ) {

	next if( $$nodes{$Key} ) ;

	if(
	    ( !ref $$pointer{ $Key} ) ||
	    ( ref( $$pointer{ $Key} ) eq 'HASH') ||
	    ( ref( $$pointer{ $Key} ) eq 'ARRAY' && $#{$$pointer{$Key}} == 0 )
	    ) {

	    push(@args , $Key) ;

	}
    }

    return @args ;
}

###############
# ARGS_VALUES #
###############

sub args_values {

    my $this = shift ;

    return () if $this->null ;

    my @args = $this->args ;

    my @values ;

    foreach my $args_i ( @args ) {
	push( @values, $this->{$args_i} ) ;
    }

    return @values ;

}

#########
# NODES #
#########

sub nodes {

    my $this = shift ;

    return () if $this->null ;

    my $nodes   = $this->{'/nodes'}->pointer ;
    my $pointer = $$this->{point}            ;

    my @nodes ;

    foreach my $Key ( keys %$this ) {

	if(
	    $$nodes{$Key} ||
	    (ref($$pointer{$Key}) eq 'HASH') ||
	    (ref($$pointer{$Key}) eq 'ARRAY' && $#{$$pointer{$Key}} > 0)
	    ) {

	    if( ref($$pointer{$Key}) eq 'ARRAY' ) {
		my $n = $#{$$pointer{$Key}} ;
		for my $i (0..$n) {
		    push( @nodes, $this->{$Key}[$i] ) ;
		}
	    } else {
		push( @nodes, $this->{$Key}[0] ) ;
	    }
	}
    }

    return @nodes ;

}

##############
# NODES_KEYS #
##############

sub nodes_keys {

    my $this = shift ;

    return () if $this->null ;


    my $nodes   = $this->{'/nodes'}->pointer ;
    my $pointer = $$this->{point}            ;

    my @nodes ;
    foreach my $Key ( keys %$this ) {
	if(
	    $$nodes{$Key} ||
	    (ref($$pointer{$Key}) eq 'HASH') ||
	    (ref($$pointer{$Key}) eq 'ARRAY' && $#{$$pointer{$Key}} > 0)
	    ) {
	    push(@nodes , $Key) ;
	}
    }

    return @nodes ;
}

############
# SET_NODE #
############

sub set_node {

    my $this     = shift ;
    my ( $bool ) = @_    ;

    if( !@_ ) {
	$bool = 1 ;
    }

    my $key  = $this->key  ;
    my $back = $this->back ;

    $back->{'/nodes'} = {} if( $back->{'/nodes'}->null ) ;
    my $nodes = $back->{'/nodes'}->pointer ;

    if( $bool ) {

	if( $$nodes{$key} && $$nodes{$key} =~ /^(\w+,\d+),(\d*)/ ) {
	    $$nodes{$key} = "$1,1" ;
	} else {
	    $$nodes{$key} = 1      ;
	}

	if ( !$this->{CONTENT} ) {
	    my $content = $this->content ;
	    $this->{CONTENT} = $content if $content ne '' ;
	}

    } else {

	delete $$nodes{$key} ;
	my @keys = keys %$this ;
	if( $#keys == 0 && $keys[0] eq 'CONTENT' ) {
	    my $content = ( !$this->{CONTENT}->null ) ? $this->{CONTENT}('.') : $this->content ;
	    $this->back->pointer->{$key} = $content ;
	}
    }

}

###########
# SET_TAG #
###########

sub set_tag {
    &set_node ;
}

#############
# SET_ORDER #
#############

sub set_order {
    my $this    = shift           ;
    my $pointer = $$this->{point} ;
    @{$$pointer{'/order'}} = @_   ;
}

sub order {
    my $this = shift ;
    my $pointer = $$this->{point} ;
    return @{$$pointer{'/order'}} if defined $$pointer{'/order'} && ref($$pointer{'/order'}) eq 'ARRAY' ;
    return() ;
}

#############
# SET_CDATA #
#############

sub set_node_type {

    my $this = shift ;

    my ( $type, $bool ) = @_ ;
    if( $#_ < 1 ) {
	$bool = 1 ;
    }

    my $key  = $this->key  ;
    my $back = $this->back ;

    $back->{'/nodes'} = {} if( $back->{'/nodes'}->null );
    my $nodes = $back->{'/nodes'}->pointer ;

    if( $bool ) {

	if( $$nodes{$key} && $$nodes{$key} =~ /^\w+,\d+,(\d*)/ ) {
	    my $val = $1                   ;
	    $$nodes{$key} = "$type,1,$val" ;
	} else {
	    my $existing_node_data = ( $$nodes{$key} ) ? $$nodes{$key} : "" ;
	    $$nodes{$key} = "$type,1," . $existing_node_data ;
	}

	if( !$this->{CONTENT} ) {
	    my $content = $this->content ;
	    $this->{CONTENT} = $content if $content ne '' ;
	}

    } else {

	if( !$$nodes{$key} ) {
	    my $tp = _data_type( $back->{$key} ) ;
	    if ( $tp > 2 ) { $$nodes{$key} = "$type,0," ;}
	} elsif( $$nodes{$key} eq '1' ) {
	    $$nodes{$key} = "$type,0,1" ;
	} elsif( $$nodes{$key} =~ /^\w+,\d+,1/ ) {
	    $$nodes{$key} = "$type,0,1" ;
	} elsif( $$nodes{$key} =~ /^\w+,\d+,0?$/ ) {

	    delete $$nodes{$key} ;
	    my @keys = keys %$this ;

	    if( $#keys == 0 && $keys[0] eq 'CONTENT') {
		my $content = $this->{CONTENT}('.') ;
		$this->back->pointer->{$key} = $content ;
	    }

	}
    }

}

#############
# SET_CDATA #
#############

sub set_cdata {
    my $this = shift ;
    $this->set_node_type('cdata',@_) ;
}

##############
# SET_BINARY #
##############

sub set_binary {
    my $this = shift ;
    $this->set_node_type('binary',@_) ;
}

#################
# SET_AUTO_NODE #
#################

sub set_auto_node {

    my $this = shift ;

    my $key  = $this->key  ;
    my $back = $this->back ;

    $back->{'/nodes'} = {} if( $back->{'/nodes'}->null );
    my $nodes = $back->{'/nodes'}->pointer ;

    if( !$$nodes{$key} || $$nodes{$key} eq '1' ) {
	# Do nothing. ;
    } elsif( $$nodes{$key} =~ /^\w+,\d+,1/   ) {
	$$nodes{$key} = 1 ;
    } elsif( $$nodes{$key} =~ /^\w+,\d+,0?$/ ) {

	delete $$nodes{$key} ;
	my @keys = keys %$this ;

	if( $#keys == 0 && $keys[0] eq 'CONTENT') {
	    my $content = $this->{CONTENT}('.') ;
	    $this->back->pointer->{$key} = $content ;
	}

    }

}

############
# SET_AUTO #
############

sub set_auto {

    my $this = shift ;

    my $key  = $this->key  ;
    my $back = $this->back ;

    $back->{'/nodes'} = {} if $back->{'/nodes'}->null ;
    my $nodes = $back->{'/nodes'}->pointer ;

    delete $$nodes{$key} ;
    my @keys = keys %$this ;
    if( $#keys == 0 && $keys[0] eq 'CONTENT') {
	my $content = $this->{CONTENT}('.') ;
	$this->back->pointer->{$key} = $content ;
    }

}

##############
# _DATA_TYPE #
##############

## 4 binary
## 3 CDATA
## 2 content
## 1 value

sub _data_type {


    my $data = shift ;

    # TODO: 0x80, 0x81, 0x8d, 0x8f, 0x90, 0xa0
    my @bin_data = (
	0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8e, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
	0x97, 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9e, 0x9f, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xaa,
	0xab, 0xac, 0xad, 0xae, 0xaf, 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc,
	0xbd, 0xbe, 0xbf, 0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, 0xc8, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce,
	0xcf, 0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf, 0xe0,
	0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, 0xf0, 0xf1, 0xf2,
	0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, 0x20,
	);


    my $bin_string = join( '', ( map( pack("H*", $_), @bin_data ) ) ) ;

    return 4 if( $data && (
		     $data =~ /[^\w\d\s!"#\$\%&'\(\)\*\+,\-\.\/:;<=>\?\@\[\\\]\^\`\{\|}~~$bin_string]/s
		     or
		     $data =~ /(\240|\351|\361|\363|\341|\374|\340|\350|\366|\343|\355|\366|\344|\372|\364|\324|\301|\342)/s
		 )
	) ;
    return 3 if( $data && $data =~ /<.*?>/s    ) ;
    return 2 if( $data && $data =~ /[\r\n\t]/s ) ;
    return 1                                     ;
}

#######
# RET #
#######

sub ret {

    my $this = shift ;
    my $type = shift ;

    if ($type =~ /^\s*\s*$/si ) {
	return $this->data_pointer( noheader => 1 ) ;
    }

    my @ret ;
    $type =~ s/[^<\$\@\%\.k]//gs ;

    if ($type =~ /^
	$type =~ s/^<+// ;

	my ($back , $key , $i) = $this->back ;

	if(     $type =~ /\$$/  ) {
	    @ret = $back->{$key}[$i]->content ;
	} elsif( $type =~ /\@$/ ) {

	    @ret = @{$back} ;

	    foreach my $ret_i ( @ret ) {
		$ret_i = $ret_i->{$key}[$i] ;
	    }

	} elsif( $type =~ /\%$/ ) {
	    @ret = %{$back->{$key}[$i]} ;
	}
    } else {

	if( $this->null ) {
	    return ;
	}

	if    ($type =~ /\$$/) { @ret = $this->content ; }
	elsif ($type =~ /\@$/) { @ret = @{$this}       ; }
	elsif ($type =~ /\%$/) { @ret = %{$this}       ; }
	elsif ($type =~ /\.$/) { @ret = $this->pointer ; }
	elsif ($type =~ /[\@\%]k$/) {

	    my @keys = keys %{$this} ;

	    foreach my $key ( @keys ) {
		my $n = $#{ $this->{$key} } ;
		if ($n > 0) {
		    my @multi = ($key) x ($n+1) ;
		    push(@ret , @multi) ;
		} else {
		    push(@ret , $key) ;
		}
	    }

	}
    }

    if( $type =~ /^\$./ ) {
	foreach my $ret_i ( @ret ) {
	    if(ref($ret_i) eq 'XML::Smart') {
		$ret_i = $ret_i->content ;
	    }
	}
    }


    if( wantarray ) {
	return( @ret ) ;
    }
    return $ret[0] ;

}

########
# FIND #
########

sub find {
    &find_arg
}

############
# FIND_ARG #
############

sub find_arg {

    my $this = shift ;
    if( $#_ == 0 && ref($_[0]) ne 'ARRAY' ) {
	return $this->ret(@_) ;
    }

    if( $#_ == 1 && $_[0] eq '[@]'        ) {
	my $arg = $_[1] ;
	return $this->{$arg}('<@') ;
    }

    my @search ;

    for( my $i = 0; $i <= $#_ ; ++$i ) {
	if( ref($_[$i]) eq 'ARRAY' ) {
	    push(@search , $_[$i]) ;
	} elsif( ref($_[$i]) ne 'ARRAY' && ref($_[$i+1]) ne 'ARRAY' && ref($_[$i+2]) ne 'ARRAY' ) {
	    push(@search , [$_[$i] , $_[$i+1] , $_[$i+2]]) ;
	    $i += 2 ;
	}
    }

    #use Data::Dumper ; print Dumper(\@search);
    #print "*** @search\n" ;

    if ( !@search ) {
	return ;
    }

    my $key = $$this->{key} ;

    my @hashes ;

    if( ref($$this->{array}) ) {
	push( @hashes, @{$$this->{array}} ) ;
    } else {

	push( @hashes, $$this->{point}    ) ;

	if( ref $$this->{point} eq 'HASH' ) {
	    foreach my $k ( sort keys %{$$this->{point}} ) {
		push( @hashes, [$k,$$this->{point}{$k}]) if( ref($$this->{point}{$k}) eq 'HASH' ) ;
	    }
	}
    }

    my $i = -1 ;
    my (@hash , @i) ;
    my $notwant = !wantarray ;

    foreach my $hash_i ( @hashes ) {

	foreach my $search_i ( @search ) {

	    my ($name , $type , $value) = @{$search_i} ;
	    $type =~ s/\s//gs ;

	    $i++ ;
	    my $hash ;
	    if (ref $hash_i eq 'ARRAY') { $hash = @$hash_i[1] ;}
	    else { $hash = $hash_i ;}

	    my $data ;
	    if ($name =~ /^content$/i) { $name = 'CONTENT' ;}
	    $data = ref($hash) eq 'HASH' ? $$hash{$name} : $hash ;
	    $data = $$data{CONTENT} if ref($data) eq 'HASH' ;

	    _unset_sig_warn() ;
	    if    ($type eq 'eq'  && $data eq $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq 'ne'  && $data ne $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '=='  && $data == $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '!='  && $data != $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '<='  && $data <= $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '>='  && $data >= $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '<'   && $data <  $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '>'   && $data >  $value)     { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '=~'  && $data =~ /$value/s)  { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '=~i' && $data =~ /$value/is) { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '!~'  && $data !~ /$value/s)  { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    elsif ($type eq '!~i' && $data !~ /$value/is) { push(@hash,$hash_i) ; push(@i,$i) ; last ;}
	    _reset_sig_warn() ;
	}

	if( $notwant && @hash ) {
	    last ;
	}
    }

    my $back = $$this->{back} ;

    #print "FIND>> @{$$this->{keyprev}} >> $i\n" ;

    if( @hash ) {
	if( $notwant ) {
	    my ($k,$hash) = (undef) ;
	    if (ref $hash[0] eq 'ARRAY') { ($k,$hash) = @{$hash[0]} ;}
	    else { $hash = $hash[0] ;}
	    return &XML::Smart::clone($this,$hash,$back,undef, $k,$i[0]) ;
	}
	else {
	    my $c = -1 ;
	    foreach my $hash_i ( @hash ) {
		$c++ ;
		my ($k,$hash) = (undef) ;
		if (ref $hash_i eq 'ARRAY') { ($k,$hash) = @{$hash_i} ;}
		else { $hash = $hash_i ;}
		$hash_i = &XML::Smart::clone($this,$hash,$back,undef, $k,$i[$c]) ;
	    }
	    return( @hash ) ;
	}
    }

    if (wantarray) { return() ;}
    return &XML::Smart::clone($this,'') ;
}

###########
# CONTENT #
###########
sub content {

    my $this = shift ;
    my $set_i = $#_ > 0 ? shift : undef ;

    if ( $this->null ) {
	&XML::Smart::Tie::_generate_nulltree( $$this ) ;
    }

    ##use Data::Dumper; print Dumper($$this) ;

    my $content_to_return ;
    if ( defined $$this->{content} and ( !defined( $content_to_return ) ) ) {
	if (@_) { ${$$this->{content}} = $_[0] ;}
	$content_to_return = ${$$this->{content}} ;
    }

    my $key = 'CONTENT' ;
    my $i = $$this->{i} ;

    if( ( ref($$this->{point}) eq 'ARRAY' ) and ( !defined( $content_to_return ) ) ) {
	$content_to_return = $this->[0]->content($set_i,@_) ;
    }

    if( ( ref($$this->{point}) ne 'HASH' ) and ( !defined( $content_to_return ) ) ) {
	$content_to_return = '' ;
    }

    if( ( !exists $$this->{point}{$key} ) and ( !defined( $content_to_return ) ) ) {
	if( @_ ) {
	    $content_to_return = $$this->{point}{$key} = $_[0] ;
	} else {
	    $content_to_return = '' ;
	}
    }

    if( defined( $content_to_return ) ) {
	return $content_to_return ;
    }


    if( ( ref($$this->{point}{$key}) eq 'ARRAY' ) and ( !defined( $content_to_return ) ) ) {

	if($i eq '') {
	    $i = 0 ;
	}

	if(@_) {
	    $$this->{point}{$key}[$i] = $_[0] ;
	}

	$content_to_return = $$this->{point}{$key}[$i] ;

    } elsif( ( exists $$this->{point}{$key} ) and ( !defined( $content_to_return ) ) ) {

	if ( @_ ) {
	    if ( my $tie = tied($$this->{point}{$key}) ) {
		$tie->STORE($set_i , $_[0]) ;
	    } else {
		$$this->{point}{$key} = $_[0] ;
	    }
	}

	if( wantarray && ( my $tie = tied($$this->{point}{$key} ) ) ) {
	    my @tmp = $tie->FETCH(1)   ;
	    $content_to_return = \@tmp ;
	} else {
	    $content_to_return = $$this->{point}{$key} ;
	}

    }

    unless( defined( $content_to_return ) ) {
	$content_to_return = '' ;
    }

    if( wantarray ) {
	return @{ $content_to_return } ;
    } else {
	return $content_to_return ;
    }

}

########
# SAVE #
########

sub save {

    my $this = shift ;
    my $file = shift ;

    if(-d $file || (-e $file && !-w $file)) {
	return ;
    }

    my( $data, $unicode ) = $this->data(@_) ;

    my $fh ;
    open($fh,">$file") ;
    binmode($fh) if $unicode ;
    print $fh $data ;
    close($fh) ;

    return( 1 ) ;

}

################
# DATA_POINTER #
################

sub data_pointer {

    my $this = shift ;
    if( $this->null ) {
	return ;
    }

    my( $point, $key ) ;

    if ( exists $$this->{content} ) {
	my $back = $this->back ;
	my $root = $back->key ;
	my $k = $this->key ;
	$point = $back->pointer ;
	$point = $$point{ $this->key } ;
	$point = {$root => {$k => $point} } ;
    } else {
	$point = $$this->{point} ;
	$key = $this->key ;
    }

    $this->data( tree => $point , root => $key , @_) ;

}

###########
# DESTROY #
###########

sub DESTROY {

    my $this = shift ;

    if( $$this->{ DEV_DEBUG } ) {
	require Devel::Cycle ;
	my $circ_ref = 0     ;
	my $tmp = Devel::Cycle::find_cycle(
	    $this,
	    sub {
		my $path = shift;
		foreach (@$path) {
		    my ($type,$index,$ref,$value) = @$_;
		    $circ_ref = 1 ;

		}

	    });

	if( $circ_ref ) {
	    $this->ANNIHILATE() ;
	    my $tmp = Devel::Cycle::find_cycle(
		$this,
		sub {
		    print STDERR "Circular reference found while destroying object - AFTER ANNIHILATE\n" ;
		});
	}
    }

    $$this->clean if( $this && $$this ) ; # In case object was messed with ( bug 62091 )


}

sub ANNIHILATE {

    my $this = shift ;
    my $base = shift ;

    if( ref $$this->{ point } eq 'HASH' ) {
	my %clean ;
	$$this->{ point } = \%clean ;
    } else {
	$this->{ point }->ANNIHILATE( ) ;
    }

    if( ref $$this->{ tree } eq 'HASH' ) {
	my %clean ;
	$$this->{ tree } = \%clean ;
    } else {
      $this->{ tree }->ANNIHILATE( ) ;
    }


    if( ref $$this->{ back } eq 'HASH' ) {
	my %clean ;
	$$this->{ back } = \%clean ;
    } else {
	$this->{ back }->ANNIHILATE( ) ;
    }

    if( $$this->{ XPATH } ) { # and ( ref $$this->{ XPATH } eq 'XML::XPath' ) ) {
	my $xpath = $$this->{ XPATH } ;
	$$xpath->cleanup() ;
	my $context = $$xpath->{ _context } ;
	my $context_ref = ref $context ;
	if( $context_ref =~ /XML\:\:XPath\:\:Node\:\:/ ) {
	    _xml_xpath_clean( $context ) ;
	}
    }

    $$this->DESTROY();

    return 1 ;

}


sub _xml_xpath_clean {

    my $path = shift ;

    $path->dispose() ;
    # Data::Structure::Util::unbless( $path ) ;

    return ;

}

###################
# STORABLE_FREEZE #
###################

sub STORABLE_freeze {
    my $this = shift ;
    return($this , [$$this->{tree} , $$this->{pointer}])  ;
}

#################
# STORABLE_THAW #
#################

sub STORABLE_thaw {
    my $this = shift ;
    $$this->{tree} = $_[1]->[0] ;
    $$this->{pointer} = $_[1]->[1] ;
    return ;
}

#######
# END #
#######

1;

__END__