Clone-PP-1.02004075500007650000120000000000000772344230300121515ustar00simonmadminClone-PP-1.02/Makefile.PL010064400007650000120000000001470772200420700141750ustar00simonmadminuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Clone::PP', 'VERSION_FROM' => 'PP.pm', ); Clone-PP-1.02/MANIFEST010064400007650000120000000002100772330102700133440ustar00simonmadminMANIFEST Makefile.PL PP.pm t/01array.t t/02hash.t t/03scalar.t t/04tie.t t/05dtype.t t/06refcnt.t t/dclone.t t/dump.pl t/tied.pl README Clone-PP-1.02/PP.pm010064400007650000120000000131730772344226000131110ustar00simonmadminpackage Clone::PP; use strict; use vars qw($VERSION @EXPORT_OK); use Exporter; $VERSION = 1.02; @EXPORT_OK = qw( clone ); sub import { goto &Exporter::import } # lazy Exporter # These methods can be temporarily overriden to work with a given class. use vars qw( $CloneSelfMethod $CloneInitMethod ); $CloneSelfMethod ||= 'clone_self'; $CloneInitMethod ||= 'clone_init'; # Used to detect looped networks and avoid infinite recursion. use vars qw( %CloneCache ); # Generic cloning function sub clone { my $source = shift; # Optional depth limit: after a given number of levels, do shallow copy. my $depth = shift; return $source if ( defined $depth and $depth -- < 1 ); # Maintain a shared cache during recursive calls, then clear it at the end. local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} ); return $CloneCache{ $source } if ( exists $CloneCache{ $source } ); # Non-reference values are copied shallowly my $ref_type = ref $source or return $source; # Extract both the structure type and the class name of referent my $class_name; if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) { $class_name = $ref_type; $ref_type = $1; # Some objects would prefer to clone themselves; check for clone_self(). return $CloneCache{ $source } = $source->$CloneSelfMethod() if $source->can($CloneSelfMethod); } # To make a copy: # - Prepare a reference to the same type of structure; # - Store it in the cache, to avoid looping it it refers to itself; # - Tie in to the same class as the original, if it was tied; # - Assign a value to the reference by cloning each item in the original; my $copy; if ($ref_type eq 'HASH') { $CloneCache{ $source } = $copy = {}; if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied } %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source; } elsif ($ref_type eq 'ARRAY') { $CloneCache{ $source } = $copy = []; if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied } @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source; } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') { $CloneCache{ $source } = $copy = \( my $var = "" ); if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied } $$copy = clone($$source, $depth); } else { # Shallow copy anything else; this handles a reference to code, glob, regex $CloneCache{ $source } = $copy = $source; } # - Bless it into the same class as the original, if it was blessed; # - If it has a post-cloning initialization method, call it. if ( $class_name ) { bless $copy, $class_name; $copy->$CloneInitMethod() if $copy->can($CloneInitMethod); } return $copy; } 1; __END__ =head1 NAME Clone::PP - Recursively copy Perl datatypes =head1 SYNOPSIS use Clone::PP qw(clone); $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ] }; $copy = clone( $item ); $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ]; $copy = clone( $item ); $item = Foo->new(); $copy = clone( $item ); Or as an object method: require Clone::PP; push @Foo::ISA, 'Clone::PP'; $item = Foo->new(); $copy = $item->clone(); =head1 DESCRIPTION This module provides a general-purpose clone function to make deep copies of Perl data structures. It calls itself recursively to copy nested hash, array, scalar and reference types, including tied variables and objects. The clone() function takes a scalar argument to copy. To duplicate arrays or hashes, pass them in by reference: my $copy = clone(\@array); my @copy = @{ clone(\@array) }; my $copy = clone(\%hash); my %copy = %{ clone(\%hash) }; The clone() function also accepts an optional second parameter that can be used to limit the depth of the copy. If you pass a limit of 0, clone will return the same value you supplied; for a limit of 1, a shallow copy is constructed; for a limit of 2, two layers of copying are done, and so on. my $shallow_copy = clone( $item, 1 ); To allow objects to intervene in the way they are copied, the clone() function checks for a couple of optional methods. If an object provides a method named C, it is called and the result returned without further processing. Alternately, if an object provides a method named C, it is called on the copied object before it is returned. =head1 BUGS Some data types, such as globs, regexes, and code refs, are always copied shallowly. References to hash elements are not properly duplicated. (This is why two tests in t/dclone.t that are marked "todo".) For example, the following test should succeed but does not: my $hash = { foo => 1 }; $hash->{bar} = \{ $hash->{foo} }; my $copy = clone( \%hash ); $hash->{foo} = 2; $copy->{foo} = 2; ok( $hash->{bar} == $copy->{bar} ); To report bugs via the CPAN web tracking system, go to C or send mail to C, replacing C<#> with C<@>. =head1 SEE ALSO For a faster implementation in XS, see L, L, or . =head1 CREDITS AND COPYRIGHT Developed by Matthew Simon Cavalletto at Evolution Softworks. More free Perl software is available at C. Copyright 2003 Matthew Simon Cavalletto. You may contact the author directly at C or C. Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff. Interface based by Clone by Ray Finch with contributions from chocolateboy. Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy. You may use, modify, and distribute this software under the same terms as Perl. =cut Clone-PP-1.02/README010064400007650000120000000062040772344227400131160ustar00simonmadminNAME Clone::PP - Recursively copy Perl datatypes SYNOPSIS use Clone::PP qw(clone); $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ] }; $copy = clone( $item ); $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ]; $copy = clone( $item ); $item = Foo->new(); $copy = clone( $item ); Or as an object method: require Clone::PP; push @Foo::ISA, 'Clone::PP'; $item = Foo->new(); $copy = $item->clone(); DESCRIPTION This module provides a general-purpose clone function to make deep copies of Perl data structures. It calls itself recursively to copy nested hash, array, scalar and reference types, including tied variables and objects. The clone() function takes a scalar argument to copy. To duplicate arrays or hashes, pass them in by reference: my $copy = clone(\@array); my @copy = @{ clone(\@array) }; my $copy = clone(\%hash); my %copy = %{ clone(\%hash) }; The clone() function also accepts an optional second parameter that can be used to limit the depth of the copy. If you pass a limit of 0, clone will return the same value you supplied; for a limit of 1, a shallow copy is constructed; for a limit of 2, two layers of copying are done, and so on. my $shallow_copy = clone( $item, 1 ); To allow objects to intervene in the way they are copied, the clone() function checks for a couple of optional methods. If an object provides a method named "clone_self", it is called and the result returned without further processing. Alternately, if an object provides a method named "clone_init", it is called on the copied object before it is returned. BUGS Some data types, such as globs, regexes, and code refs, are always copied shallowly. References to hash elements are not properly duplicated. (This is why two tests in t/dclone.t that are marked "todo".) For example, the following test should succeed but does not: my $hash = { foo => 1 }; $hash->{bar} = \{ $hash->{foo} }; my $copy = clone( \%hash ); $hash->{foo} = 2; $copy->{foo} = 2; ok( $hash->{bar} == $copy->{bar} ); To report bugs via the CPAN web tracking system, go to "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone-PP" or send mail to "Dist=Clone-PP#rt.cpan.org", replacing "#" with "@". SEE ALSO For a faster implementation in XS, see the clone entry in the Clone manpage, the clone entry in the Util manpage, or . CREDITS AND COPYRIGHT Developed by Matthew Simon Cavalletto at Evolution Softworks. More free Perl software is available at "www.evoscript.org". Copyright 2003 Matthew Simon Cavalletto. You may contact the author directly at "evo@cpan.org" or "simonm@cavalletto.org". Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff. Interface based by Clone by Ray Finch with contributions from chocolateboy. Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy. You may use, modify, and distribute this software under the same terms as Perl. Clone-PP-1.02/t004075500007650000120000000000000772344230300124145ustar00simonmadminClone-PP-1.02/t/01array.t010064400007650000120000000026370772200420700141400ustar00simonmadmin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..6\n"; } END {print "not ok 1\n" unless $loaded;} use Clone::PP qw( clone ); use Data::Dumper; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package Test::Array; use vars @ISA; @ISA = qw(Clone::PP); sub new { my $class = shift; my @self = @_; bless \@self, $class; } package main; sub ok { print "ok $test\n"; $test++ } sub not_ok { print "not ok $test\n"; $test++ } $^W = 0; $test = 2; my $a = Test::Array->new( 1, [ 'two', [ 3, ['four'] ], ], ); my $b = $a->clone(0); my $c = $a->clone(2); # TEST 2 $b->[1][0] eq 'two' ? ok : not_ok; # TEST 3 $b->[1] == $a->[1] ? ok : not_ok; # TEST 4 $c->[1] != $a->[1] ? ok : not_ok; # TEST 5 $c->[1][1][1] == $a->[1][1][1] ? ok : not_ok; my @circ = (); $circ[0] = \@circ; $aref = clone(\@circ); Dumper(\@circ) eq Dumper($aref) ? ok : not_ok; Clone-PP-1.02/t/02hash.t010064400007650000120000000035350772200420700137440ustar00simonmadmin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..11\n"; } END {print "not ok 1\n" unless $loaded;} use Clone::PP qw( clone ); use Data::Dumper; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package Test::Hash; use vars @ISA; @ISA = qw(Clone::PP); sub new { my $class = shift; my %self = @_; bless \%self, $class; } sub DESTROY { my $self = shift; # warn "DESTROYING $self"; } package main; sub ok { print "ok $test\n"; $test++ } sub not_ok { print "not ok $test\n"; $test++ } $^W = 0; $test = 2; my $a = Test::Hash->new( level => 1, href => { level => 2, href => { level => 3, href => { level => 4, }, }, }, ); $a->{a} = $a; my $b = $a->clone(0); my $c = $a->clone(3); $a->{level} == $b->{level} ? ok : not_ok; $b->{href} == $a->{href} ? ok : not_ok; $c->{href} != $a->{href} ? ok : not_ok; $b->{href}{href} == $a->{href}{href} ? ok : not_ok; $c->{href}{href} != $a->{href}{href} ? ok : not_ok; $c->{href}{href}{level} == 3 ? ok : not_ok; $c->{href}{href}{href}{level} == 4 ? ok : not_ok; $b->{href}{href}{href} == $a->{href}{href}{href} ? ok : not_ok; $c->{href}{href}{href} == $a->{href}{href}{href} ? ok : not_ok; my %circ = (); $circ{c} = \%circ; my $cref = clone(\%circ); Dumper(\%circ) eq Dumper($cref) ? ok : not_ok; Clone-PP-1.02/t/03scalar.t010064400007650000120000000025730772200420700142700ustar00simonmadmin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..6\n"; } END {print "not ok 1\n" unless $loaded;} use Clone::PP qw( clone ); use Data::Dumper; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package Test::Scalar; use vars @ISA; @ISA = qw(Clone::PP); sub new { my $class = shift; my $self = shift; bless \$self, $class; } sub DESTROY { my $self = shift; # warn "DESTROYING $self"; } package main; sub ok { print "ok $test\n"; $test++ } sub not_ok { print "not ok $test\n"; $test++ } $^W = 0; $test = 2; my $a = Test::Scalar->new(1.0); my $b = $a->clone(1); $$a == $$b ? ok : not_ok; $a != $b ? ok : not_ok; my $c = \"test 2 scalar"; my $d = Clone::PP::clone($c, 2); $$c == $$d ? ok : not_ok; $c != $d ? ok : not_ok; my $circ = undef; $circ = \$circ; $aref = clone($circ); Dumper($circ) eq Dumper($aref) ? ok : not_ok; Clone-PP-1.02/t/04tie.t010064400007650000120000000023620772200420700136010ustar00simonmadmin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..5\n"; } END {print "not ok 1\n" unless $loaded;} use Clone::PP qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. my $test = 2; require 't/dump.pl'; require 't/tied.pl'; my ($a, @a, %a); tie $a, TIED_SCALAR; tie %a, TIED_HASH; tie @a, TIED_ARRAY; $a{a} = 0; $a{b} = 1; my $b = [\%a, \@a, \$a]; my $c = clone($b); my $d1 = &dump($b); my $d2 = &dump($c); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; my $t1 = tied(%{$b->[0]}); my $t2 = tied(%{$c->[0]}); $d1 = &dump($t1); $d2 = &dump($t2); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; $t1 = tied(@{$b->[1]}); $t2 = tied(@{$c->[1]}); $d1 = &dump($t1); $d2 = &dump($t2); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; $t1 = tied(${$b->[2]}); $t2 = tied(${$c->[2]}); $d1 = &dump($t1); $d2 = &dump($t2); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; Clone-PP-1.02/t/05dtype.t010064400007650000120000000024430772200420700141460ustar00simonmadmin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..2\n"; } END {print "not ok 1\n" unless $loaded;} use Clone::PP; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): use Data::Dumper; eval 'use Storable qw( dclone )'; if ($@) { print "ok 2 # skipping Storable not found\n"; exit; } # use Storable qw( dclone ); $^W = 0; $test = 2; sub ok { printf("ok %d\n", $test++); } sub not_ok { printf("not ok %d\n", $test++); } use strict; package Test::Hash; @Test::Hash::ISA = qw( Clone::PP ); sub new() { my ($class) = @_; my $self = {}; $self->{x} = 0; $self->{x} = {value => 1}; bless $self, $class; } package main; my ($master, $clone1); my $a = Test::Hash->new(); my $b = $a->clone; my $c = dclone($a); Dumper($a, $b) eq Dumper($a, $c) ? ok() : not_ok; # print Dumper($a, $b); # print Dumper($a, $c); Clone-PP-1.02/t/06refcnt.t010064400007650000120000000030710772200420700143010ustar00simonmadmin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..9\n"; } END {print "not ok 1\n" unless $loaded;} use Clone::PP qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): # code to test for memory leaks use Benchmark; use Data::Dumper; # use Storable qw( dclone ); $^W = 0; $test = 2; sub ok { printf("ok %d\n", $test++); } sub not_ok { printf("not ok %d\n", $test++); } use strict; package Test::Hash; @Test::Hash::ISA = qw( Clone::PP ); sub new() { my ($class) = @_; my $self = {}; bless $self, $class; } my $ok = 0; END { $ok = 1; }; sub DESTROY { my $self = shift; printf("not ") if $ok; printf("ok %d\n", $::test++); } package main; { my $a = Test::Hash->new(); my $b = $a->clone; # my $c = dclone($a); } # benchmarking bug { my $a = Test::Hash->new(); my $sref = sub { my $b = clone($a) }; $sref->(); } # test for cloning unblessed ref { my $a = {}; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning unblessed ref { my $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } Clone-PP-1.02/t/dclone.t010064400007650000120000000047060772200420700141240ustar00simonmadmin#!./perl # $Id: dclone.t,v 0.11 2001/07/29 19:31:05 ray Exp $ # # Id: dclone.t,v 0.6.1.1 2000/03/02 22:21:05 ram Exp # # Copyright (c) 1995-1998, Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # $Log: dclone.t,v $ # Revision 0.11 2001/07/29 19:31:05 ray # VERSION 0.11 # # Revision 0.10.2.1 2001/07/28 21:47:49 ray # commented out print statements. # # Revision 0.10 2001/04/29 21:56:10 ray # VERSION 0.10 # # Revision 0.9 2001/03/05 00:11:49 ray # version 0.9 # # Revision 0.9 2000/08/21 23:06:34 ray # added support for code refs # # Revision 0.8 2000/08/11 17:08:36 ray # Release 0.08. # # Revision 0.7 2000/08/01 00:31:42 ray # release 0.07 # # Revision 0.6 2000/07/28 21:37:20 ray # "borrowed" code from Storable # # Revision 0.6.1.1 2000/03/02 22:21:05 ram # patch9: added test case for "undef" bug in hashes # # Revision 0.6 1998/06/04 16:08:25 ram # Baseline for first beta release. # require 't/dump.pl'; # use Storable qw(dclone); use Clone::PP qw(clone); print "1..9\n"; $a = 'toto'; $b = \$a; $c = bless {}, CLASS; $c->{attribute} = 'attrval'; %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $b, \$a, $a, $c, \$c, \%a); print "not " unless defined ($aref = clone(\@a)); print "ok 1\n"; $dumped = &dump(\@a); print "ok 2\n"; $got = &dump($aref); print "ok 3\n"; # print $got; # print $dumped; # print $_, "\n" for (@a); # print $_, "\n" foreach (@$aref); print "not " unless $got eq $dumped; print "ok 4\n"; package FOO; @ISA = qw(Clone::PP); sub make { my $self = bless {}; $self->{key} = \%main::a; return $self; }; package main; $foo = FOO->make; print "not " unless defined($r = $foo->clone); print "ok 5\n"; # print &dump($foo); # print &dump($r); print "not " unless &dump($foo) eq &dump($r); print "ok 6\n"; # Ensure refs to "undef" values are properly shared during cloning my $hash; push @{$$hash{''}}, \$$hash{a}; print "not " unless $$hash{''}[0] == \$$hash{a}; print "ok 7\n"; my $cloned = clone(clone($hash)); require Data::Dumper; # warn "Hash: " . ( $$hash{''}[0] ) . " : " . ( \$$hash{a} ) . "\n"; # warn "Copy: " . ( $$cloned{''}[0] ) . " : " . ( \$$cloned{a} ) . "\n"; warn "This test is todo " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 8\n"; $$cloned{a} = "blah"; warn "This test is todo " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 9\n"; Clone-PP-1.02/t/dump.pl010064400007650000120000000072410772200420700137720ustar00simonmadmin;# Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# ;# You may redistribute only under the terms of the Artistic License, ;# as specified in the README file that comes with the distribution. ;# ;# Log: dump.pl,v ;# Revision 0.7 2000/08/03 22:04:45 ram ;# Baseline for second beta release. ;# sub ok { my ($num, $ok) = @_; print "not " unless $ok; print "ok $num\n"; } package dump; use Carp; %dump = ( 'SCALAR' => 'dump_scalar', 'ARRAY' => 'dump_array', 'HASH' => 'dump_hash', 'REF' => 'dump_ref', 'CODE' => 'dump_code', ); # Given an object, dump its transitive data closure sub main'dump { my ($object) = @_; croak "Not a reference!" unless ref($object); local %dumped; local %object; local $count = 0; local $dumped = ''; &recursive_dump($object, 1); return $dumped; } # This is the root recursive dumping routine that may indirectly be # called by one of the routine it calls... # The link parameter is set to false when the reference passed to # the routine is an internal temporay variable, implying the object's # address is not to be dumped in the %dumped table since it's not a # user-visible object. sub recursive_dump { my ($object, $link) = @_; # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...). # Then extract the bless, ref and address parts of that string. my $what = "$object"; # Stringify my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/; ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless; # Special case for references to references. When stringified, # they appear as being scalars. However, ref() correctly pinpoints # them as being references indirections. And that's it. $ref = 'REF' if ref($object) eq 'REF'; # Make sure the object has not been already dumped before. # We don't want to duplicate data. Retrieval will know how to # relink from the previously seen object. if ($link && $dumped{$addr}++) { my $num = $object{$addr}; $dumped .= "OBJECT #$num seen\n"; return; } my $objcount = $count++; $object{$addr} = $objcount; # Call the appropriate dumping routine based on the reference type. # If the referenced was blessed, we bless it once the object is dumped. # The retrieval code will perform the same on the last object retrieved. croak "Unknown simple type '$ref'" unless defined $dump{$ref}; &{$dump{$ref}}($object); # Dump object &bless($bless) if $bless; # Mark it as blessed, if necessary $dumped .= "OBJECT $objcount\n"; } # Indicate that current object is blessed sub bless { my ($class) = @_; $dumped .= "BLESS $class\n"; } # Dump single scalar sub dump_scalar { my ($sref) = @_; my $scalar = $$sref; unless (defined $scalar) { $dumped .= "UNDEF\n"; return; } my $len = length($scalar); $dumped .= "SCALAR len=$len $scalar\n"; } # Dump array sub dump_array { my ($aref) = @_; my $items = 0 + @{$aref}; $dumped .= "ARRAY items=$items\n"; foreach $item (@{$aref}) { unless (defined $item) { $dumped .= 'ITEM_UNDEF' . "\n"; next; } $dumped .= 'ITEM '; &recursive_dump(\$item, 1); } } # Dump hash table sub dump_hash { my ($href) = @_; my $items = scalar(keys %{$href}); $dumped .= "HASH items=$items\n"; foreach $key (sort keys %{$href}) { $dumped .= 'KEY '; &recursive_dump(\$key, undef); unless (defined $href->{$key}) { $dumped .= 'VALUE_UNDEF' . "\n"; next; } $dumped .= 'VALUE '; &recursive_dump(\$href->{$key}, 1); } } # Dump reference to reference sub dump_ref { my ($rref) = @_; my $deref = $$rref; # Follow reference to reference $dumped .= 'REF '; &recursive_dump($deref, 1); # $dref is a reference } # Dump code sub dump_code { my ($sref) = @_; $dumped .= "CODE\n"; } 1; Clone-PP-1.02/t/tied.pl010064400007650000120000000037060772200420700137540ustar00simonmadmin#!./perl # $Id: tied.pl,v 0.11 2001/07/29 19:31:05 ray Exp $ # # Copyright (c) 1995-1998, Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # $Log: tied.pl,v $ # Revision 0.11 2001/07/29 19:31:05 ray # VERSION 0.11 # # Revision 0.10 2001/04/29 21:56:10 ray # VERSION 0.10 # # Revision 0.9 2001/03/05 00:11:49 ray # version 0.9 # # Revision 0.9 2000/08/21 23:06:34 ray # added support for code refs # # Revision 0.8 2000/08/11 17:08:36 ray # Release 0.08. # # Revision 0.7 2000/08/01 00:43:48 ray # release 0.07. # # Revision 0.6.2.1 2000/08/01 00:42:53 ray # modified to use as a require statement. # # Revision 0.6 2000/08/01 01:38:38 ray # "borrowed" code from Storable # # Revision 0.6 1998/06/04 16:08:40 ram # Baseline for first beta release. # require 't/dump.pl'; package TIED_HASH; sub TIEHASH { my $self = bless {}, shift; return $self; } sub FETCH { my $self = shift; my ($key) = @_; $main::hash_fetch++; return $self->{$key}; } sub STORE { my $self = shift; my ($key, $value) = @_; $self->{$key} = $value; } sub FIRSTKEY { my $self = shift; scalar keys %{$self}; return each %{$self}; } sub NEXTKEY { my $self = shift; return each %{$self}; } sub CLEAR { %$self = (); } package TIED_ARRAY; sub TIEARRAY { my $self = bless [], shift; return $self; } sub FETCH { my $self = shift; my ($idx) = @_; $main::array_fetch++; return $self->[$idx]; } sub STORE { my $self = shift; my ($idx, $value) = @_; $self->[$idx] = $value; } sub FETCHSIZE { my $self = shift; return @{$self}; } sub CLEAR { @$self = (); } sub EXTEND { } package TIED_SCALAR; sub TIESCALAR { my $scalar; my $self = bless \$scalar, shift; return $self; } sub FETCH { my $self = shift; $main::scalar_fetch++; return $$self; } sub STORE { my $self = shift; my ($value) = @_; $$self = $value; } sub CLEAR { $$self = (); } 1;