/[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.2 by joko, Sun Dec 1 04:44:07 2002 UTC revision 1.5 by joko, Mon Dec 16 19:57:54 2002 UTC
# Line 3  Line 3 
3  #  $Id$  #  $Id$
4  #  #
5  #  $Log$  #  $Log$
6    #  Revision 1.5  2002/12/16 19:57:54  joko
7    #  + option 'init'
8    #
9    #  Revision 1.4  2002/12/05 13:56:49  joko
10    #  - var_deref
11    #  + expand - more sophisticated dereferencing with callbacks using Iterate
12    #
13    #  Revision 1.3  2002/12/03 05:34:55  joko
14    #  + bugfix: now utilizing var_utf2iso from Data::Transform::Encode
15    #
16  #  Revision 1.2  2002/12/01 04:44:07  joko  #  Revision 1.2  2002/12/01 04:44:07  joko
17  #  + code from Data::Transform::OO  #  + code from Data::Transform::OO
18  #  #
# Line 24  require Exporter; Line 34  require Exporter;
34  our @ISA = qw( Exporter );  our @ISA = qw( Exporter );
35  our @EXPORT_OK = qw(  our @EXPORT_OK = qw(
36    &var_NumericalHashToArray    &var_NumericalHashToArray
   &var_deref  
37    &var_mixin    &var_mixin
38    &object2hash    &object2hash
39    &hash2object    &hash2object
40    &refexpr2perlref    &refexpr2perlref
41      &expand
42  );  );
43    #  &var_deref
44  #  &getStructSlotByStringyAddress  #  &getStructSlotByStringyAddress
45    
46  use attributes;  use attributes;
47  use Data::Dumper;  use Data::Dumper;
48    use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 );
49    use libp qw( deep_copy );
50    use Iterate;
51    
52  sub var_NumericalHashToArray {  sub var_NumericalHashToArray {
53    my $vref = shift;    my $vref = shift;
# Line 64  sub var_NumericalHashToArray { Line 77  sub var_NumericalHashToArray {
77    
78  sub var_deref {  sub var_deref {
79    my $obj = shift;    my $obj = shift;
80      my $options = shift;
81    my $result;    my $result;
82    if ((ref $obj) eq 'ARRAY') {    if ((ref $obj) eq 'ARRAY') {
83      foreach (@{$obj}) {      foreach (@{$obj}) {
84        my $ref = ref $_;        my $ref = ref $_;
85        if ($ref) {        if ($ref) {
86          push(@{$result}, var_deref($_));          push(@{$result}, var_deref($_, $options));
87            #undef $_;
88        } else {        } else {
89          push(@{$result}, $_);          #push(@{$result}, $_);
90            push(@{$result}, deep_copy($_));
91        }        }
92          #undef $_ if $options->{destroy};
93          #$options->{destroy}->($_) if $options->{destroy};
94      }      }
95    # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???    # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
96    } else {    } else {
# Line 80  sub var_deref { Line 98  sub var_deref {
98        my $key = $_;        my $key = $_;
99        my $ref = ref $obj->{$_};        my $ref = ref $obj->{$_};
100        if ($ref) {        if ($ref) {
101          $result->{$_} = var_deref($obj->{$_});          $result->{$_} = var_deref($obj->{$_}, $options);
102            #undef $obj->{$_};
103        } else {        } else {
104          $result->{$_} = $obj->{$_};          #$result->{$_} = $obj->{$_};
105            $result->{$_} = deep_copy($obj->{$_});
106        }        }
107          #undef $obj->{$_} if $options->{destroy};
108          #$options->{destroy}->($obj->{$_}) if $options->{destroy};
109      }      }
110    }    }
111      #undef $obj if $options->{destroy};
112      $options->{cb_destroy}->($obj) if $options->{cb_destroy};
113    return $result;    return $result;
114  }  }
115    
116    
117    sub expand {
118    
119      my $obj = shift;
120      my $options = shift;
121      my $result;
122    
123      if ((ref $obj) eq 'ARRAY') {
124    
125        IterArray @$obj, sub {
126          my $item;
127          # if current item is a reference ...
128          if (ref $_[0]) {
129            # ... expand structure recursively
130            $item = expand($_[0], $options);
131            # destroy item via seperate callback method (a POST) if requested
132            #$options->{cb}->{destroy}->($_[0]) if $options->{destroy};
133    
134          # ... assume plain scalar
135          } else {
136            #$item = deep_copy($_[0]);
137            $item = $_[0];
138            # conversions/encodings
139            $item = scalar2utf8($item) if ($item && $options->{utf8});
140          }
141          #push(@{$result}, $item) if $item;   # use item only if not undef  (TODO: make configurable via $options)
142          push(@{$result}, $item);                 # use item in any case
143    
144        }
145    
146      # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
147      } else {
148    
149        IterHash %$obj, sub {
150          my $item;
151          
152          # if current item is a reference ...
153          if (ref $_[1]) {
154            # ... expand structure recursively
155            $item = expand($_[1], $options);
156            # destroy item via seperate callback method (a POST) if requested
157            #$options->{cb}->{destroy}->($_[1]) if $options->{destroy};
158          
159          # ... assume plain scalar
160          } else {
161            #$item = deep_copy($_[1]);
162            $item = $_[1];
163            # conversions/encodings
164            $item = scalar2utf8($item) if ($item && $options->{utf8});
165          }
166          #$result->{$_[0]} = $item if $item;   # use item only if not undef  (TODO: make configurable via $options)
167          $result->{$_[0]} = $item;               # use item in any case
168        }
169    
170      }
171    
172      # convert all values to utf8 (inside complex struct)
173        # now done in core-item-callbacks via Greg London's "Iterate" from CPAN
174        # var2utf8($result) if ($options->{utf8});
175    
176      # destroy persistent object from memory to be sure to get a fresh one next time
177      #undef $obj if $options->{destroy};
178      #$options->{cb_destroy}->($obj) if $options->{cb_destroy};
179      #$options->{cb}->{destroy}->($obj) if $options->{destroy};
180      
181      return $result;
182    }
183    
184    
185    
186  my @indexstack;  my @indexstack;
# Line 140  sub var_traverse_mixin_update { Line 231  sub var_traverse_mixin_update {
231  sub object2hash {  sub object2hash {
232    my $object = shift;    my $object = shift;
233    my $options = shift;    my $options = shift;
234    my $deref = var_deref($object);    #my $deref = var_deref($object);
235    var2utf8($deref) if ($options->{utf8});    my $deref = expand($object, $options);
236      #var2utf8($deref) if ($options->{utf8});
237    return $deref;    return $deref;
238  }  }
239    
# Line 151  sub hash2object { Line 243  sub hash2object {
243    my $data = shift;    my $data = shift;
244    my $options = shift;    my $options = shift;
245    
246      #print "hash2object", "\n";
247      
248    # "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,    # "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,
249    # this method corrects this    # this method corrects this
250    var_NumericalHashToArray($data) if ($options->{php});    var_NumericalHashToArray($data) if ($options->{php});
# Line 165  sub hash2object { Line 259  sub hash2object {
259    #my $obj = $self->getObject($oid);    #my $obj = $self->getObject($oid);
260    
261    # mix changes into fresh object and save it back    # mix changes into fresh object and save it back
262    hash2object_traverse_mixin($object, $data);    hash2object_traverse_mixin($object, $data, 0, $options);
263    
264    # done in core mixin function?    # done in core mixin function?
265    #$self->{storage}->update($obj);    #$self->{storage}->update($obj);
# Line 192  sub hash2object_traverse_mixin { Line 286  sub hash2object_traverse_mixin {
286    my $object = shift;    my $object = shift;
287    my $data = shift;    my $data = shift;
288    my $bool_recursion = shift;    my $bool_recursion = shift;
289      my $options = shift;
290    
291    # clear our key - stack if we are called from user-code (non-recursively)    # clear our key - stack if we are called from user-code (non-recursively)
292    @indexstack = () if (!$bool_recursion);    @indexstack = () if (!$bool_recursion);
# Line 209  sub hash2object_traverse_mixin { Line 304  sub hash2object_traverse_mixin {
304    
305  #    print STDERR "===", "reftype: ", attributes::reftype($obj), "\n";  #    print STDERR "===", "reftype: ", attributes::reftype($obj), "\n";
306                    
307        my @fields;
308      # loop through fields of object (Tangram-object)      # loop through fields of object (Tangram-object)
309      foreach (keys %{$object}) {      @fields = keys %{$object};
310    
311        # loop through fields of to.be.injected-data (arbitrary Perl-data-structure)
312        @fields = keys %{$data} if $options->{init};
313        
314        foreach (@fields) {
315        push @indexstack, $_;        push @indexstack, $_;
316                            
317        # determine type of object        # determine type of object
318        my $ref = ref $object->{$_};        my $ref = ref $object->{$_};
319  #      print STDERR "attrname: $_  ATTRref: $ref", "\n";  #      print STDERR "attrname: $_  ATTRref: $ref", "\n";
320        if ($ref) {        if ($ref) {
321          hash2object_traverse_mixin($object->{$_}, $data, 1);          hash2object_traverse_mixin($object->{$_}, $data, 1, $options);
322        } else {        } else {
323          my $val = getStructSlotByStringyAddress($data, \@indexstack);          my $val = getStructSlotByStringyAddress($data, \@indexstack);
324          $object->{$_} = $val;                  $object->{$_} = $val;        
# Line 252  sub hash2object_traverse_mixin { Line 353  sub hash2object_traverse_mixin {
353        my $ref = ref $_;        my $ref = ref $_;
354  #      print STDERR "attrname: $_  ATTRref: $ref", "\n";  #      print STDERR "attrname: $_  ATTRref: $ref", "\n";
355        if ($ref && $_) {        if ($ref && $_) {
356          hash2object_traverse_mixin($_, $data, 1);          hash2object_traverse_mixin($_, $data, 1, $options);
357        } else {        } else {
358          $object->[$i] = $_;          $object->[$i] = $_;
359        }        }
# Line 265  sub hash2object_traverse_mixin { Line 366  sub hash2object_traverse_mixin {
366    
367    
368  # this function seems to do similar stuff like these below (refexpr2perlref & co.)  # this function seems to do similar stuff like these below (refexpr2perlref & co.)
369    # TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ?   ;-)
370  sub getStructSlotByStringyAddress {  sub getStructSlotByStringyAddress {
371    my $var = shift;    my $var = shift;
372    my $indexstack_ref = shift;    my $indexstack_ref = shift;
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.5
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed