/[cvs]/nfo/perl/libs/Data/Mungle/Transform/Deep.pm
ViewVC logotype

Diff of /nfo/perl/libs/Data/Mungle/Transform/Deep.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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