File Coverage

lib/Data/Deep.pm

Criterion	Covered	Total	%
statement	528	592	89.1
branch	285	358	79.6
condition	105	166	63.2
subroutine	28	32	87.5
pod	15	23	65.2
total	961	1171	82.0

 ######################################################################
#############################################################################
package Data::Deep;
##############################################################################
  # Ultimate tool for Perl data manipulation
  ############################################################################
 ### Deep.pm
  ############################################################################
  # Copyright (c) 2005 Matthieu Damerose. All rights reserved.
  # This program is free software; you can redistribute it and/or
  # modify it under the same terms as Perl itself.
  ############################################################################
###
##
#
#


=head1 NAME

Data::Deep - Complexe Data Structure analysis and manipulation

=head1 SYNOPSIS

use Data::Deep;

$dom1=[ \{'toto' => 12}, 33,  {o=>5,d=>12}, 'titi' ];

$dom2=[ \{'toto' => 12, E=>3},{d=>12,o=>5}, 'titi' ];

my @patch = compare($dom1, $dom2);

use Data::Deep qw(:DEFAULT :convert :config);

o_complex(1);        # deeper analysis results

print join("\n", domPatch2TEXT( @patch ) );

@patch = (
 'add(@0$,@0$%E)=3','remove(@1,)=33','move(@2,@1)=','move(@3,@2)='
);

$dom2 = applyPatch($dom1,@patch);

@list_found = search($dom1, ['@',1])

@list_found = search($dom1, patternText2Dom('@1'))



=head1 DESCRIPTION

Data::Deep provides search, path, compare and applyPatch functions which may operate on complex Perl Data Structure
for introspection, usage and manipulation
(ref, hash or array, array of hash, blessed object and siple scalar).
Package, Filehandles and functions are partially supported (type and location is considered).
Loop circular references are also considered as a $t1 variable and partially supported.


=head2 path definition

path expression identify the current element node location in a complex Perl data structure.
pattern used in function search is used to match a part of this path.

Path is composed internally of an array of following elements :

   ('%', '') to match a hash table at  value
   ('@', ) to match an array at specified index value
   ('*', '') to match a global reference
   ('|', '') to match a blessed module reference

   ('$') to match a reference
   ('&') to match a code reference
   ('$loop') to match a loop reference (circular reference)

   ('=' ) to match the leaf node

In text mode a keyname may be defined by entering an hash-ref of keys in o_key()
then '/keyname' will appears in the path text results or could be provided
to convert function textPatch2dom() and patternText2dom()


Modifier  can be placed in the path with types to checks :

EX:

   ?%  : match with hash-table content (any key match)
   ?@  : match with an array content (any index match)
   ?=  : any value
   ?*  : any glob type
   ?$  : any reference
   ?=%@      : any value, hash-table or array
   ?%@*|$&=  : everything

Evaluation function :
   sub{... test with $_ ... } will be executed to match the node
   EX: sub { /\d{2,}/ } match numbers of minimal size of two

Patch is a directional operation to apply difference between two nodes resulting from compare($a, $b)
Patch allow the $a complex perl data structure to be changed to $b using applyPatch($a,@patch)

Each Patch operation is composed of :
   - an action :
        'add' for addition of an element from source to destination
        'remove' is the suppression from source to destination
        'move' if possible the move of a value or Perl Dom
        'change' describe the modification of a value
        'erase' is managed internally for array cleanup when using 'move'
   - a source path on which the value is taken from
   - a destination path on which is applied the change (most of the time same as source)

Three patch formats can be use :
   - dom : interaction with search, path, compare, ApplyPatch
   - text : programmer facilities to use a single scalar for a patch operation
   - ihm : a small readble IHM text aim for output only

Convert function may operation the change between this formats.


   DOM  : dom patch hash-ref sample

        EX: my $patch1 =
                     { action=>'change',
                       path_orig=>['@0','$','%a'],
                       path_dest=>['@0','$','%a'],
                       val_orig=>"toto",
                       val_dest=>"tata"
                     };

   TEXT : text output mode patch could be :

          add(,)=
          remove(,)=
          change(,)=/=>
          move(,)


=head2 Important note :

* search() and path() functions use paths in "dom" format :

      DOM (simple array of elements described above)
            EX: ['@',1,'%','r','=',432]

* applyPath() can use TEXT or DOM patch format in input.

* compare() produce "dom" patch format in output.


All function prefer the use of dom (internal format) then no convertion is done.
Output (user point of view) is text or ihm.

format patches dom  can be converted to TEXT : domPatch2TEXT
format patches text can be converted to DOM  : textPatch2DOM
format patches dom  can be converted to IHM  : domPatch2IHM

See conversion function

=cut


##############################################################################
# General version and rules
##############################################################################
use 5.004;
$VERSION = '0.12';
#$| = 1;

##############################################################################
# Module dep
##############################################################################

use Carp;
use strict;
no warnings;
no integer;
no strict 'refs';


use overload; require Exporter; our @ISA = qw(Exporter);


our @DEFAULT =
  qw(
     travel
     visitor_patch
     visitor_dump
     visitor_perl_dump
     search
     compare
     path
     applyPatch
     __d
    );

our @EXPORT = @DEFAULT;


our @CONFIG =
  qw(
     o_debug
     o_follow_ref
     o_complex
     o_key
    );

our @CONVERT =
  qw(
      patternText2Dom
      patternDom2Text
      textPatch2DOM
      domPatch2TEXT
      domPatch2IHM
    );

our @EXPORT_OK = (@DEFAULT,
	      @CONFIG,
	      @CONVERT
	     );


our %EXPORT_TAGS=(
	      convert=>[@CONVERT],
	      config=>[@CONFIG]
	     );
##############################################################################
#/````````````````````````````````````````````````````````````````````````````\


my $CONSOLE_LINE=78;

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


=head2 Options Methods

=over 4

=item I()

configure nodes to skip (in search or compare)
without parameter will return those nodes

=cut


sub zap {
  @_ and $Data::Deep::CFG->{zap}=shift()
    or return $Data::Deep::CFG->{zap};
}


 #############################################################################
### OPTIONS DECLARATION
##############################################################################
 # Declare option  : _opt_dcl 'o_flg'
 # Read the option :           o_flg()
 # Set the option  :           o_flg(1)
 ############################################################################

our $CFG = {};

my $__opt_dcl = sub { my $name = shift();
		      my $proto = shift() || '$';

		      eval 'sub '.$name."(;$proto) {"
			  .' @_ and $Data::Deep::CFG->{'.$name.'}=shift()
                               or return $Data::Deep::CFG->{'.$name.'} }';
		      $@ and die '__bool_opt_dcl('.$name.') : '.$@;
		  };
 ############################################################################

=item I([])

debug mode :
   1: set debug mode on
   0: set debug mode off
   undef : return debug mode

=cut

$__opt_dcl->('o_debug');

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

=item I([])

follow mode :
   1: follow every reference (default)
   0: do not enter into any reference
   undef: return if reference are followed

=cut

$__opt_dcl->('o_follow_ref');

o_follow_ref(1);


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

=item I([])

complex mode is used for intelligency complex (EX: elements move in an array)
   1: complex mode used in search() & compare()
   0: simple analysis (no complex search)
   undef: return if reference are followed

=cut

$__opt_dcl->('o_complex');


##############################################################################
sub debug {
##############################################################################
  o_debug() or return;

  # B.S./WIN : no output using STDERR
  sub out__ { (($^O=~/win/i)?print @_:print SDTERR @_) }

  my $l;
  foreach $l(@_) {
    (ref $l)
      and out__ "\n".__d($l)
	or do {
	  out__$l;
	  if (length($l)>$CONSOLE_LINE) { out__ "\n" }
	  else { out__ ' ' }
	}
      }
  out__ "\n"
}


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub  __d {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
  my $res = join('', travel(shift(), \&visitor_perl_dump));
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  $res =~ s/
	     ([\000-\037]|[\177-\377])
	   /sprintf("\\%o", ord ($1))/egx;

  return $res;
}

##############################################################################
###############################################################################
###############################################################################
# PRIVATE FX
###############################################################################
###############################################################################


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
my $matchPath = sub {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
  my @pattern=@{shift()};  # to match
  my @where=@_;    # current path
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  # warn 'matchPath('.join(' ',@where).' , '.join(' ',@pattern).')';


  my $ok;
  # warn 'matchPath:LongAlgo( '.join(' ',@pattern).', '.join(' ',@where).' )';
  my $i = 0;
 PATH:while ($i<=$#where) {

    my $j = 0;
    my $sav_i = $i;

  PATTERN: while ($i<=$#where) {

      ### CURRENT PATH
      my $t_where = $where[$i++]; # TYPE

      ## PATTERN
      my $t_patt = $pattern[$j++]; # TYPE

      if ($t_patt eq '/') {
        die 'internal matchPath('.join('',@pattern).') : key usage is only in textual format (use Text and convertion patternText2Dom)';
      }

      #print "$t_where =~ $t_patt : ";

      (index($t_patt,$t_where)==-1) and last PATTERN; # type where should be found in the pattern

      if ($t_where eq '&') { }
      elsif ($t_where eq '$') { }
      elsif ($t_where eq '=' or
	     $t_where eq '%' or
	     $t_where eq '@' or
	     $t_where eq '*' or
	     $t_where eq '|'
	    ) {

	my $v_where = $where[$i++];

	unless (substr($t_patt,0,1) eq '?') {
#print 'v';

	  my $v_patt = $pattern[$j++];

	  if (ref($v_patt) eq 'CODE') { # regexp or complexe val
            local ($_) = ($v_where);
	    $v_patt->($_) or last PATTERN
	  }
	  elsif (ref($v_patt) and (__d($v_patt) ne __d($v_where))) {
	    last PATTERN;
	  }
	  elsif (!defined($v_where) and defined($v_patt)) {
	    # print '!';
	    last PATTERN;
	  }
	  elsif (defined($v_where) and !defined($v_patt)) {
	    # print '!';
	    last PATTERN;
	  }
	  elsif (defined($v_where) and defined($v_patt) and $v_patt ne $v_where) {
	    # print '!';
	    last PATTERN;
	  }
	}
      }
      else {
#print '#';
	($i-1==$#where)
	  or
	    die 'Error in matched expression "'.join('',@where).'" not supported char type "'.$t_where.'".';
      }
#print '.';
      if ($j-1==$#pattern and $i-1==$#where) {
	# warn "#found($i,$j)";
	return $sav_i;
      }

    }# PATTERN:

    # next time
    ($j>1) and $i = $sav_i+1;

  }# WHERE:

  #print "\n";
  return undef;
};

##############################################################################
# KEY DCL :

sub o_key {
  @_ and $CFG->{o_key}=shift()
    or return $CFG->{o_key};
}

=item I()

key is a search pattern for simplifying search or compare.
or a group of pattern for best identification of nodes.

hash of key path:


EX:
         key(
		CRC => {regexp=>['%','crc32'],
			eval=>'{crc32}',
			priority=>1
		       },
		SZ  => {regexp=>['%','sz'),
			eval=>'{sz}',
			priority=>2
		       }
             )


regexp   : path to search in the dom
eval     : is the perl way to match the node
priority : on the same node two ambigues keys are prioritized
depth    : how many upper node to return from the current match node

=back

=cut




##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
my $patchDOM = sub($$$;$$) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
  my $action = shift;
  my $p1= shift();
  my $p2= shift();
  my $v1 = shift();
  my $v2 = shift();
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  my $dom = {};
  $dom->{action} = $action;
  $dom->{path_orig} = $p1;
  $dom->{path_dest} = $p2;
  $dom->{val_orig}  = $v1;
  $dom->{val_dest}  = $v2;

  return $dom;
};


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
my $path2eval__ = sub {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
  my $first_eval = shift();
  my $deepness = shift();  # [ 0.. N ] return N from root
                           # [-N..-1]  return N stage from leaves
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{

  my $evaled = $first_eval;

  my $dbg_head = __PACKAGE__."::path2eval__(".join(',',@_).") : ";
  debug $dbg_head;
  my $max=$#_;

  @_ or return $evaled;

  if (defined $deepness and $deepness<=0) { # start from the end
    while ($deepness++<0 and $max>=0) {
      $_[$max-1] =~ /^[\@%\*\|\/=]$/ and $max-=2
	or
      $_[$max] =~ /^[\$\&]$/    and $max--;
    }
    ($max==0) and return $evaled; # upper as root

    debug "\n negative depth $deepness: -> remaining path(".join(',',@_[0..$max]).")\n";
    $deepness=undef;
  }
  my $deref='->';

  my $i=0;
  while($i<=$max) {
    $_ = $_[$i++];

    if ($_ eq '$') {
      $evaled = '${'.$evaled.'}';
      $deref = '->';
    }
    elsif ($_ eq '%') {
      $evaled .= $deref."{'".$_[$i++]."'}";
      $deref='';
    }
    elsif ($_ eq '@') {
      $evaled .= $deref.'['.$_[$i++].']';
      $deref='';
    }
    elsif ($_ eq '|') {
      $i++;
    }
    elsif ($_ eq '*') {
      $i++;
      my $suiv = $_[$i] or next;
      if ($suiv eq '%') {
	$evaled = '*{'.$evaled.'}{HASH}';
	$deref = '->';
      }
      elsif ($suiv eq '@'){
	$evaled = '*{'.$evaled.'}{ARRAY}';
	$deref = '->';
      }
      elsif ($suiv eq '$' or $suiv eq '='){
	$evaled = '*{'.$evaled.'}{SCALAR}';
	$deref = '->';
      }
    }
    elsif ($_ eq '/') { # KEY->{eval}
      my $keyname = $_[$i++];
      my $THEKEY  = $CFG->{o_key}{$keyname};
      my $ev = $THEKEY->{eval} or die $dbg_head.'bad eval code for '.$keyname;
      $evaled .= $deref.$ev;
      $deref='';
    }
    elsif ($_ eq '&') {
      $evaled = $evaled.'->()';
    }
    elsif ($_ eq '=') {
      ($i==$#_) or die $dbg_head.'bad path format : value waited in path after "="';

      if ($_[$i]=~/^\d+$/) {
	$evaled = 'int('.$evaled.'=='.$_[$i++].')'
      }
      else {
	$evaled = 'int('.$evaled.' eq \''.$_[$i++].'\')'
      }

      $deref='';
    }
    else {
      die $dbg_head.'bad path format : Type '.$_.' not supported.'
    }

    if (defined($deepness)) {  # >0 start from root
      #print "\n positive depth $deepness:";
      last if (--$deepness==0);
    }
  }
  debug "-> $evaled #\n";
  return $evaled;
};

my %loop_ref=();
##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub loop_det($;@) {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{

  my $r = shift();
  ref($r) or return 0;

  $r = $r.' ';

  if (exists($loop_ref{$r})) {
    debug "loop_det => LOOP".join('',@_) ;

    return 1;
  }

  $loop_ref{$r}=1;
  return 0;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# PUBLIC FX
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~




=head2 Operation Methods

=over 4

=cut


#############################################################
sub visitor_patch {
#                  Visitor which create patch for dom creation
#############################################################
    my $node = shift();
    my $depth = shift;
    my $open = shift;
    my @cur_path = @_;

    my $path = join('',@cur_path);

# warn $depth.($open==1?' > ':(defined($open)?' < ':'   ')).join('',@cur_path).' : '.ref($node);

    my $ref = ref($node);
    if ($ref) {
      if (!defined $open ) {
	($_[-1] eq '$loop') and return 'loop('.$path.','.$path.')=';
	($ref eq 'CODE') and return 'add('.$path.','.$path.')=sub{}';
	#($ref eq 'REF') and return 'add('.$path.','.$path.')={}';
	($ref eq 'GLOB') and return 'new '.$_[-1].'()';
      }
      elsif ($open ==1 ) {
	($ref eq 'ARRAY') and return 'add('.$path.','.$path.')=[]';
	($ref eq 'HASH') and return 'add('.$path.','.$path.')={}';
	return ;
      }
      elsif ($open ==0 ) {
	#($ref eq 'ARRAY') and return ']';
	#($ref eq 'HASH') and return '}';
	return;
      }

    }

    defined($node) and $node = "'$node'" or $node = 'undef';


    pop(@cur_path);
    pop(@cur_path);
    $path = join('',@cur_path);
    pop(@cur_path);
    pop(@cur_path);

    ($_[-2] eq '=') and return 'add('.join('',@cur_path).','.$path.')='.$node;


    return;

    # get the source code => How ?
#   (ref($node) eq 'CODE') and return $dump.'CODE';#(&$node());
 #   return $dump.ref($node);

}


#############################################################
sub visitor_perl_dump {
#                  Visitor to dump Perl structure
#############################################################
    my $node = shift();
    my $depth = shift;
    my $open = shift;
    my @cur_path = @_;

    my $path = @cur_path;

    my $ref = ref($node);

    my ($realpack, $realtype, $id) =
      (overload::StrVal($node) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

    # warn $depth.($open==1?' > ':(defined($open)?' < ':'   ')).join('',@cur_path).' : '.ref($node)." ($realpack/$realtype/$id)";


    if ($ref) {
      if (!defined $open ) {
	($realpack and $realtype and $id) and $ref = $realtype;

	($ref eq 'REF' or $ref eq 'SCALAR') and return '\\';

	($ref eq 'CODE') and return 'sub { "DUMMY" }';

	if ($_[-1] eq '$loop') {
	  return '$t1';
	}

	if ($ref eq 'HASH' and $_[-2] eq '%') {
	  my @keys = sort {$a cmp $b} keys(%$node);
	  my $is_first = ($_[-1] eq $keys[0]);

	  $is_first
	    and
	      return '\''.$_[-1].'\'=>';

	  return ',\''.$_[-1].'\'=>';
	}
	($ref eq 'ARRAY' and $_[-2] eq '@' and $_[-1] != 0) and return ',';
	return;
      }
      elsif ($open ==1 ) {
	($ref eq 'ARRAY') and return '[';
	($ref eq 'HASH') and return '{';

	($realtype eq 'ARRAY') and return 'bless([';
	($realtype eq 'HASH') and return 'bless({';
      }
      elsif ($open ==0 ) {
	($ref eq 'ARRAY') and return ']';
	($ref eq 'HASH') and return '}';

	($realtype eq 'ARRAY') and return "] , '$ref')";
	($realtype eq 'HASH') and return "} , '$ref')";

      }
    }

    (defined($node)) or return 'undef';

    if ($_[-2] eq '=') {
      $node=~s/\'/\\\'/g;
      ($node=~/^\d+$/) and return $node;
      return '\''.$node.'\'';
    }

    return;

  }


#############################################################
sub visitor_dump {
#                  Visitor to dump Perl structure
#############################################################
    my $node = shift();
    my $depth = shift;
    my $open = shift;
    my @cur_path = @_;

    my $path = join('',@cur_path);

    my ($realpack, $realtype, $id) =
      (overload::StrVal($node) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

    return $depth.($open==1?' > ':(defined($open)?' < ':'   ')).join('',@cur_path).' : '.ref($node); #." ( $realpack/$realtype/$id)";
  }


#############################################################
# IDEA : sub visitor_search {
# IDEA : searching visitor to replace search
#############################################################
#    my $node = shift();
#    my $depth = shift;
#    my $open = shift;
#    my @cur_path = @_;

#    if (defined $matchPath->($pattern, @cur_path)) {
#	    defined($nb_occ) and (--$nb_occ<1) and die 'STOP';

#            return $node;
#    }
#}


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub travel($;@) {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{

  my $where=shift();
  my $visitor = shift() || \&visitor_patch;
  my $depth = shift()||0;
  my @path = @_;


=over 4

=item I( [,])

travel make the visitor function to travel through each node of the

       complexe perl data structure to travel into
   ()

Return a list path where the  argument match with the
   corresponding node in the  tree data type

I

   travel( {ky=>['l','r','t',124],r=>2}

   returns ( [ '%', 'ky', '@' , 3 , '=' , 124 ] )

=cut

#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
  if (@path) {
    debug "travel( dom=",@path, ' is ',ref($where),")";
    #debug "return ".($arr && ' ARRAY ' || 'SCALAR');
  }
  else {
    %loop_ref=();
  }

  #

  sub __appendVisitorResult {
    my $is_array = shift();
    my @list;

    foreach (@_) {
      if (defined $_) {
	$is_array or return $_;
	push(@list, $_);
      }
    }
    return @list;
  }

  my ($k,$res);
  my @res;

  #}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  my $ref_type = ref $where;


  ######################################## !!!!! Modules type resolution
#  if (index($ref_type,'::')!=-1) {
  my ($realpack, $realtype, $id) =
    (overload::StrVal(scalar($where)) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

  if ($realpack and $realtype and $id) {
    push @path,'|',$ref_type;

    my $y = undef;
    if ($realtype eq 'SCALAR') {
      $y=$$where;
    }
    elsif ($realtype eq 'HASH') {
      $y=\%$where
    }
    elsif ($realtype eq 'ARRAY') {
      $y=\@$where
    }
    else {
      #die $realtype.' : '.$where;
    }

    #debug ref($y)." = $realpack -> real $realtype, $id";

    $where=$y;
    $ref_type = $realtype;
  }


  ######################################## !!!!! Loop detection
  my @p;

  if (loop_det($where)) {

    return __appendVisitorResult(wantarray(), @res,
				 &$visitor($where, $depth, undef , (@path, '$loop')));

  }
  else {
    ######################################## !!!!! SCALAR TRAVEL
    if (!$ref_type) {

      return __appendVisitorResult(wantarray(),
				   @res,
				   &$visitor($where, $depth , undef, (@path, '=', $where)));

    }
    ######################################## !!!!! HASH TRAVEL
    elsif ($ref_type eq 'HASH')
      {

	@res = __appendVisitorResult(wantarray(),
				     @res,
				     &$visitor($where, $depth, 1, @path));

	my $k;
	foreach $k (sort {$a cmp $b} keys(%{ $where })) {
	  @p = (@path, '%', $k);

	  @res = __appendVisitorResult(wantarray(),
				       @res,
				       &$visitor($where, $depth, undef, @p)
				      );

	  @res = __appendVisitorResult(
				       wantarray(),
				       @res,
				       travel($where->{$k},$visitor,$depth+1, @p)
				      );
	}

	return __appendVisitorResult( wantarray(),
				      @res,
				      &$visitor($where, $depth, 0, @path)
				    );

      }
    ######################################## !!!!! ARRAY TRAVEL
    elsif ($ref_type eq 'ARRAY')
      {
        $res = &$visitor($where, $depth, 1, @path);

	@res = __appendVisitorResult( wantarray(), @res, $res );

	for my $i (0..$#{ $where }) {
	  #print "\narray  $i (".$where->[$i].','.join('.',@p).")\n" if (join('_',@p)=~ /\@_1_\%_g_/);
	  @p = (@path, '@', $i);

	  @res = __appendVisitorResult(wantarray(),
				       @res,
				       &$visitor($where, $depth, undef, @p)
				      );

	  @res = __appendVisitorResult(
				       wantarray(),
				       @res,
				       travel($where->[$i],$visitor,$depth+1, @p)
				      );

	}

	return __appendVisitorResult( wantarray(),
				      @res,
				      &$visitor($where, $depth, 0, @path)
				    );

      }
    ######################################## !!!!! REFERENCE TRAVEL
    elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR')
      {
	@p = (@path, "\$");

	@res = __appendVisitorResult( wantarray(),
				      @res,
				      &$visitor($where, $depth, undef,  @p )
				    );

	return __appendVisitorResult( wantarray(),
				      @res,
				      travel( ${ $where }, $visitor, $depth+1, @p )
				    );
      }
    else { # others types
      ######################################## !!!!! CODE TRAVEL
      if ($ref_type eq 'CODE') {
	@p = (@path, '&');
      }
      ######################################## !!!!! GLOB TRAVEL
      elsif ($ref_type eq 'GLOB') {
	my $name=$$where;
	$name=~s/b^\*//;
	@p = (@path, '*', $name);
      }
      ######################################## !!!!! MODULE TRAVEL
      else {
	#die $ref_type;
      }

      ######################################## !!!!! GLOB TRAVEL
      # cf IO::Handle or Symbol::gensym()

      if ($p[-2] eq '*') { # GLOB
	for $k (qw(SCALAR ARRAY HASH)) {
	  my $gval = *$where{$k};
	  defined($gval) or next;
	  next if ($k eq "SCALAR" && ! defined $$gval);  # always there

	  return __appendVisitorResult( wantarray(),
					@res,
					travel($gval, $visitor, $depth+1, undef, @p)
				      );
	}
      }

      return __appendVisitorResult(
				   wantarray(),
				   @res,
				   &$visitor($where, $depth, undef, @p )
				  );
    }
  }

  return ();
}



my %circular_ref;
##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub search($$;$@) {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
  my $where = shift();
  my $pattern = shift();
  my $nb_occ = shift();
  my @path=@_;

#  warn "search for #$nb_occ (",join('',@{$pattern}),")";


=item I(,  [,])

search the  into

         is a complexe perl data structure to search into
      is an array of type description to match
     optional argument to limit the number of results
                  if undef all results are returned
		  if 1 first one is returned

Return a list path where the  argument match with the
    corresponding node in the  tree data type

EX:
    search( {ky=>['l','r','t',124],r=>2}
            ['?@','=',124])

      Returns ( [ '%', 'ky', '@' , 3 , '=' , 124 ] )


    search( [5,2,3,{r=>3,h=>5},4,\{r=>4},{r=>5}],
            ['%','r'], 2 )

      Returns (['@',3,'%','r'],['@',5,'$','%','r'])


    search( [5,2,3,{r=>3},4,\3],
            ['?$@%','=',sub {$_ == 3 }],
            2;

      Returns (['@',2,'=',3], ['@',3,'%','r','=',3])

=cut

#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
  # warn "search($where / ref=".ref($where).','.$nb_occ.' ,'.join('',@path).")";

  @path or %loop_ref=();

  (defined($nb_occ) and ($nb_occ<1)) and return ();

  my $ref_type = ref $where;

  my @found;
  my $next = undef;
  my @p;

  ######################################## !!!!! Modules type resolution
  if ($ref_type) {

    #if (index($where,'::')!=-1) {  ## !!!!! MODULE SEARCH

    my ($realpack, $realtype, $id) =
      (overload::StrVal($where) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

    if ($realpack and $realtype and $id) {
      push @path, ('|', $ref_type);

      $ref_type = $realtype;

      #warn "$ref_type -> ($realpack, $realtype, $id )";
    }


    ######################################## !!!!! Loop detection

    if (loop_det($where)) {
      @p = (@path, '$loop');
    }
    ######################################## HASH Search
    elsif ($ref_type eq 'HASH') {
      my $k;
      foreach $k (sort {$a cmp $b} keys(%{ $where })) {
	@p = (@path, '%', $k);

	if (defined $matchPath->($pattern, @p)) {
	  push @found,[@p];
	  defined($nb_occ) and (--$nb_occ<1) and last;
	}
	else {
	  my @res = search($where->{$k}, $pattern, $nb_occ, @p);
	  @res and push @found,@res;
	}
      }
      return @found;
    }
    ######################################## HASH Search
    elsif ($ref_type eq 'ARRAY')
      {
	for my $i (0..$#{ $where }) {
	  @p = (@path, '@', $i);

	  if (defined $matchPath->($pattern, @p)) {
	    push @found,[@p];
	    defined($nb_occ) and (--$nb_occ<1) and last;
	  }
	  else {
	    my @res = search($where->[$i], $pattern, $nb_occ, @p);
	    @res and push @found,@res;
	  }
	}
	return @found;
      }
    ######################################## REF Search
    elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
      @p = (@path, '$');
      $next = ${ $where };
    }
    ######################################## CODE Search
    elsif ($ref_type eq 'CODE') {
      @p = (@path, '&');
    }
    ######################################## GLOB Search
    elsif ($ref_type eq 'GLOB') {
      my $name = $$where;
      $name=~s/^\*//;
      @p = (@path, '*',$name);
      if (defined *$where{SCALAR} and defined(${*$where{SCALAR}})) {
	$next = *$where{SCALAR};
      }
      elsif (defined *$where{ARRAY}) {
	$next = *$where{ARRAY};
      }
      elsif (defined *$where{HASH}) {
	$next = *$where{HASH};
      }
    }
  }
  ######################################
  else { ## !!!!! SCALAR Search
    @p = (@path, '=', $where);
  }
  ######################################

  if (defined $matchPath->($pattern, @p)) {
    push @found,[@p];
    defined($nb_occ) and --$nb_occ;
  }

  if ((defined($next))) {
    my @res = search($next, $pattern, $nb_occ, @p);

    @res and push @found,@res;
  }

  return @found;
}


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub path($$;$) {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
  my $dom = shift();
  my @paths = @{shift()};
  my $father_nb = shift() or 0;


=item I(,  [,])

gives a list of nodes pointed by
    is the complex perl data structure
    is the array reference of paths
    is the depth level to return from tree
       start counting from the top
      - start counting from the leaf
      0 return the leaf or check the leaf with '=' or '&' types):
             * if code give the return of execution
             * scalar will check the value

Return a list of nodes reference to the

EX:

    $eq_3 = path([5,{a=>3,b=>sub {return 'test'}}],
                  ['@1%a'])

    $eq_3 = path([5,{a=>3,b=>sub {return 'test'}}],
                  '@1%a','@1%b')


    @nodes = path([5,{a=>3,b=>sub {return 'test'}}],
                   ['@1%b&'], # or [['@',1,'%','b','&']]

                   0  # return ('test')
                      # -1 or 2 return ( sub { "DUMMY" } )
		      # -2 or 1 get the hash table
		      # -3 get the root tree
                   )]);

    @nodes = path([5,{a=>3,b=>sub {return 'test'}}],
                   ['@1%a'], # or [['@',1,'%','b','&']]

                   0  # return 3
                      # -1 or 2 get the hash table
		      # -2 or 1 get the root tree
                   )]);


=cut

#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}


  debug "path( \$dom, $#paths patch, $father_nb)";

  my @nodes;

  foreach my $node (@paths) {
    (ref($node) eq 'ARRAY') or die 'path() : pattern "'.$node.'" should be a Dom pattern ("Dom" internal array, perhaps use patternText2dom)';

    my @path = @{$node};

    # perl evaluation of the dom path
    my $e = $path2eval__->('$dom', $father_nb, @path);

    my $r = eval $e;
    debug $dom;
    debug $e.' evaluated to '.__d($r);
    die __FILE__.' : path() '.$e.' : '.$@ if ($@);
    push @nodes,$r
  }
  return shift @nodes unless (wantarray());
  return @nodes;
}

##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub compare {
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{

  # ############ ret : 0 if equal / 1 else
  my $d1 = shift();
  my $d2 = shift();

  my (@p1,@p2,$do_resolv_patch);
  if (@_) {
    @p1 = @{$_[0]};
    @p2 = @{$_[1]};
  }
  else {
    %loop_ref=();
    # equiv TEST on each function call: if ($CFG->{o_complex} and ($#a1==-1 and $#a2==-1)) {
    $CFG->{o_complex} and $do_resolv_patch=1;
  }

=item I(, )

compare nodes from origine to destination
nodes are complex perl data structure

Return a list of  (empty if node structures are equals)

EX:

   compare(
           [{r=>new Data::Dumper([5],ui=>54},4],
           [{r=>new Data::Dumper([5,2],ui=>52},4]
          )

    return ({ action=>'add',
              ...
            },
            { action=>'change',
              ...
            },
             ...
          )

=cut


#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}



  ###############################################################################
  sub searchSuffix__{
    my @a1=@{shift()};
    my @a2=@{shift()};
    my @patch=@{shift()};

    my @common;
    while (@a1 and @a2) {
      $_= pop(@a1);
      ($_ eq pop(@a2)) and unshift @common,$_ or return @common
    }
    return @common
  }
  ###############################################################################

  sub resolve_patch {
    my @patch = @_;
    my ($p1,$p2);

    foreach $p1 (@patch) {
      foreach $p2 (@patch) {

	if ($p1->{action} eq 'remove' and
	    $p2->{action} eq 'add' and
	    (__d($p1->{val_orig}) eq __d($p2->{val_dest}))) {

	  #my @com = searchSuffix__($p1->{path_orig}, $p2->{path_dest}, \@patch);
	  #@com or next;
	  #grep({$_ eq '&'}  @com) or next;
	  push @patch,
	    compare($p1->{val_orig},
		    $p2->{val_dest},
		    [@{$p1->{path_orig}}],
		    [@{$p2->{path_dest}}]
		   );

	  $p1->{action}='move';
	  $p1->{val_orig}= $p1->{val_dest}= undef;
	  $p1->{path_dest}= $p2->{path_dest};
	  $p2->{action}='erase';
	}
      }
    }

    my $o = 0;
    while ($o<=$#patch) {
      ($patch[$o]->{action} eq 'erase') and splice(@patch,$o,1) and next;
      $o++
    }

    return @patch
  }

  ###############################################################################
  #warn "\nComparing ORIG(".join(@p1,'=',ref($d1)||$d1).") <> DEST(".join('.',@p2,'=',ref($d2)||$d2).")\n";

  # ############ ret : 0 if equal / 1 else
  my @msg=();

  ######################################## !!!!! Type resolution
  my $ref_type = ref $d1;

  if ($ref_type) {

    ($ref_type ne ref($d2))
      and
	return ( $patchDOM->('change', \@p1,\@p2, $d1,$d2) );

    #if (index($ref_type,'::')!=-1) {

    my ($realpack, $realtype, $id) =
      (overload::StrVal($d1) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

    if ($realpack and $realtype and $id) {
      my ($realpack2, $realtype2, $id2) =
	(overload::StrVal($d2) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);

      ($realtype ne $realtype2)
	and
	  push @msg, $patchDOM->('change', \@p1 ,\@p2 , $realtype ,$realtype2);

      push @p1, '|',$ref_type;
      push @p2, '|',$ref_type;

      debug "$ref_type -> ($realpack, $realtype, $id : $ref_type)";

      $ref_type = $realtype;
    }
  }

  ######################################## !!!!! SCALAR COMPARE
  if (!$ref_type)
    {
      (defined($d1) and $d1 ne $d2) and return ($patchDOM->('change', \@p1,\@p2, $d1,$d2) );
      (!defined($d1) and defined($d2)) and return ($patchDOM->('change', \@p1,\@p2, $d1,$d2) );
      return ();
    }
  ######################################## !!!!! HASH COMPARE
  elsif ($ref_type eq 'HASH')
    {
      my (%seen,$k);

      foreach $k (sort {$a cmp $b}
		  keys(%{ $d1 }))
	{
	  $seen{$k}=1;

	  if (exists $d2->{$k}) {

	    loop_det($d1->{$k},@p1) and next;

	    push @msg,
	      compare( $d1->{$k},
		       $d2->{$k},
		       [ @p1, '%',$k ],
		       [ @p2, '%',$k ],
		     );
	  } else {
	    push @msg,$patchDOM->('remove', [ @p1, '%', $k ] ,\@p2 , $d1->{$k} ,undef)
	  }

	}#foreach($d1)

      foreach $k (sort {$a cmp $b} keys(%{ $d2 })) {
	next if exists $seen{$k};

	my $v = $d2->{$k};
	push @msg,$patchDOM->('add', \@p1, [ @p2, '%', $k ], undef, $v)
      }

      $do_resolv_patch or return @msg;
      return resolve_patch(@msg);
    }
  elsif ($ref_type eq 'ARRAY')
    {
      ######################################## !!!!! ARRAY COMPARE (not complex mode)

      unless ($CFG->{o_complex}) {

	my $min = $#{$d1};
	$min = $#{$d2} if ($#{$d2}<$min); # min ($#{$d1},$#{$d2})

	my $i;
	foreach $i (0..$min) {

	  loop_det($d1->[$i], @p1)
	    and
	      next;

	  push @msg,
	    compare( $d1->[$i], $d2->[$i], [@p1, '@',$i], [@p2, '@',$i]);
	}

	foreach $i ($min+1..$#{$d1}) { # $d1 is bigger
	  # silent just for complexe search mode
	  push @msg,$patchDOM->('remove', [ @p1, '@', $i ], \@p2 ,$d1->[$i], undef)
	}
	foreach $i ($#{$d1}+1..$#{$d2}) { # d2 is bigger
	  push @msg,$patchDOM->('add', \@p1, [ @p2, '@', $i ], undef, $d2->[$i])
	}
	return @msg;
      }

      ######################################## !!!!! ARRAY COMPARE (in complex mode)
      my @seen_src;
      my @seen_dst;
      my @res_Eq;
      # perhaps not on the same index (search in the dest @)
      my $i;
    ARRAY_CPLX:
      foreach $i (0..$#{$d1}) {
	my $val1 = $d1->[$i];

	#print "\n SAR($i) {";
	#if ($i<$#{$d2}) {
	if (exists $d2->[$i]) {
	  my @res;

	  loop_det($val1, @p1)
	    or
	      @res = compare($val1,
			     $d2->[$i],
			     [ @p1, '@',$i ],
			     [ @p2, '@',$i ]);

	  if (@res) {	$res_Eq[$i] = [@res]	    }   # (*)
	  else
	    {
	      $seen_src[$i]=$i;
	      $seen_dst[$i]=$i;
	      next ARRAY_CPLX;
	    }
	}
	my $j;
	foreach $j (0..$#{$d2}) {  #print " -> $j ";
	  next if ($i==$j);
	  next if (defined($seen_dst[$j]));

	  unless (compare( $val1,
			   $d2->[$j],
			   [ @p1, '@',$i ],
			   [ @p2, '@',$j ]))
	    {  #print " (found) ";

	      $seen_dst[$j] = 1;
	      $seen_src[$i] = $patchDOM->('move',
					  [ @p1, '@', $i ],
					  [ @p2, '@', $j ]);
	      next ARRAY_CPLX;
	    }
	}
	(defined  $seen_src[$i])
	  or
	    $seen_src[$i] = $patchDOM->('remove',
					[ @p1, '@', $i ],
					\@p2,
					$val1,
					undef
				       );

	#print " }SAR($i)";
      } # for $d1 (0..$min)

      ### destination table $d2 is bigger
      ##
      foreach $i (0..$#{$d2}) {
	defined($seen_dst[$i]) and next;

	$seen_dst[$i] = $patchDOM->('add',
				    \@p1,
				    [ @p2, '@', $i ],
				    undef,
				    $d2->[$i]
				   )
      }

      my $max = $#seen_dst;

      ($#seen_src>$max) and $max = $#seen_src;

      foreach (0..$max) {
	my $src = $seen_src[$_];
	my $dst = $seen_dst[$_];

	if (ref($res_Eq[$_]) and # differences on the same index (*)
	    ref($src) and ref($dst)) {

	  #print "\n src/dst : ".domPatch2TEXT($src)."/ ".domPatch2TEXT($dst)."\n";

	  # remove(@2,)= add(,@2)=
	  ($src->{action} eq 'remove') and
	    ($dst->{action} eq 'add') and
	      (push @msg, @{ $res_Eq[$_] })
		and next;
	}
	(ref $src) and push @msg,$src;
	(ref $dst) and push @msg,$dst;
      }

      $do_resolv_patch or return @msg;
      return resolve_patch(@msg);
    }
  ######################################## !!!!! REF COMPARE
  elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR')
    {
      if (loop_det($$d1, @p1)) {
      }
      else {
	@msg = ( compare($$d1, $$d2,
			 [ @p1, '$' ],
			 [ @p2, '$' ])
	       );
      }
      $do_resolv_patch or return @msg;
      return resolve_patch(@msg);
    }
  ######################################## !!!!! GLOBAL REF COMPARE
  elsif ($ref_type eq 'GLOB')
    {
      my $name1=$$d1;
      $name1=~s/^\*//;
      my $name2=$$d2;
      $name2=~s/^\*//;

      push @p1,'*', $name1;
      push @p2,'*', $name2;

      push @msg, $patchDOM->('change', \@p1 ,\@p2);

      my ($k,$g_d1,$g_d2)=(undef,undef,undef);

      if (defined *$d1{SCALAR} and defined(${*$d1{SCALAR}})) {
	$g_d1 = *$d1{SCALAR};
      }
      elsif (defined *$d1{ARRAY}) {
	$g_d1 = *$d1{ARRAY};
      }
      elsif (defined*$d1{HASH}) {
	$g_d1 = *$d1{HASH};
      }
      elsif (defined*$d1{GLOB}) {
	$g_d1 = *$d1{GLOB};
	loop_det($g_d1, @p1) and return ();
      }
      else {
	die $name1;
      }

      if (defined *$d2{SCALAR} and defined(${*$d2{SCALAR}})) {
	$g_d2 = *$d2{SCALAR};
      }
      elsif (defined *$d2{ARRAY}) {
	$g_d2 = *$d2{ARRAY};
      }
      elsif (defined*$d2{HASH}) {
	$g_d2 = *$d2{HASH};
      }
      elsif (defined*$d2{GLOB}) {
	$g_d2 = *$d2{GLOB};
      }
      else {
	die $name2;
      }

      my @msg = ( compare($g_d1, $g_d2, \@p1, \@p2));

      $do_resolv_patch or return @msg;
      return resolve_patch(@msg);

    }
  ######################################## !!!!! CODE REF COMPARE
  elsif ($ref_type eq 'CODE') {      # cannot compare this type

    #push @msg,$patchDOM->('change', \@p1, [@p2, '@', $i ], undef, $d2->[$i])
    return ();
  }
  ######################################## !!!!! What's that ?
  else {
    die 'unknown type /'.$ref_type.'/ '.join('',@p1);
  }
  return ();
}



##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub applyPatch($@) { # modify a dom source with a patch
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
  my $dom = shift();


=item I(,  [, ] )

applies the patches to the  (perl data structure)
 [, ] is the list of your patches to apply
supported patch format should be text or dom types,
the patch should a clear description of a modification
no '?' modifier or ambiguities)

Return the modified dom, die if patch are badly formated

EX:
    applyPatch([1,2,3],'add(,@4)=4')
    return [1,2,3,4]

=back

=cut

#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
  debug 'applyPatch('.__d($dom).') :';
  my (@remove,@add,@change,@move);

  my $p;
  foreach $p (@_) { # ordering the patch operations
    defined($p) or next;
    my $dom_patch = $p;

    (ref($p) eq 'HASH')
      or ($dom_patch) = textPatch2DOM($p);

    debug(domPatch2TEXT($dom_patch));

    eval 'push @'.$dom_patch->{action}.', $dom_patch;';
    $@ and die 'applyPatch() : '.$@;
  }

  my ($d,$t);

  my ($d1,$d2,$d3,$d4,$d5);
  my ($t1,$t2,$t3,$t4,$t5);

  my $patch_eval='$d='.__d($dom).";\n";

  $patch_eval .= '$t='.__d($dom).";\n";

  my $post_eval;

  my $r;
  foreach $r (@remove) {
    my @porig = @{$r->{path_orig}};

    my $key =  pop @porig;
    my $type = pop @porig;

    if ($type eq '@') {
      $patch_eval .= 'splice @{'.$path2eval__->('$d',undef,@porig) ."},$key,1;\n";
    }
    else {
      $patch_eval .= 'delete '.$path2eval__->('$d',undef,@porig,$type,$key) .";\n";
    }
  }

  my $m;
  my @remove_patch = sort
		 {
		   # the array indexes order from smallest to biggest
		   if (${$a->{path_orig}}[-2] eq '@') {
		     return (${$a->{path_orig}}[-1] >
			     ${$b->{path_orig}}[-1])
		   }
		   # smallest path after bigger ones
		   return $#{$a->{path_orig}} < $#{$b->{path_orig}};
		 } @move;

  foreach $m (@remove_patch) {
    my @porig = @{$m->{path_orig}};

    my $key =  pop @porig;
    my $type = pop @porig;

    if ($type eq '@') {
      $patch_eval .= 'splice @{'.$path2eval__->('$d',undef,@porig)."},$key,1;\n";
    }
    else {
      $patch_eval .= 'delete '.$path2eval__->('$d',undef,@porig,$type,$key) .";\n";
    }
  }

  foreach $m (@remove_patch) {
    my @porig = @{$m->{path_orig}};
    $patch_eval .= $path2eval__->('$d',undef,@{$m->{path_dest}}).
      ' = '.$path2eval__->('$t',undef,@porig).";\n";
  }


  my $a;
  foreach $a (@add) {
    $patch_eval .=
      $path2eval__->('$d',undef,@{$a->{path_dest}}).
	' = '.__d($a->{val_dest}) .";\n";
  }
  my $c;
  foreach $c (@change) {
    $patch_eval .=
      $path2eval__->('$d',undef,@{$c->{path_dest}}).
	' = '.__d($c->{val_dest}).";\n";
  }

  $patch_eval = $patch_eval.'$d;';

  my $res = eval($patch_eval);

  debug "\nEval=>> $patch_eval >>=".__d($res).".\n";

  $@
    and
      die 'applyPatch() : '.$patch_eval.$@;

  return $res
}

=back

=head2 Conversion Methods

=over 4

=cut


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub patternDom2Text($) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
  my @path=@{shift()};
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{

=item I()

convert the pattern DOM (array of element used by search(), path()) to text scalar string.


      is an array list of splited element of the pattern

Return equivalent text

EX:
    patternDom2Text( ['?@'] );

             Return '?@'

    patternDom2Text( ['%', 'r'] );

             Return '%r'

    patternDom2Text( ['@',3,'%','r'] );

             Return '@3%r'

    patternDom2Text( ['@',2,'=','3'] );

             Return '@2=3'

=cut

#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  # patternDom2Text is a singlé join without key defined

  (defined $CFG->{o_key}) or   return join('',@path);

  (%{$CFG->{o_key}}) or join('',@path);


  # matching Keys

  my $sz_path = scalar(@path);

  # debug "\n###".join('.',@{$path}).' '.join('|',keys %{$CFG->{o_key}});    <>;

  my %keys=%{$CFG->{o_key}};

# TODO : key priority sould be managed by a small getPrioritizedKey() function (warning)

  my @sorted_keys =
#    sort {      ( $keys{$a}->{priority} > $keys{$b}->{priority} ) }
    keys %keys;

  my $k;

  my $i = 0;
  while ($i

    foreach $k (@sorted_keys)
      {
	my $match = $keys{$k}{regexp};

	#warn "\n=$k on ".join('',@path[0..$i]);

	my $min_index = $matchPath->($match, @path[0..$i]);

	if (defined $min_index) {
	  # debug
	  #warn " -> key($k -> ".join(' ',@{$match}).")  = $min_index\n";

	  # replace the (matched key expression) by ('/' , )

	  splice @path, $min_index, scalar(@$match), '/',$k;

	  $i = $i + 2 - scalar(@$match);

	  #warn "-> path  -> ".join('.',@path)." \$i=$i\n";
      }
    }
    $i++;
  }
  return join('',@path);

};



##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub domPatch2TEXT(@) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

=over 4

=item I(,  [,])

convert a list of perl usable patches into a readable text format.
Also convert to key patterns which are matching the regexp key definnition
Mainly used to convert the compare result (format dom)

ARGS:
   a list of

Return a list of patches in TEXT mode

EX:


   domPatch2TEXT($patch1)

        returns 'change(@0$%magic_key,@0$%magic_key)="toto"/=>"tata"'


   # one key defined
   o_key({ key_1 => {regexp=>['%','magic_key'], eval=>'{magic_key}' }	} );

   # same but with the related matched key in path

   domPatch2TEXT($patch1)

        returns 'change(@0$/key_1,@0$/key_1)="toto"/=>"tata"'


=cut

  my @res;
  my $patch;
  foreach $patch (@_) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

    (ref($patch) eq 'HASH') and do {

      (exists $patch->{action})
	or die 'domPatch2TEXT(): bad internal dom structure '.__d($patch);


      my $action = $patch->{action};
      my $v1 = $patch->{val_orig};
      my $v2 = $patch->{val_dest};

      my $txt = $action
	.'('
	  .patternDom2Text($patch->{path_orig})
	    .','
	      .patternDom2Text($patch->{path_dest})
		.')=';

      if (($action eq 'remove') or ($action eq 'change')) {
	$v1 = __d($v1);
	$v1 =~ s|/=>|\/\\054\>|g;
	$v1 =~ s/\s=>\s/=>/sg;
	$txt .= $v1;
      }

      ($action eq 'change') and $txt .= '/=>';

      if (($action eq 'add') or ($action eq 'change')) {
	$v2 = __d($v2);
	$v2 =~ s|/=>|\/\\054\>|g;
	$v2 =~ s/\s=>\s/=>/sg;
	$txt .= $v2;
      }

      push @res, $txt;
      next
    } or
    (ref($_) eq 'ARRAY') and do {
      push @res,join '', @{$_};
      next
    };
  }

  #
  (wantarray()) and return @res;
  return join("\n",@res);
}

##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub domPatch2IHM(@) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

=item I(,  [,])

convert a list of patches in DOM format (internal Data;;Deep format)
into a IHM format.
Mainly used to convert the compare result (format dom)

ARGS:
   a list of

Return a list of patches in IHM mode
   IHM format is not convertible

EX:
   C($patch1)
   returns
       '"toto" changed in "tata" from @0$%a
                       into @0$%a
=cut


  my ($msg,$patch);

  foreach $patch (@_) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
    $_ = $patch->{action};

    /^add$/ and ($msg .= __d($patch->{val_orig}).' added')
      or
	/^remove$/ and ($msg .= __d($patch->{val_orig}).' removed')
	  or
	    /^move$/ and ($msg .= 'Moved ')
	      or
		/^change$/ and ($msg .= __d($patch->{val_orig})
				.' changed in '
				.__d($patch->{val_dest}));
    my $l = length($msg);
    my $MAX_COLS=40;
    if ($l>$MAX_COLS) {
      $msg .= "\n   from ".join('',@{$patch->{path_orig}});
      $msg .= "\n   into ".join('',@{$patch->{path_dest}});
    }
    else {
      $l-=($msg=~ s/\n//g);
      $msg .= ' from '.join('',@{$patch->{path_orig}});
      $msg .= "\n".(' 'x $l).' into '.join('',@{$patch->{path_dest}});
    }
    $msg .= "\n";
  }
  return $msg;
}


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub patternText2Dom($) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  my $pathTxt = shift();

  (ref($pathTxt)) and die 'patternText2Dom() : bad call with a reference instead of scalar containing pattern text ';

=item I()

convert pattern scalar string to the array of element to be used by search(), path()


      is an array of type description to match
     optional argument to limit the number of results
                  if undef all results are returned
		  if 1 first one is returned

Return an array  list of splited element of the  for usage

EX:
    patternText2Dom( '?@' );

             Return ['?@']

    patternText2Dom( '%r' );

             Return ['%', 'r']

    patternText2Dom( '@3%r' );

             Return ['@',3,'%','r']

    patternText2Dom( '@2=3' );

             Return ['@',2,'=','3']

=cut

#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

  my @path;

  #debug "patternText2Dom($pathTxt)";;

  my %keys=();

   (ref($CFG->{o_key})) and %keys = %{$CFG->{o_key}};

  my @pathTxt = split('',$pathTxt);

  while (@pathTxt) {

    $_ = shift @pathTxt;

    if (defined($path[-1]) and $path[-1] =~ /^\?/ and m/^[\=\%\$\@\%\*]/) {
      $path[-1].= $_;
    }
    elsif ($_ eq '$') {
      push(@path,'$');
    }
    elsif ($_ eq '?') {
      push(@path,'?');
    }
    elsif ($_ eq '&') {
      push(@path,'&');
    }
    elsif (/([%\@\=\|\*\/])/) {
      push(@path,$1,'');
    }
    else {
      if ($path[-2] eq '/' and exists($keys{$path[-1]})) {
           # cf test "Search Complex key 3..5"
             push(@path,'');
      }
      $path[-1].= $_;
    }
  }

  # post - convertion § array & key convertion

  my $i;
  for $i (0..$#path) {

    if ($path[$i] eq '@') {
      $path[$i+1] = int($path[$i+1]);
    }
    elsif ($path[$i] eq '/') {
      my $keyname = $path[$i+1];
      (exists($keys{$keyname})) or die 'patternText2Dom() ! no key '.$keyname;

      splice @path, $i, 2, @{ $keys{$keyname}{regexp} };

    }
  }

#warn "patternText2Dom(".join('',@pathTxt).')=> '.join(' ',@path)."  .";

  #debug '=>'.join('.',@path);
  return [@path];
};


##############################################################################
#{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
sub textPatch2DOM(@) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}

=item I(,  [,])

convert a list of patches formatted in text (readable text format format)
to a perl DOM format (man  perldsc).
Mainly used to convert the compare result (format dom)

ARGS:
   a list of

Return a list of patches in dom mode

EX:
   C( 'change(@0$%a,@0$%a)="toto"/=>"tata"',
                        'move(... '
                      )

returns (
   { action=>'change',
     path_orig=>['@0','$','%a'],
     path_dest=>['@0','$','%a'],
     val_orig=>"toto",
     val_dest=>"tata"
   },
   { action=>'move',
     ...
   });

=cut

  my @res;
  while (@_) {
#}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
    my $patch=pop;

    defined($patch) or next;

    debug "textPatch2DOM in ".$patch;

    my ($p1,$p2,$v1,$v2);
    $patch =~ s/^(\w+)\(// or die 'Data::Deep::textPatch2DOM / bad patch format :'.$patch.'  !!!';

    my $action = $1; # or die 'action ???';

    ( $patch =~ s/^([^,]*?),//
    ) and $p1 = patternText2Dom($1);

    ( $patch =~ s/^([^\(]*?)\)=//
    ) and $p2 = patternText2Dom($1);

    if ($action ne 'move') {
      my $i = index($patch, '/=>');
      if ($i ==-1 ) {
	($action eq 'add') && ($v2 = $patch) or ($v1 = $patch);
      }
      else {
	$v1 = substr($patch, 0, $i);
	$v2 = substr($patch, $i+3);
      }
    }
    my $a = eval($v1);
    ($@) and die "textPatch2DOM() error in eval($v1) : ".$@;

    my $b = eval($v2);
    ($@) and die "textPatch2DOM() error in eval($v2) : ".$@;

    push @res,$patchDOM->($action, $p1, $p2, $a, $b);
  }

  #
  (wantarray()) and return @res;
   return [@res];
}


=begin end

=head1 AUTHOR


Data::Deep was written by Matthieu Damerose [e-mail]> in 2005.

=cut


   ###########################################################################
1;#############################################################################
__END__ Deep::Manip.pm