Clone-PP-1.06/000755 000765 000024 00000000000 12363011572 013251 5ustar00neilbstaff000000 000000 Clone-PP-1.06/Changes000644 000765 000024 00000002051 12363011472 014541 0ustar00neilbstaff000000 000000 Revision history for Perl module Clone::PP 1.06 2014-07-20 NEILB - Changed the copyright on dclone.t, dump.pl, and tied.pl in t/, to match the rest of the dist, "same as perl itself". These changes were approved by the copyright owner, Raphael Manfredi. 1.05 2014-02-17 NEILB - Added github repo to metadata (thanks dsteinbrunner) - Added github repo to doc 1.04 2014-02-17 NEILB - I had erroneously listed Test::Array as a test prereq, but the package is defined in 01array.t where it's used. RT#93082 - thanks to Dagfinn Ilmari Mannsaker. 1.03 2014-02-16 NEILB - Added Changes file - Fixed typos from dsteinbrunner in RT#86337 - Added "use warnings" and in the process fixed RT#17121 - Min perl version 5.6.0 in code and metadata - Added license type to metadata and renamed L&C section in pod - Expanded the SEE ALSO section - Added prereqs to PREREQ_PM in Makefile.PL - Added test prereqs in TEST_REQUIRES 1.02 2003-08-28 1.01 2003-08-27 1.00 2003-08-25 - First release to CPAN Clone-PP-1.06/lib/000755 000765 000024 00000000000 12363011572 014017 5ustar00neilbstaff000000 000000 Clone-PP-1.06/Makefile.PL000644 000765 000024 00000002275 12300517244 015227 0ustar00neilbstaff000000 000000 use ExtUtils::MakeMaker; my $mm_ver = $ExtUtils::MakeMaker::VERSION; if ($mm_ver =~ /_/) { # dev version $mm_ver = eval $mm_ver; die $@ if $@; } WriteMakefile( 'NAME' => 'Clone::PP', 'VERSION_FROM' => 'lib/Clone/PP.pm', PREREQ_PM => { 'Exporter' => 0, 'strict' => 0, 'warnings' => 0, 'vars' => 0, }, ($mm_ver >= 6.48 ? (MIN_PERL_VERSION => 5.006) : () ), ($mm_ver >= 6.31 ? (LICENSE => 'perl_5') : () ), ($mm_ver >= 6.64 ? (TEST_REQUIRES => { 'Data::Dumper' => 0, 'Benchmark' => 0, 'Carp' => 0, }) : () ), ($mm_ver <= 6.45 ? () : (META_MERGE => { 'meta-spec' => { version => 2 }, resources => { bugtracker => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Clone-PP', repository => { type => 'git', web => 'https://github.com/neilbowers/Clone-PP', url => 'git://github.com/neilbowers/Clone-PP.git', }, }, }) ), ); Clone-PP-1.06/MANIFEST000644 000765 000024 00000000502 12363011572 014377 0ustar00neilbstaff000000 000000 Changes MANIFEST Makefile.PL lib/Clone/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 META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Clone-PP-1.06/META.json000644 000765 000024 00000002411 12363011572 014670 0ustar00neilbstaff000000 000000 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.141170", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Clone-PP", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Exporter" : "0", "perl" : "5.006", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Benchmark" : "0", "Carp" : "0", "Data::Dumper" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/neilbowers/Clone-PP.git", "web" : "https://github.com/neilbowers/Clone-PP" } }, "version" : "1.06" } Clone-PP-1.06/META.yml000644 000765 000024 00000001147 12363011572 014525 0ustar00neilbstaff000000 000000 --- abstract: unknown author: - unknown build_requires: Benchmark: '0' Carp: '0' Data::Dumper: '0' ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.141170' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Clone-PP no_index: directory: - t - inc requires: Exporter: '0' perl: '5.006' strict: '0' vars: '0' warnings: '0' resources: repository: git://github.com/neilbowers/Clone-PP.git version: '1.06' Clone-PP-1.06/README000644 000765 000024 00000006204 12277636345 014152 0ustar00neilbstaff000000 000000 NAME 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.06/t/000755 000765 000024 00000000000 12363011572 013514 5ustar00neilbstaff000000 000000 Clone-PP-1.06/t/01array.t000644 000765 000024 00000002637 12277636345 015207 0ustar00neilbstaff000000 000000 # 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.06/t/02hash.t000644 000765 000024 00000003535 12277636345 015013 0ustar00neilbstaff000000 000000 # 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.06/t/03scalar.t000644 000765 000024 00000002573 12277636345 015337 0ustar00neilbstaff000000 000000 # 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.06/t/04tie.t000644 000765 000024 00000002362 12277636345 014650 0ustar00neilbstaff000000 000000 # 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.06/t/05dtype.t000644 000765 000024 00000002443 12277636345 015215 0ustar00neilbstaff000000 000000 # 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.06/t/06refcnt.t000644 000765 000024 00000003071 12277636345 015350 0ustar00neilbstaff000000 000000 # 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.06/t/dclone.t000644 000765 000024 00000004604 12362307576 015164 0ustar00neilbstaff000000 000000 #!./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 this file under the same terms as Perl 5 itself. # # $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.06/t/dump.pl000644 000765 000024 00000007136 12362307622 015030 0ustar00neilbstaff000000 000000 ;# Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# ;# You may redistribute this file under the same terms as Perl 5 itself. ;# ;# 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.06/t/tied.pl000644 000765 000024 00000003604 12362307632 015005 0ustar00neilbstaff000000 000000 #!./perl # $Id: tied.pl,v 0.11 2001/07/29 19:31:05 ray Exp $ # # Copyright (c) 1995-1998, Raphael Manfredi # # You may redistribute this file under the same terms as Perl 5 itself. # # $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; Clone-PP-1.06/lib/Clone/000755 000765 000024 00000000000 12363011572 015057 5ustar00neilbstaff000000 000000 Clone-PP-1.06/lib/Clone/PP.pm000644 000765 000024 00000013772 12362307772 015757 0ustar00neilbstaff000000 000000 package Clone::PP; use 5.006; use strict; use warnings; use vars qw($VERSION @EXPORT_OK); use Exporter; $VERSION = 1.06; @EXPORT_OK = qw( clone ); sub import { goto &Exporter::import } # lazy Exporter # These methods can be temporarily overridden 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; return undef if not defined($source); # 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 ( defined $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 if 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 L - a baseclass which provides a C method. L - find-grained cloning for Moose objects. The C function in L. L - polymorphic data cloning (see its documentation for what that means). L - use whichever of the cloning methods is available. =head1 REPOSITORY L =head1 AUTHOR AND CREDITS Developed by Matthew Simon Cavalletto at Evolution Softworks. More free Perl software is available at C. =head1 COPYRIGHT AND LICENSE 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