/[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.3 by joko, Tue Dec 3 05:34:55 2002 UTC revision 1.4 by joko, Thu Dec 5 13:56:49 2002 UTC
# Line 3  Line 3 
3  #  $Id$  #  $Id$
4  #  #
5  #  $Log$  #  $Log$
6    #  Revision 1.4  2002/12/05 13:56:49  joko
7    #  - var_deref
8    #  + expand - more sophisticated dereferencing with callbacks using Iterate
9    #
10  #  Revision 1.3  2002/12/03 05:34:55  joko  #  Revision 1.3  2002/12/03 05:34:55  joko
11  #  + bugfix: now utilizing var_utf2iso from Data::Transform::Encode  #  + bugfix: now utilizing var_utf2iso from Data::Transform::Encode
12  #  #
# Line 27  require Exporter; Line 31  require Exporter;
31  our @ISA = qw( Exporter );  our @ISA = qw( Exporter );
32  our @EXPORT_OK = qw(  our @EXPORT_OK = qw(
33    &var_NumericalHashToArray    &var_NumericalHashToArray
   &var_deref  
34    &var_mixin    &var_mixin
35    &object2hash    &object2hash
36    &hash2object    &hash2object
37    &refexpr2perlref    &refexpr2perlref
38      &expand
39  );  );
40    #  &var_deref
41  #  &getStructSlotByStringyAddress  #  &getStructSlotByStringyAddress
42    
43  use attributes;  use attributes;
44  use Data::Dumper;  use Data::Dumper;
45  use Data::Transform::Encode qw( var_utf2iso );  use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 );
46    use libp qw( deep_copy );
47    use Iterate;
48    
49  sub var_NumericalHashToArray {  sub var_NumericalHashToArray {
50    my $vref = shift;    my $vref = shift;
# Line 67  sub var_NumericalHashToArray { Line 74  sub var_NumericalHashToArray {
74    
75  sub var_deref {  sub var_deref {
76    my $obj = shift;    my $obj = shift;
77      my $options = shift;
78    my $result;    my $result;
79    if ((ref $obj) eq 'ARRAY') {    if ((ref $obj) eq 'ARRAY') {
80      foreach (@{$obj}) {      foreach (@{$obj}) {
81        my $ref = ref $_;        my $ref = ref $_;
82        if ($ref) {        if ($ref) {
83          push(@{$result}, var_deref($_));          push(@{$result}, var_deref($_, $options));
84            #undef $_;
85        } else {        } else {
86          push(@{$result}, $_);          #push(@{$result}, $_);
87            push(@{$result}, deep_copy($_));
88        }        }
89          #undef $_ if $options->{destroy};
90          #$options->{destroy}->($_) if $options->{destroy};
91      }      }
92    # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???    # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
93    } else {    } else {
# Line 83  sub var_deref { Line 95  sub var_deref {
95        my $key = $_;        my $key = $_;
96        my $ref = ref $obj->{$_};        my $ref = ref $obj->{$_};
97        if ($ref) {        if ($ref) {
98          $result->{$_} = var_deref($obj->{$_});          $result->{$_} = var_deref($obj->{$_}, $options);
99            #undef $obj->{$_};
100        } else {        } else {
101          $result->{$_} = $obj->{$_};          #$result->{$_} = $obj->{$_};
102            $result->{$_} = deep_copy($obj->{$_});
103        }        }
104          #undef $obj->{$_} if $options->{destroy};
105          #$options->{destroy}->($obj->{$_}) if $options->{destroy};
106      }      }
107    }    }
108      #undef $obj if $options->{destroy};
109      $options->{cb_destroy}->($obj) if $options->{cb_destroy};
110    return $result;    return $result;
111  }  }
112    
113    
114    sub expand {
115    
116      my $obj = shift;
117      my $options = shift;
118      my $result;
119    
120      if ((ref $obj) eq 'ARRAY') {
121    
122        IterArray @$obj, sub {
123          my $item;
124          # if current item is a reference ...
125          if (ref $_[0]) {
126            # ... expand structure recursively
127            $item = expand($_[0], $options);
128            # destroy item via seperate callback method (a POST) if requested
129            #$options->{cb}->{destroy}->($_[0]) if $options->{destroy};
130    
131          # ... assume plain scalar
132          } else {
133            #$item = deep_copy($_[0]);
134            $item = $_[0];
135            # conversions/encodings
136            $item = scalar2utf8($item) if ($item && $options->{utf8});
137          }
138          #push(@{$result}, $item) if $item;   # use item only if not undef  (TODO: make configurable via $options)
139          push(@{$result}, $item);                 # use item in any case
140    
141        }
142    
143      # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
144      } else {
145    
146        IterHash %$obj, sub {
147          my $item;
148          
149          # if current item is a reference ...
150          if (ref $_[1]) {
151            # ... expand structure recursively
152            $item = expand($_[1], $options);
153            # destroy item via seperate callback method (a POST) if requested
154            #$options->{cb}->{destroy}->($_[1]) if $options->{destroy};
155          
156          # ... assume plain scalar
157          } else {
158            #$item = deep_copy($_[1]);
159            $item = $_[1];
160            # conversions/encodings
161            $item = scalar2utf8($item) if ($item && $options->{utf8});
162          }
163          #$result->{$_[0]} = $item if $item;   # use item only if not undef  (TODO: make configurable via $options)
164          $result->{$_[0]} = $item;               # use item in any case
165        }
166    
167      }
168    
169      # convert all values to utf8 (inside complex struct)
170        # now done in core-item-callbacks via Greg London's "Iterate" from CPAN
171        # var2utf8($result) if ($options->{utf8});
172    
173      # destroy persistent object from memory to be sure to get a fresh one next time
174      #undef $obj if $options->{destroy};
175      #$options->{cb_destroy}->($obj) if $options->{cb_destroy};
176      #$options->{cb}->{destroy}->($obj) if $options->{destroy};
177      
178      return $result;
179    }
180    
181    
182    
183  my @indexstack;  my @indexstack;
# Line 143  sub var_traverse_mixin_update { Line 228  sub var_traverse_mixin_update {
228  sub object2hash {  sub object2hash {
229    my $object = shift;    my $object = shift;
230    my $options = shift;    my $options = shift;
231    my $deref = var_deref($object);    #my $deref = var_deref($object);
232    var2utf8($deref) if ($options->{utf8});    my $deref = expand($object, $options);
233      #var2utf8($deref) if ($options->{utf8});
234    return $deref;    return $deref;
235  }  }
236    
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed