Mungle/Transform/Deep.pm

## ---------------------------------------------------------------------------
##  $Id: Deep.pm,v 1.9 2003/02/18 19:35:56 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: Deep.pm,v $
##  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::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 Data::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar );
use Data::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;
}


sub expand {

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

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

  if (ref $obj eq 'ARRAY') {

    IterArray @$obj, sub {
      my $item;
      # if current item is a reference ...
      if (ref $_[0]) {
        # ... 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});
      }
      #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) {

    IterHash %$obj, sub {
      my $item;
      
      # if current item is a reference ...
      if (ref $_[1]) {
        # ... 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});
      }
      #$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
    # var2utf8($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".
}


# 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)
  var_utf2iso($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_copy2 {

    # if not defined then return it
    return undef if $#_ < 0 || !defined( $_[0] );

    # if not a reference then return the parameter
    return $_[0] if !ref( $_[0] );
    my $obj = shift;
    if ( UNIVERSAL::isa( $obj, 'SCALAR' ) ) {
        my $temp = deep_copy2($$obj);
        return \$temp;
    }
    elsif ( UNIVERSAL::isa( $obj, 'HASH' ) ) {
        my $temp_hash = {};
        foreach my $key ( keys %$obj ) {
            if ( !defined( $obj->{$key} ) || !ref( $obj->{$key} ) ) {
                $temp_hash->{$key} = $obj->{$key};
            }
            else {
                $temp_hash->{$key} = deep_copy2( $obj->{$key} );
            }
        }
        return $temp_hash;
    }
    elsif ( UNIVERSAL::isa( $obj, 'ARRAY' ) ) {
        my $temp_array = [];
        foreach my $array_val (@$obj) {
            if ( !defined($array_val) || !ref($array_val) ) {
                push ( @$temp_array, $array_val );
            }
            else {
                push ( @$temp_array, deep_copy2($array_val) );
            }
        }
        return $temp_array;
    }

    # ?? I am uncertain about this one
    elsif ( UNIVERSAL::isa( $obj, 'REF' ) ) {
        my $temp = deep_copy2($$obj);
        return \$temp;
    }

    # I guess that it is either CODE, GLOB or LVALUE
    else {
        return $obj;
    }
}

sub deep_copy {
  deep_copy2(@_);
}

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