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