2 |
## $Id$ |
## $Id$ |
3 |
## --------------------------------------------------------------------------- |
## --------------------------------------------------------------------------- |
4 |
## $Log$ |
## $Log$ |
5 |
|
## Revision 1.14 2003/02/22 17:13:55 jonen |
6 |
|
## + added function 'childObject2string()' to encode 'child'-references to option related string |
7 |
|
## + use new option at 'expand()' for replacing 'childObject2string' |
8 |
|
## |
9 |
|
## Revision 1.13 2003/02/21 01:48:50 joko |
10 |
|
## renamed core function |
11 |
|
## |
12 |
|
## Revision 1.12 2003/02/20 22:45:19 joko |
13 |
|
## fix regarding new deep_copy |
14 |
|
## |
15 |
|
## Revision 1.11 2003/02/20 21:13:54 joko |
16 |
|
## - removed implementation of deep_copy2 - get this from the Pitonyak namespace (now cloned to repository) |
17 |
|
## |
18 |
## Revision 1.10 2003/02/20 20:48:00 joko |
## Revision 1.10 2003/02/20 20:48:00 joko |
19 |
## - refactored lots of code to Data::Code::Ref |
## - refactored lots of code to Data::Code::Ref |
20 |
## + alternative 'deep_copy' implementation |
## + alternative 'deep_copy' implementation |
71 |
use Data::Dumper; |
use Data::Dumper; |
72 |
use Iterate; |
use Iterate; |
73 |
|
|
74 |
|
use Pitonyak::DeepCopy; |
75 |
use Data::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar ); |
use Data::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar ); |
76 |
use Data::Code::Ref qw( ref_slot ); |
use Data::Code::Ref qw( ref_slot ); |
77 |
|
|
143 |
} |
} |
144 |
|
|
145 |
|
|
146 |
|
# convert values in hash to utf8 (and back) to be ready for (e.g.) encapsulation in XML |
147 |
|
# but still using the known latin locale stuff |
148 |
sub expand { |
sub expand { |
149 |
|
|
150 |
my $obj = shift; |
my $obj = shift; |
159 |
my $item; |
my $item; |
160 |
# if current item is a reference ... |
# if current item is a reference ... |
161 |
if (ref $_[0]) { |
if (ref $_[0]) { |
162 |
# ... expand structure recursively |
$item = $_[0]; |
163 |
$item = expand($_[0], $options); |
# if $options->{childObj2string} is TRUE or STRING don't expand referenced object, |
164 |
|
# instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) |
165 |
|
if ($item && $options->{childObj2string}) { |
166 |
|
$item = childObj2string($item, $options->{childObj2string}); |
167 |
|
} else { |
168 |
|
# ... expand structure recursively |
169 |
|
$item = expand($_[0], $options); |
170 |
|
} |
171 |
# destroy item via seperate callback method (a POST) if requested |
# destroy item via seperate callback method (a POST) if requested |
172 |
#$options->{cb}->{destroy}->($_[0]) if $options->{destroy}; |
#$options->{cb}->{destroy}->($_[0]) if $options->{destroy}; |
173 |
|
|
196 |
|
|
197 |
# if current item is a reference ... |
# if current item is a reference ... |
198 |
if (ref $_[1]) { |
if (ref $_[1]) { |
199 |
# ... expand structure recursively |
$item = $_[1]; |
200 |
$item = expand($_[1], $options); |
# if $options->{childObj2string} is TRUE or STRING don't expand referenced object, |
201 |
|
# instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) |
202 |
|
if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH")) { |
203 |
|
$item = childObj2string($item, $options->{childObj2string}); |
204 |
|
} else { |
205 |
|
# ... expand structure recursively |
206 |
|
$item = expand($_[1], $options); |
207 |
|
} |
208 |
# destroy item via seperate callback method (a POST) if requested |
# destroy item via seperate callback method (a POST) if requested |
209 |
#$options->{cb}->{destroy}->($_[1]) if $options->{destroy}; |
#$options->{cb}->{destroy}->($_[1]) if $options->{destroy}; |
210 |
|
|
228 |
|
|
229 |
# convert all values to utf8 (inside complex struct) |
# convert all values to utf8 (inside complex struct) |
230 |
# now done in core-item-callbacks via Greg London's "Iterate" from CPAN |
# now done in core-item-callbacks via Greg London's "Iterate" from CPAN |
231 |
# var2utf8($result) if ($options->{utf8}); |
# latin_to_utf8($result) if ($options->{utf8}); |
232 |
|
|
233 |
# destroy persistent object from memory to be sure to get a fresh one next time |
# destroy persistent object from memory to be sure to get a fresh one next time |
234 |
#undef $obj if $options->{destroy}; |
#undef $obj if $options->{destroy}; |
471 |
# ACK's go to Andrew Pitonyak |
# ACK's go to Andrew Pitonyak |
472 |
# Copyright 2002, Andrew Pitonyak (perlboy@pitonyak.org) |
# Copyright 2002, Andrew Pitonyak (perlboy@pitonyak.org) |
473 |
# please visit: http://www.pitonyak.org/code/perl/Pitonyak/DeepCopy.pm.html |
# please visit: http://www.pitonyak.org/code/perl/Pitonyak/DeepCopy.pm.html |
474 |
sub deep_copy2 { |
sub deep_copy { |
475 |
|
Pitonyak::DeepCopy::deep_copy(@_); |
476 |
# 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; |
|
|
} |
|
477 |
|
|
|
# ?? I am uncertain about this one |
|
|
elsif ( UNIVERSAL::isa( $obj, 'REF' ) ) { |
|
|
my $temp = deep_copy2($$obj); |
|
|
return \$temp; |
|
|
} |
|
478 |
|
|
479 |
# I guess that it is either CODE, GLOB or LVALUE |
sub childObj2string { |
480 |
else { |
my $obj = shift; |
481 |
return $obj; |
my $option = shift; |
482 |
} |
my $classname = ref $obj; |
483 |
|
|
484 |
|
if($option == 1) { |
485 |
|
my $string = "o_" . $classname . "_" .$obj->{guid}; |
486 |
|
return $string; |
487 |
|
} |
488 |
} |
} |
489 |
|
|
|
sub deep_copy { |
|
|
deep_copy2(@_); |
|
|
} |
|
490 |
|
|
491 |
1; |
1; |
492 |
__END__ |
__END__ |