Mungle/Transform/Deep.pm

## ---------------------------------------------------------------------------
##  $Id: Deep.pm,v 1.22 2003/05/10 17:09:18 jonen Exp $
## ---------------------------------------------------------------------------
##  $Log: Deep.pm,v $
##  Revision 1.22  2003/05/10 17:09:18  jonen
##  + added keep of empty arrays/hashes if 'expand' for php
##
##  Revision 1.21  2003/04/09 07:21:56  joko
##  childObj2string now inside Encode.pm, renamed to 'twingle_reference'
##
##  Revision 1.20  2003/04/04 17:31:23  joko
##  minor update to 'childObj2string'
##
##  Revision 1.19  2003/03/28 03:11:25  jonen
##  + bugfix
##
##  Revision 1.18  2003/03/28 03:07:26  jonen
##  + minor changes
##
##  Revision 1.17  2003/03/27 15:17:07  joko
##  namespace fixes for Data::Mungle::*
##
##  Revision 1.16  2003/03/27 15:04:52  joko
##  minor update: comment
##
##  Revision 1.15  2003/02/27 14:39:48  jonen
##  + fixed bug at _hash2object()
##
##  Revision 1.14  2003/02/22 17:13:55  jonen
##  + added function 'childObject2string()' to encode 'child'-references to option related string
##  + use new option at 'expand()' for replacing 'childObject2string'
##
##  Revision 1.13  2003/02/21 01:48:50  joko
##  renamed core function
##
##  Revision 1.12  2003/02/20 22:45:19  joko
##  fix regarding new deep_copy
##
##  Revision 1.11  2003/02/20 21:13:54  joko
##  - removed implementation of deep_copy2 - get this from the Pitonyak namespace (now cloned to repository)
##
##  Revision 1.10  2003/02/20 20:48:00  joko
##  - refactored lots of code to Data::Code::Ref
##  + alternative 'deep_copy' implementation
##
##  Revision 1.9  2003/02/18 19:35:56  joko
##  +- modified 'sub refexpr2perlref': now can get the $delimiter passed, too
##
##  Revision 1.8  2003/02/09 05:10:56  joko
##  + minor update
##
##  Revision 1.7  2003/01/19 03:26:59  joko
##  + added 'sub deep_copy'  -  refactored from libp
##  + add 'sub merge'  -  exported from CPAN's 'Hash::Merge'
##
##  Revision 1.6  2002/12/23 11:27:53  jonen
##  + changed behavior WATCH!
##
##  Revision 1.5  2002/12/16 19:57:54  joko
##  + option 'init'
##
##  Revision 1.4  2002/12/05 13:56:49  joko
##  - var_deref
##  + expand - more sophisticated dereferencing with callbacks using Iterate
##
##  Revision 1.3  2002/12/03 05:34:55  joko
##  + bugfix: now utilizing var_utf2iso from Data::Transform::Encode
##
##  Revision 1.2  2002/12/01 04:44:07  joko
##  + code from Data::Transform::OO
##
##  Revision 1.1  2002/11/29 04:49:20  joko
##  + initial check-in
##
##  Revision 1.1  2002/10/10 03:26:00  cvsjoko
##  + new
## ---------------------------------------------------------------------------


package Data::Mungle::Transform::Deep;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw(
  &expand
  &deep_copy
  &merge_to
);


use attributes;
use Data::Dumper;
use Iterate;

use Pitonyak::DeepCopy;
use Data::Mungle::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar twingle_reference );
use Data::Mungle::Code::Ref qw( ref_slot );

sub numhash2list {
  my $vref = shift;
  #my $context = shift;
  if (ref $vref eq 'HASH') {
    foreach (keys %{$vref}) {
#      if ((ref $vref->{$_}) =~ m/HASH/) {
          if ((ref $vref->{$_}) =~ m/HASH/) {
            if ($vref->{$_}{0}) {   # might be a numerical-indexed array
              #print "000\n";
              #print "context: $context\n";
              my @arr;
              foreach my $key_numeric (sort keys %{$vref->{$_}}) {
                push @arr, $vref->{$_}{$key_numeric};
              }
              $vref->{$_} = \@arr;
            }
            numhash2list($vref->{$_});
          }
#      } else {
#        #$vref->{$_} = scalar2iso($vref->{$_});
#      }
    }
  }
}


# FIXME: could this be refactored using expand?
# btw: "expand": look at scripts@CPAN (System Administration):
# there is a perl make with perl
sub _var_deref_test {
  my $obj = shift;
  my $options = shift;
  my $result;
  if ((ref $obj) eq 'ARRAY') {
    foreach (@{$obj}) {
      my $ref = ref $_;
      if ($ref) {
        push(@{$result}, var_deref($_, $options));
        #undef $_;
      } else {
        #push(@{$result}, $_);
        push(@{$result}, deep_copy($_));
      }
      #undef $_ if $options->{destroy};
      #$options->{destroy}->($_) if $options->{destroy};
    }
  # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
  } else {
    foreach (keys %{$obj}) {
      my $key = $_;
      my $ref = ref $obj->{$_};
      if ($ref) {
        $result->{$_} = var_deref($obj->{$_}, $options);
        #undef $obj->{$_};
      } else {
        #$result->{$_} = $obj->{$_};
        $result->{$_} = deep_copy($obj->{$_});
      }
      #undef $obj->{$_} if $options->{destroy};
      #$options->{destroy}->($obj->{$_}) if $options->{destroy};
    }
  }
  #undef $obj if $options->{destroy};
  $options->{cb_destroy}->($obj) if $options->{cb_destroy};
  return $result;
}


# convert values in hash to utf8 (and back) to be ready for (e.g.) encapsulation in XML
# but still using the known latin locale stuff
# TODO: Review: Could this be revamped using Clone.pm?
sub expand {

  my $obj = shift;
  my $options = shift;
  my $result;

  #print "ref: ", ref $obj, "\n";

  if (ref $obj eq 'ARRAY') {
   
   # if we expand for php, keep empty ARRAY
   if($#$obj == -1 && $options->{childObj2string}) {
     $result = $obj;
   } else {
    IterArray @$obj, sub {
      my $item;
      # if current item is a reference ...
      if (ref $_[0]) {
        $item = $_[0];
        # if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
        # instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) 
        if ($item && $options->{childObj2string}) {
          $item = twingle_reference($item);
        } else {
          # ... expand structure recursively
          $item = expand($_[0], $options);
        }
        # destroy item via seperate callback method (a POST) if requested
        #$options->{cb}->{destroy}->($_[0]) if $options->{destroy};

      # ... assume plain scalar
      } else {
        #$item = deep_copy($_[0]);
        $item = $_[0];
        # conversions/encodings
        $item = latin_to_utf8_scalar($item) if ($item && $options->{utf8});
        $item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin});
      }
      
      $item = '' if $options->{define} and not defined $item;
      #push(@{$result}, $item) if $item;   # use item only if not undef  (TODO: make configurable via $options)
      push(@{$result}, $item);                 # use item in any case

    }
   }

  } elsif (ref $obj eq 'CODE') {
    #print Dumper($obj);
    #exit;

  # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
  } elsif (ref $obj) {
   
   # if we expand for php, keep empty HASH
   my @tmp = keys %$obj;
   if($#tmp == -1 && $options->{childObj2string}) {
     $result = $obj;
   } else {
    IterHash %$obj, sub {
      my $item;
      
      # if current item is a reference ...
      if (ref $_[1]) {
        $item = $_[1];
        # if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
        # instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) 
        if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH") && !(ref $_[1] eq "Set::Object")) {
          $item = twingle_reference($item);
        } else {
          # ... expand structure recursively
          $item = expand($_[1], $options);
        }
        # destroy item via seperate callback method (a POST) if requested
        #$options->{cb}->{destroy}->($_[1]) if $options->{destroy};
      
      # ... assume plain scalar
      } else {
        #$item = deep_copy($_[1]);
        $item = $_[1];
        # conversions/encodings
        $item = latin_to_utf8_scalar($item) if ($item && $options->{utf8});
        $item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin});
      }
      
      $item = '' if $options->{define} and not defined $item;
      #$result->{$_[0]} = $item if $item;   # use item only if not undef  (TODO: make configurable via $options)
      $result->{$_[0]} = $item;               # use item in any case
    }
   }

  } else {
    #die ("not a reference!");
    $result = $obj;

  }

  # convert all values to utf8 (inside complex struct)
    # now done in core-item-callbacks via Greg London's "Iterate" from CPAN
    # latin_to_utf8($result) if ($options->{utf8});

  # destroy persistent object from memory to be sure to get a fresh one next time
  #undef $obj if $options->{destroy};
  #$options->{cb_destroy}->($obj) if $options->{cb_destroy};
  #$options->{cb}->{destroy}->($obj) if $options->{destroy};
  
  return $result;
}


my @indexstack;
sub _var_traverse_mixin_update_old {
  my $obj = shift;
  my $data = shift;
  my $bool_recursion = shift;
  if (!$bool_recursion) {
    @indexstack = ();
  }
  my $result;

  # 'ARRAY' does not work!
  if ((ref $obj) eq 'ARRAY') {
    #print "ARRAY\n";
    my $i = 0;
    foreach (@{$obj}) {
      push @indexstack, $i;
      my $ref = ref $_;
      if ($ref) {
        #$obj->[$i] = var_mixin($_, $data, 1);
        var_traverse_mixin_update($_, $data, 1);
      } else {
        $obj->[$i] = $_;
      }
      pop @indexstack;
      $i++;
    }
  } else {
    foreach (keys %{$obj}) {
      push @indexstack, $_;
      my $ref = ref $obj->{$_};
      if ($ref) {
        #$obj->{$_} = var_mixin($obj->{$_}, $data, 1);
        var_traverse_mixin_update($obj->{$_}, $data, 1);
      } else {
        #$obj->{$_} = $obj->{$_};
        my $evstring = getSlot($data);
        $obj->{$_} = $evstring;
        
      }
      pop @indexstack;
    }
  }
  #return $result;
}

sub merge_to {
  _hash2object(@_);
  # TODO:
  # re-implement using CPAN's "Iterate" and/or a modified Hash::Merge.
}


# todo: maybe do diff(s) here sometimes!?
sub _hash2object {
  my $object = shift;
  my $data = shift;
  my $options = shift;

  #print "hash2object", "\n";
  
  # "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,
  # this method corrects this
  numhash2list($data) if ($options->{php});

  # utf8-conversion/-encoding (essential for I18N)
  utf8_to_latin($data) if ($options->{utf8});

  # get fresh object from database
  # todo:
  #   - handle "locked" objects !!!
  #   - check if already another update occoured (object-revisioning needed!)
  #my $obj = $self->getObject($oid);

  # mix changes into fresh object and save it back
  _hash2object_traverse_mixin($object, $data, 0, $options);

  # done in core mixin function?
  #$self->{storage}->update($obj);

  # we should "undef" some objects here to destroy them in memory and enforce reloading when used next time
  # simulate:
  #$self->{storage}->disconnect();

}

# ------------------------------------
#   core mixin function
# TODO-FEATURE: make this possible in a reverse way: object is empty (no fields) and gets filled up by mixin-data

# remember keys of structures we are traversing
# this is a HACK:
#  - don't (!!!) "packageglobal" @indexstack
#  - it will lead to problems with parallelism!

#my @indexstack;

# traverse a deeply nested structure, mix in values from given hash, update underlying tangram-object
sub _hash2object_traverse_mixin {
  my $object = shift;
  my $data = shift;
  my $bool_recursion = shift;
  my $options = shift;

  # clear our key - stack if we are called from user-code (non-recursively)
  @indexstack = () if (!$bool_recursion);

  my $classname = ref $object;
#  if ($classname) {
#    print STDERR "*****************", Dumper(Class::Tangram::attribute_types($classname)), "\n";
#  }

  # parser: detected OBJECT (a Tangram one?)   (reftype == HASH) (assume)
  # what's exactly done here? hmmm.... it works ;)
  # maybe a HACK: please try not to use "IntrHash"es, maybe this cannot handle them!!!
  # extend! check!
  
  #print attributes::reftype($object), "\n";
  
  # V1
  #if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) {
  # V2
  my $reftype = attributes::reftype($object);
  #print "reftype: '$reftype'", "\n";
  if ($reftype eq 'HASH') {

#    print STDERR "===", "reftype: ", attributes::reftype($obj), "\n";
        
    my @fields;
    # loop through fields of object (Tangram-object)
    @fields = keys %{$object};

    # loop through fields of to.be.injected-data (arbitrary Perl-data-structure)
    @fields = keys %{$data} if $options->{init};
#    @fields = keys %{$data} if $options->{mixin};
    
    foreach (@fields) {
      my $field = $_;
      push @indexstack, $field;
            
      # determine type of object
      my $ref = ref $object->{$field};
#      print STDERR "attrname: $_  ATTRref: $ref", "\n";
      if ($ref) {
        _hash2object_traverse_mixin($object->{$field}, $data, 1, $options);
      } else {
        my $val = ref_slot($data, \@indexstack);
        
#print Dumper($options);
        my $field_target = $field;
        if (my $pattern = $options->{pattern_strip_key}) {
          print "pattern: $pattern", "\n";
          $field_target =~ s/$pattern//;
          print "field: $field_target", "\n";
        }

        $object->{$field_target} = $val if defined $val;
      }
      pop @indexstack;
    }

    # save object to database ...
    # ... do an update if it already exists, do an insert if it doesn't
#    my $objectId = $self->{storage}->id($obj);
#    $logger->debug( __PACKAGE__ . "->saveObjectFromHash_traverse_mixin_update( object $obj objectId $objectId )" );
#    if ($objectId) {
#      $self->{storage}->update($obj);

#print __PACKAGE__ . ":", "\n";
#print Dumper($object);

#    } else {
#      $self->{storage}->insert($obj);
#    }
    
  }

#&& ( ref($obj) ne 'HASH' ) 

    # loop through entries of array (IntrArray, isn't it?)
  if ((ref $object) eq 'ARRAY') {
#    print STDERR "===", "refttype ", attributes::reftype($obj), "\n";
    my $i = 0;
    foreach (@{$object}) {
      push @indexstack, $i;
      my $ref = ref $_;
#      print STDERR "attrname: $_  ATTRref: $ref", "\n";
#      if ($ref && $_) {
      if ($ref) {
        _hash2object_traverse_mixin($_, $data, 1, $options);
      } else {
        $object->[$i] = $_ if defined $_;
      }
      pop @indexstack;
      $i++;
    }

=pod
  # object?
  } else {
    print "reference: ", ref $object, "\n";
    print "reftype: ", $reftype, "\n";
    die(__PACKAGE__ . "->_hash2object_traverse_mixin: can not handle this!");
=cut
  
  }

}


# ACK's go to Randal L. Schwartz <merlyn@stonehenge.com>
# on the website:
# This text is copyright by Miller-Freeman, Inc., and is used with their permission. 
# Further distribution or use is not permitted. 
# please visit http://www.stonehenge.com/merlyn/UnixReview/col30.html
sub deep_copy1 {
  my $this = shift;
  if (not ref $this) {
    $this;
  } elsif (ref $this eq "ARRAY") {
    [map deep_copy1($_), @$this];
  } elsif (ref $this eq "HASH") {
    +{map { $_ => deep_copy1($this->{$_}) } keys %$this};
  } elsif (ref $this eq "CODE") {
    $this;
  } else { die "deep_copy1 asks: what type is $this?" }
  #} else { print "deep_copy asks: what type is $this?", "\n"; }
}

# ACK's go to Andrew Pitonyak
# Copyright 2002, Andrew Pitonyak (perlboy@pitonyak.org)
# please visit: http://www.pitonyak.org/code/perl/Pitonyak/DeepCopy.pm.html
sub deep_copy {
  Pitonyak::DeepCopy::deep_copy(@_);
}


1;
__END__
1	joko	1.7	## ---------------------------------------------------------------------------
2	joko	1.23	## $Id: Deep.pm,v 1.22 2003/05/10 17:09:18 jonen Exp $
3	joko	1.7	## ---------------------------------------------------------------------------
4	joko	1.8	## $Log: Deep.pm,v $
5	joko	1.23	## Revision 1.22 2003/05/10 17:09:18 jonen
6			## + added keep of empty arrays/hashes if 'expand' for php
7			##
8	jonen	1.22	## Revision 1.21 2003/04/09 07:21:56 joko
9			## childObj2string now inside Encode.pm, renamed to 'twingle_reference'
10			##
11	joko	1.21	## Revision 1.20 2003/04/04 17:31:23 joko
12			## minor update to 'childObj2string'
13			##
14	joko	1.20	## Revision 1.19 2003/03/28 03:11:25 jonen
15			## + bugfix
16			##
17	jonen	1.19	## Revision 1.18 2003/03/28 03:07:26 jonen
18			## + minor changes
19			##
20	jonen	1.18	## Revision 1.17 2003/03/27 15:17:07 joko
21			## namespace fixes for Data::Mungle::*
22			##
23	joko	1.17	## Revision 1.16 2003/03/27 15:04:52 joko
24			## minor update: comment
25			##
26	joko	1.16	## Revision 1.15 2003/02/27 14:39:48 jonen
27			## + fixed bug at _hash2object()
28			##
29	jonen	1.15	## Revision 1.14 2003/02/22 17:13:55 jonen
30			## + added function 'childObject2string()' to encode 'child'-references to option related string
31			## + use new option at 'expand()' for replacing 'childObject2string'
32			##
33	jonen	1.14	## Revision 1.13 2003/02/21 01:48:50 joko
34			## renamed core function
35			##
36	joko	1.13	## Revision 1.12 2003/02/20 22:45:19 joko
37			## fix regarding new deep_copy
38			##
39	joko	1.12	## Revision 1.11 2003/02/20 21:13:54 joko
40			## - removed implementation of deep_copy2 - get this from the Pitonyak namespace (now cloned to repository)
41			##
42	joko	1.11	## Revision 1.10 2003/02/20 20:48:00 joko
43			## - refactored lots of code to Data::Code::Ref
44			## + alternative 'deep_copy' implementation
45			##
46	joko	1.10	## Revision 1.9 2003/02/18 19:35:56 joko
47			## +- modified 'sub refexpr2perlref': now can get the $delimiter passed, too
48			##
49	joko	1.9	## Revision 1.8 2003/02/09 05:10:56 joko
50			## + minor update
51			##
52	joko	1.8	## Revision 1.7 2003/01/19 03:26:59 joko
53			## + added 'sub deep_copy' - refactored from libp
54			## + add 'sub merge' - exported from CPAN's 'Hash::Merge'
55			##
56	joko	1.7	## Revision 1.6 2002/12/23 11:27:53 jonen
57			## + changed behavior WATCH!
58			##
59			## Revision 1.5 2002/12/16 19:57:54 joko
60			## + option 'init'
61			##
62			## Revision 1.4 2002/12/05 13:56:49 joko
63			## - var_deref
64			## + expand - more sophisticated dereferencing with callbacks using Iterate
65			##
66			## Revision 1.3 2002/12/03 05:34:55 joko
67			## + bugfix: now utilizing var_utf2iso from Data::Transform::Encode
68			##
69			## Revision 1.2 2002/12/01 04:44:07 joko
70			## + code from Data::Transform::OO
71			##
72			## Revision 1.1 2002/11/29 04:49:20 joko
73			## + initial check-in
74			##
75			## Revision 1.1 2002/10/10 03:26:00 cvsjoko
76			## + new
77			## ---------------------------------------------------------------------------
78	joko	1.1
79
80	joko	1.17	package Data::Mungle::Transform::Deep;
81	joko	1.1
82			use strict;
83			use warnings;
84
85			require Exporter;
86			our @ISA = qw( Exporter );
87	joko	1.2	our @EXPORT_OK = qw(
88	joko	1.4	&expand
89	joko	1.7	&deep_copy
90	joko	1.10	&merge_to
91	joko	1.1	);
92	joko	1.10
93	joko	1.1
94			use attributes;
95	joko	1.2	use Data::Dumper;
96	joko	1.10	use Iterate;
97	joko	1.7
98	joko	1.12	use Pitonyak::DeepCopy;
99	joko	1.21	use Data::Mungle::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar twingle_reference );
100	joko	1.17	use Data::Mungle::Code::Ref qw( ref_slot );
101	joko	1.1
102	joko	1.10	sub numhash2list {
103	joko	1.1	my $vref = shift;
104			#my $context = shift;
105			if (ref $vref eq 'HASH') {
106			foreach (keys %{$vref}) {
107			# if ((ref $vref->{$_}) =~ m/HASH/) {
108			if ((ref $vref->{$_}) =~ m/HASH/) {
109			if ($vref->{$_}{0}) { # might be a numerical-indexed array
110			#print "000\n";
111			#print "context: $context\n";
112			my @arr;
113			foreach my $key_numeric (sort keys %{$vref->{$_}}) {
114			push @arr, $vref->{$_}{$key_numeric};
115			}
116			$vref->{$_} = \@arr;
117			}
118	joko	1.10	numhash2list($vref->{$_});
119	joko	1.1	}
120			# } else {
121			# #$vref->{$_} = scalar2iso($vref->{$_});
122			# }
123			}
124			}
125			}
126
127
128	joko	1.9	# FIXME: could this be refactored using expand?
129			# btw: "expand": look at scripts@CPAN (System Administration):
130			# there is a perl make with perl
131	joko	1.10	sub _var_deref_test {
132	joko	1.1	my $obj = shift;
133	joko	1.4	my $options = shift;
134	joko	1.1	my $result;
135			if ((ref $obj) eq 'ARRAY') {
136			foreach (@{$obj}) {
137			my $ref = ref $_;
138			if ($ref) {
139	joko	1.4	push(@{$result}, var_deref($_, $options));
140			#undef $_;
141	joko	1.1	} else {
142	joko	1.4	#push(@{$result}, $_);
143			push(@{$result}, deep_copy($_));
144	joko	1.1	}
145	joko	1.4	#undef $_ if $options->{destroy};
146			#$options->{destroy}->($_) if $options->{destroy};
147	joko	1.1	}
148	joko	1.2	# TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ???
149	joko	1.1	} else {
150			foreach (keys %{$obj}) {
151			my $key = $_;
152			my $ref = ref $obj->{$_};
153			if ($ref) {
154	joko	1.4	$result->{$_} = var_deref($obj->{$_}, $options);
155			#undef $obj->{$_};
156	joko	1.1	} else {
157	joko	1.4	#$result->{$_} = $obj->{$_};
158			$result->{$_} = deep_copy($obj->{$_});
159	joko	1.1	}
160	joko	1.4	#undef $obj->{$_} if $options->{destroy};
161			#$options->{destroy}->($obj->{$_}) if $options->{destroy};
162	joko	1.1	}
163			}
164	joko	1.4	#undef $obj if $options->{destroy};
165			$options->{cb_destroy}->($obj) if $options->{cb_destroy};
166	joko	1.1	return $result;
167			}
168
169
170	joko	1.13	# convert values in hash to utf8 (and back) to be ready for (e.g.) encapsulation in XML
171			# but still using the known latin locale stuff
172	joko	1.23	# TODO: Review: Could this be revamped using Clone.pm?
173	joko	1.4	sub expand {
174
175			my $obj = shift;
176			my $options = shift;
177			my $result;
178
179	joko	1.10	#print "ref: ", ref $obj, "\n";
180
181			if (ref $obj eq 'ARRAY') {
182	jonen	1.22
183			# if we expand for php, keep empty ARRAY
184			if($#$obj == -1 && $options->{childObj2string}) {
185			$result = $obj;
186			} else {
187	joko	1.4	IterArray @$obj, sub {
188			my $item;
189			# if current item is a reference ...
190			if (ref $_[0]) {
191	jonen	1.14	$item = $_[0];
192			# if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
193			# instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> )
194			if ($item && $options->{childObj2string}) {
195	joko	1.21	$item = twingle_reference($item);
196	jonen	1.14	} else {
197			# ... expand structure recursively
198			$item = expand($_[0], $options);
199			}
200	joko	1.4	# destroy item via seperate callback method (a POST) if requested
201			#$options->{cb}->{destroy}->($_[0]) if $options->{destroy};
202
203			# ... assume plain scalar
204			} else {
205			#$item = deep_copy($_[0]);
206			$item = $_[0];
207			# conversions/encodings
208	joko	1.10	$item = latin_to_utf8_scalar($item) if ($item && $options->{utf8});
209			$item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin});
210	joko	1.4	}
211	joko	1.23
212			$item = '' if $options->{define} and not defined $item;
213	joko	1.4	#push(@{$result}, $item) if $item; # use item only if not undef (TODO: make configurable via $options)
214			push(@{$result}, $item); # use item in any case
215
216			}
217	jonen	1.22	}
218	joko	1.4
219	joko	1.10	} elsif (ref $obj eq 'CODE') {
220			#print Dumper($obj);
221			#exit;
222
223	joko	1.4	# TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ???
224	joko	1.10	} elsif (ref $obj) {
225	jonen	1.22
226			# if we expand for php, keep empty HASH
227			my @tmp = keys %$obj;
228			if($#tmp == -1 && $options->{childObj2string}) {
229			$result = $obj;
230			} else {
231	joko	1.4	IterHash %$obj, sub {
232			my $item;
233
234			# if current item is a reference ...
235			if (ref $_[1]) {
236	jonen	1.14	$item = $_[1];
237			# if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
238			# instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> )
239	jonen	1.22	if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH") && !(ref $_[1] eq "Set::Object")) {
240	joko	1.21	$item = twingle_reference($item);
241	jonen	1.14	} else {
242			# ... expand structure recursively
243			$item = expand($_[1], $options);
244			}
245	joko	1.4	# destroy item via seperate callback method (a POST) if requested
246			#$options->{cb}->{destroy}->($_[1]) if $options->{destroy};
247
248			# ... assume plain scalar
249			} else {
250			#$item = deep_copy($_[1]);
251			$item = $_[1];
252			# conversions/encodings
253	joko	1.10	$item = latin_to_utf8_scalar($item) if ($item && $options->{utf8});
254			$item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin});
255	joko	1.4	}
256	joko	1.23
257			$item = '' if $options->{define} and not defined $item;
258	joko	1.4	#$result->{$_[0]} = $item if $item; # use item only if not undef (TODO: make configurable via $options)
259			$result->{$_[0]} = $item; # use item in any case
260			}
261	jonen	1.22	}
262	joko	1.4
263	joko	1.10	} else {
264			#die ("not a reference!");
265			$result = $obj;
266
267	joko	1.4	}
268
269			# convert all values to utf8 (inside complex struct)
270			# now done in core-item-callbacks via Greg London's "Iterate" from CPAN
271	joko	1.13	# latin_to_utf8($result) if ($options->{utf8});
272	joko	1.4
273			# destroy persistent object from memory to be sure to get a fresh one next time
274			#undef $obj if $options->{destroy};
275			#$options->{cb_destroy}->($obj) if $options->{cb_destroy};
276			#$options->{cb}->{destroy}->($obj) if $options->{destroy};
277
278			return $result;
279			}
280
281	joko	1.1
282
283			my @indexstack;
284	joko	1.10	sub _var_traverse_mixin_update_old {
285	joko	1.1	my $obj = shift;
286			my $data = shift;
287			my $bool_recursion = shift;
288			if (!$bool_recursion) {
289			@indexstack = ();
290			}
291			my $result;
292
293			# 'ARRAY' does not work!
294			if ((ref $obj) eq 'ARRAY') {
295			#print "ARRAY\n";
296			my $i = 0;
297			foreach (@{$obj}) {
298			push @indexstack, $i;
299			my $ref = ref $_;
300			if ($ref) {
301			#$obj->[$i] = var_mixin($_, $data, 1);
302			var_traverse_mixin_update($_, $data, 1);
303			} else {
304			$obj->[$i] = $_;
305			}
306			pop @indexstack;
307			$i++;
308			}
309			} else {
310			foreach (keys %{$obj}) {
311			push @indexstack, $_;
312			my $ref = ref $obj->{$_};
313			if ($ref) {
314			#$obj->{$_} = var_mixin($obj->{$_}, $data, 1);
315			var_traverse_mixin_update($obj->{$_}, $data, 1);
316			} else {
317			#$obj->{$_} = $obj->{$_};
318			my $evstring = getSlot($data);
319			$obj->{$_} = $evstring;
320
321			}
322			pop @indexstack;
323			}
324			}
325			#return $result;
326			}
327
328	joko	1.10	sub merge_to {
329			_hash2object(@_);
330			# TODO:
331	joko	1.16	# re-implement using CPAN's "Iterate" and/or a modified Hash::Merge.
332	joko	1.2	}
333
334	joko	1.10
335	joko	1.2	# todo: maybe do diff(s) here sometimes!?
336	joko	1.10	sub _hash2object {
337	joko	1.2	my $object = shift;
338			my $data = shift;
339			my $options = shift;
340
341	joko	1.3	#print "hash2object", "\n";
342
343	joko	1.2	# "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,
344			# this method corrects this
345	joko	1.10	numhash2list($data) if ($options->{php});
346	joko	1.2
347			# utf8-conversion/-encoding (essential for I18N)
348	jonen	1.15	utf8_to_latin($data) if ($options->{utf8});
349	joko	1.2
350			# get fresh object from database
351			# todo:
352			# - handle "locked" objects !!!
353			# - check if already another update occoured (object-revisioning needed!)
354			#my $obj = $self->getObject($oid);
355
356			# mix changes into fresh object and save it back
357	joko	1.10	_hash2object_traverse_mixin($object, $data, 0, $options);
358	joko	1.2
359			# done in core mixin function?
360			#$self->{storage}->update($obj);
361
362			# we should "undef" some objects here to destroy them in memory and enforce reloading when used next time
363			# simulate:
364			#$self->{storage}->disconnect();
365
366			}
367
368			# ------------------------------------
369			# core mixin function
370			# TODO-FEATURE: make this possible in a reverse way: object is empty (no fields) and gets filled up by mixin-data
371
372			# remember keys of structures we are traversing
373			# this is a HACK:
374			# - don't (!!!) "packageglobal" @indexstack
375			# - it will lead to problems with parallelism!
376
377			#my @indexstack;
378
379			# traverse a deeply nested structure, mix in values from given hash, update underlying tangram-object
380	joko	1.10	sub _hash2object_traverse_mixin {
381	joko	1.2	my $object = shift;
382			my $data = shift;
383			my $bool_recursion = shift;
384	joko	1.5	my $options = shift;
385	joko	1.2
386			# clear our key - stack if we are called from user-code (non-recursively)
387			@indexstack = () if (!$bool_recursion);
388
389			my $classname = ref $object;
390			# if ($classname) {
391			# print STDERR "*****************", Dumper(Class::Tangram::attribute_types($classname)), "\n";
392			# }
393
394			# parser: detected OBJECT (a Tangram one?) (reftype == HASH) (assume)
395			# what's exactly done here? hmmm.... it works ;)
396			# maybe a HACK: please try not to use "IntrHash"es, maybe this cannot handle them!!!
397			# extend! check!
398	joko	1.10
399			#print attributes::reftype($object), "\n";
400
401			# V1
402			#if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) {
403			# V2
404			my $reftype = attributes::reftype($object);
405			#print "reftype: '$reftype'", "\n";
406			if ($reftype eq 'HASH') {
407	joko	1.2
408			# print STDERR "===", "reftype: ", attributes::reftype($obj), "\n";
409
410	joko	1.5	my @fields;
411	joko	1.2	# loop through fields of object (Tangram-object)
412	joko	1.5	@fields = keys %{$object};
413
414			# loop through fields of to.be.injected-data (arbitrary Perl-data-structure)
415			@fields = keys %{$data} if $options->{init};
416	jonen	1.6	# @fields = keys %{$data} if $options->{mixin};
417	joko	1.5
418			foreach (@fields) {
419	joko	1.7	my $field = $_;
420			push @indexstack, $field;
421	joko	1.2
422			# determine type of object
423	joko	1.7	my $ref = ref $object->{$field};
424	joko	1.2	# print STDERR "attrname: $_ ATTRref: $ref", "\n";
425			if ($ref) {
426	joko	1.10	_hash2object_traverse_mixin($object->{$field}, $data, 1, $options);
427	joko	1.2	} else {
428	joko	1.10	my $val = ref_slot($data, \@indexstack);
429	joko	1.7
430	joko	1.8	#print Dumper($options);
431	joko	1.7	my $field_target = $field;
432			if (my $pattern = $options->{pattern_strip_key}) {
433			print "pattern: $pattern", "\n";
434			$field_target =~ s/$pattern//;
435			print "field: $field_target", "\n";
436			}
437
438			$object->{$field_target} = $val if defined $val;
439	joko	1.2	}
440			pop @indexstack;
441			}
442
443			# save object to database ...
444			# ... do an update if it already exists, do an insert if it doesn't
445			# my $objectId = $self->{storage}->id($obj);
446			# $logger->debug( __PACKAGE__ . "->saveObjectFromHash_traverse_mixin_update( object $obj objectId $objectId )" );
447			# if ($objectId) {
448			# $self->{storage}->update($obj);
449
450			#print __PACKAGE__ . ":", "\n";
451			#print Dumper($object);
452
453			# } else {
454			# $self->{storage}->insert($obj);
455			# }
456
457			}
458
459			#&& ( ref($obj) ne 'HASH' )
460
461			# loop through entries of array (IntrArray, isn't it?)
462			if ((ref $object) eq 'ARRAY') {
463			# print STDERR "===", "refttype ", attributes::reftype($obj), "\n";
464			my $i = 0;
465			foreach (@{$object}) {
466			push @indexstack, $i;
467			my $ref = ref $_;
468			# print STDERR "attrname: $_ ATTRref: $ref", "\n";
469	jonen	1.6	# if ($ref && $_) {
470			if ($ref) {
471	joko	1.10	_hash2object_traverse_mixin($_, $data, 1, $options);
472	joko	1.2	} else {
473	jonen	1.6	$object->[$i] = $_ if defined $_;
474	joko	1.2	}
475			pop @indexstack;
476			$i++;
477			}
478	joko	1.10
479			=pod
480			# object?
481			} else {
482			print "reference: ", ref $object, "\n";
483			print "reftype: ", $reftype, "\n";
484			die(__PACKAGE__ . "->_hash2object_traverse_mixin: can not handle this!");
485			=cut
486
487	joko	1.2	}
488
489			}
490
491
492	joko	1.10	# ACK's go to Randal L. Schwartz <merlyn@stonehenge.com>
493			# on the website:
494			# This text is copyright by Miller-Freeman, Inc., and is used with their permission.
495			# Further distribution or use is not permitted.
496			# please visit http://www.stonehenge.com/merlyn/UnixReview/col30.html
497			sub deep_copy1 {
498			my $this = shift;
499			if (not ref $this) {
500			$this;
501			} elsif (ref $this eq "ARRAY") {
502			[map deep_copy1($_), @$this];
503			} elsif (ref $this eq "HASH") {
504			+{map { $_ => deep_copy1($this->{$_}) } keys %$this};
505			} elsif (ref $this eq "CODE") {
506			$this;
507			} else { die "deep_copy1 asks: what type is $this?" }
508			#} else { print "deep_copy asks: what type is $this?", "\n"; }
509	joko	1.2	}
510
511	joko	1.10	# ACK's go to Andrew Pitonyak
512			# Copyright 2002, Andrew Pitonyak (perlboy@pitonyak.org)
513			# please visit: http://www.pitonyak.org/code/perl/Pitonyak/DeepCopy.pm.html
514	joko	1.7	sub deep_copy {
515	joko	1.12	Pitonyak::DeepCopy::deep_copy(@_);
516	joko	1.1	}
517	joko	1.12
518	joko	1.1
519			1;
520	joko	1.10	__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26