Clone-0.36/0000755000175000017500000000000012250674227011167 5ustar garugaruClone-0.36/MANIFEST0000644000175000017500000000046612250674227012326 0ustar garugaruChanges Clone.pm Clone.xs Makefile.PL MANIFEST META.yml Module meta-data (added by MakeMaker) t/01array.t t/02hash.t t/03scalar.t t/04tie.t t/05dtype.t t/06refcnt.t t/07magic.t t/08fieldhash.t t/dclone.t t/dump.pl t/tied.pl META.json Module JSON meta-data (added by MakeMaker) Clone-0.36/META.json0000664000175000017500000000207612250674227012617 0ustar garugaru{ "abstract" : "recursively copy Perl datatypes", "author" : [ "Ray Finch " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Clone", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/garu/Clone" } }, "version" : "0.36" } Clone-0.36/t/0000755000175000017500000000000012250674227011432 5ustar garugaruClone-0.36/t/08fieldhash.t0000755000175000017500000000070512250667025013721 0ustar garugaru# $Id: 07magic.t,v 1.8 2007/04/20 05:40:48 ray Exp $ use strict; use warnings; use Clone 'clone'; BEGIN { use Test::More; eval { require Hash::Util::FieldHash; Hash::Util::FieldHash->import('fieldhash'); }; if ($@) { plan skip_all => 'Hash::Util::FieldHash not available'; } else { plan tests => 1; } } fieldhash my %hash; my $var = {}; exists $hash{ \$var }; my $cloned = clone($var); cmp_ok($cloned, '!=', $var); Clone-0.36/t/06refcnt.t0000755000175000017500000000542212250667025013252 0ustar garugaru# $Id: 06refcnt.t,v 0.22 2007/07/25 03:41:06 ray Exp $ # 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.) my $HAS_WEAKEN; BEGIN { $| = 1; my $plan = 20; eval 'use Scalar::Util qw( weaken isweak );'; if ($@) { $HAS_WEAKEN = 0; $plan = 15; } else { $HAS_WEAKEN = 1; } print "1..$plan\n"; } END {print "not ok 1\n" unless $loaded;} use Clone 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 = 1; $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 ); 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'; } # test for cloning ref that was an int(IV) { my $a = 1; $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning ref that was a string(PV) { my $a = ''; $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning ref that was a magic(PVMG) { my $a = *STDOUT; $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning weak reference if ( $HAS_WEAKEN ) { { my $a = new Test::Hash(); my $b = { r => $a }; $a->{r} = $b; weaken($b->{'r'}); my $c = clone($a); } # another weak reference problem, this one causes a segfault in 0.24 { my $a = new Test::Hash(); { my $b = [ $a, $a ]; $a->{r} = $b; weaken($b->[0]); weaken($b->[1]); } my $c = clone($a); # check that references point to the same thing print "not " unless $c->{'r'}[0] == $c->{'r'}[1]; printf "ok %d\n", $::test++; } } Clone-0.36/t/02hash.t0000755000175000017500000000425412250667025012712 0ustar garugaru# $Id: 02hash.t,v 0.19 2006/10/08 03:37:29 ray Exp $ # 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.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 11; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone 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): package Test::Hash; use vars @ISA; @ISA = qw(Clone); 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); if ($has_data_dumper) { Dumper(\%circ) eq Dumper($cref) ? ok : not_ok; } # test for unicode support { my $a = { chr(256) => 1 }; my $b = clone( $a ); ord( (keys(%$a))[0] ) == ord( (keys(%$b))[0] ) ? ok : not_ok; } Clone-0.36/t/tied.pl0000755000175000017500000000443212250667025012720 0ustar garugaru#!./perl # $Id: tied.pl,v 0.18 2006/10/08 03:37:29 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.18 2006/10/08 03:37:29 ray # Commented out VERSION causes errors with DynaLoader in perl 5.6.1 (and # probably all earlier versions. It was removed. # # Revision 0.14 2003/09/07 22:02:36 ray # VERSION 0.15 # # Revision 0.13.2.1 2003/09/07 21:51:13 ray # added support for unicode hash keys. This is only really a bug in 5.8.0 and # the test in t/03scalar supports this. # # Revision 0.13 2002/06/12 06:41:55 ray # VERSION 0.13 # # 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}; } 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}; } 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; } 1; Clone-0.36/t/dump.pl0000755000175000017500000000724112250667025012741 0ustar garugaru;# 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-0.36/t/01array.t0000755000175000017500000000334112250667025013100 0ustar garugaru# $Id: 01array.t,v 0.19 2006/10/08 03:37:29 ray Exp $ # 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.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 6; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone 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): package Test::Array; use vars @ISA; @ISA = qw(Clone); 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); if ($has_data_dumper) { Dumper(\@circ) eq Dumper($aref) ? ok : not_ok; } # test for unicode support { my $a = [ chr(256) => 1 ]; my $b = clone( $a ); ord( $a->[0] ) == ord( $b->[0] ) ? ok : not_ok; } Clone-0.36/t/07magic.t0000755000175000017500000000232412250667025013050 0ustar garugaru# $Id: 07magic.t,v 1.8 2007/04/20 05:40:48 ray Exp $ use strict; use Clone; use Test::More tests => 3; SKIP: { eval "use Data::Dumper"; skip "Data::Dumper not installed", 1 if $@; SKIP: { eval "use Scalar::Util qw( weaken )"; skip "Scalar::Util not installed", 1 if $@; my $x = { a => "worked\n" }; my $y = $x; weaken($y); my $z = Clone::clone($x); ok( Dumper($x) eq Dumper($z), "Cloned weak reference"); } ## RT 21859: Clone segfault (isolated example) SKIP: { my $string = "HDDR-WD-250JS"; eval { use utf8; utf8::upgrade($string); }; skip $@, 1 if $@; $string = sprintf ('<>%s<>%s', '#EA0', substr ($string, 0, 4), substr ($string, 4), ); my $z = Clone::clone($string); ok( Dumper($string) eq Dumper($z), "Cloned magic utf8"); } } SKIP: { eval "use Taint::Runtime qw(enable taint_env)"; skip "Taint::Runtime not installed", 1 if $@; taint_env(); my $x = ""; for (keys %ENV) { $x = $ENV{$_}; last if ( $x && length($x) > 0 ); } my $y = Clone::clone($x); ## ok(Clone::clone($tainted), "Tainted input"); ok( Dumper($x) eq Dumper($y), "Tainted input"); } Clone-0.36/t/dclone.t0000755000175000017500000000527412250667025013074 0ustar garugaru#!./perl # $Id: dclone.t,v 0.18 2006/10/08 03:37:29 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.18 2006/10/08 03:37:29 ray # Commented out VERSION causes errors with DynaLoader in perl 5.6.1 (and # probably all earlier versions. It was removed. # # Revision 0.14 2003/09/07 22:02:36 ray # VERSION 0.15 # # Revision 0.13.2.1 2003/09/07 21:51:13 ray # added support for unicode hash keys. This is only really a bug in 5.8.0 and # the test in t/03scalar supports this. # # Revision 0.13 2002/06/12 06:41:55 ray # VERSION 0.13 # # 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 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); 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)); print "not " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 8\n"; $$cloned{a} = "blah"; print "not " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 9\n"; Clone-0.36/t/04tie.t0000755000175000017500000000244212250667025012547 0ustar garugaru# $Id: 04tie.t,v 0.18 2006/10/08 03:37:29 ray Exp $ # 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 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-0.36/t/05dtype.t0000755000175000017500000000273712250667025013123 0ustar garugaru# $Id: 05dtype.t,v 0.18 2006/10/08 03:37:29 ray Exp $ # 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.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 1; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use 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): 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 ); 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); if ($has_data_dumper) { Dumper($a, $b) eq Dumper($a, $c) ? ok() : not_ok; } # print Dumper($a, $b); # print Dumper($a, $c); Clone-0.36/t/03scalar.t0000755000175000017500000000372012250667025013232 0ustar garugaru# $Id: 03scalar.t,v 0.19 2006/10/08 03:37:29 ray Exp $ # 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.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 9; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone 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): package Test::Scalar; use vars @ISA; @ISA = qw(Clone); 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::clone($c, 2); $$c == $$d ? ok : not_ok; $c != $d ? ok : not_ok; my $circ = undef; $circ = \$circ; $aref = clone($circ); if ($has_data_dumper) { Dumper($circ) eq Dumper($aref) ? ok : not_ok; } # the following used to produce a segfault, rt.cpan.org id=2264 undef $a; $b = clone($a); $$a == $$b ? ok : not_ok; # used to get a segfault cloning a ref to a qr data type. my $str = 'abcdefg'; my $qr = qr/$str/; my $qc = clone( $qr ); $qr eq $qc ? ok : not_ok; $str =~ /$qc/ ? ok : not_ok; # test for unicode support { my $a = \( chr(256) ); my $b = clone( $a ); ord($$a) == ord($$b) ? ok : not_ok; } Clone-0.36/Clone.xs0000755000175000017500000002075112250667425012615 0ustar garugaru#include #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define CLONE_KEY(x) ((char *) &x) #define CLONE_STORE(x,y) \ do { \ if (!hv_store(hseen, CLONE_KEY(x), PTRSIZE, SvREFCNT_inc(y), 0)) { \ SvREFCNT_dec(y); /* Restore the refcount */ \ croak("Can't store clone in seen hash (hseen)"); \ } \ else { \ TRACEME(("storing ref = 0x%x clone = 0x%x\n", ref, clone)); \ TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); \ TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); \ } \ } while (0) #define CLONE_FETCH(x) (hv_fetch(hseen, CLONE_KEY(x), PTRSIZE, 0)) static SV *hv_clone (SV *, SV *, HV *, int); static SV *av_clone (SV *, SV *, HV *, int); static SV *sv_clone (SV *, HV *, int); static SV *rv_clone (SV *, HV *, int); #ifdef DEBUG_CLONE #define TRACEME(a) printf("%s:%d: ",__FUNCTION__, __LINE__) && printf a; #else #define TRACEME(a) #endif static SV * hv_clone (SV * ref, SV * target, HV* hseen, int depth) { HV *clone = (HV *) target; HV *self = (HV *) ref; HE *next = NULL; int recur = depth ? depth - 1 : 0; assert(SvTYPE(ref) == SVt_PVHV); TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); hv_iterinit (self); while (next = hv_iternext (self)) { SV *key = hv_iterkeysv (next); TRACEME(("clone item %s\n", SvPV_nolen(key) )); hv_store_ent (clone, key, sv_clone (hv_iterval (self, next), hseen, recur), 0); } TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return (SV *) clone; } static SV * av_clone (SV * ref, SV * target, HV* hseen, int depth) { AV *clone = (AV *) target; AV *self = (AV *) ref; SV **svp; SV *val = NULL; I32 arrlen = 0; int i = 0; int recur = depth ? depth - 1 : 0; assert(SvTYPE(ref) == SVt_PVAV); TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); /* The following is a holdover from a very old version */ /* possible cause of memory leaks */ /* if ( (SvREFCNT(ref) > 1) ) */ /* CLONE_STORE(ref, (SV *)clone); */ arrlen = av_len (self); av_extend (clone, arrlen); for (i = 0; i <= arrlen; i++) { svp = av_fetch (self, i, 0); if (svp) av_store (clone, i, sv_clone (*svp, hseen, recur)); } TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return (SV *) clone; } static SV * rv_clone (SV * ref, HV* hseen, int depth) { SV *clone = NULL; SV *rv = NULL; assert(SvROK(ref)); TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); if (!SvROK (ref)) return NULL; if (sv_isobject (ref)) { clone = newRV_noinc(sv_clone (SvRV(ref), hseen, depth)); sv_2mortal (sv_bless (clone, SvSTASH (SvRV (ref)))); } else clone = newRV_inc(sv_clone (SvRV(ref), hseen, depth)); TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return clone; } static SV * sv_clone (SV * ref, HV* hseen, int depth) { SV *clone = ref; SV **seen = NULL; UV visible; int magic_ref = 0; if (!ref) { TRACEME(("NULL\n")); return NULL; } #if PERL_REVISION >= 5 && PERL_VERSION > 8 /* This is a hack for perl 5.9.*, save everything */ /* until I find out why mg_find is no longer working */ visible = 1; #else visible = (SvREFCNT(ref) > 1) || (SvMAGICAL(ref) && mg_find(ref, '<')); #endif TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); if (depth == 0) return SvREFCNT_inc(ref); if (visible && (seen = CLONE_FETCH(ref))) { TRACEME(("fetch ref (0x%x)\n", ref)); return SvREFCNT_inc(*seen); } TRACEME(("switch: (0x%x)\n", ref)); switch (SvTYPE (ref)) { case SVt_NULL: /* 0 */ TRACEME(("sv_null\n")); clone = newSVsv (ref); break; case SVt_IV: /* 1 */ TRACEME(("int scalar\n")); case SVt_NV: /* 2 */ TRACEME(("double scalar\n")); clone = newSVsv (ref); break; #if PERL_VERSION <= 10 case SVt_RV: /* 3 */ TRACEME(("ref scalar\n")); clone = newSVsv (ref); break; #endif case SVt_PV: /* 4 */ TRACEME(("string scalar\n")); clone = newSVsv (ref); break; case SVt_PVIV: /* 5 */ TRACEME (("PVIV double-type\n")); case SVt_PVNV: /* 6 */ TRACEME (("PVNV double-type\n")); clone = newSVsv (ref); break; case SVt_PVMG: /* 7 */ TRACEME(("magic scalar\n")); clone = newSVsv (ref); break; case SVt_PVAV: /* 10 */ clone = (SV *) newAV(); break; case SVt_PVHV: /* 11 */ clone = (SV *) newHV(); break; #if PERL_VERSION <= 8 case SVt_PVBM: /* 8 */ #elif PERL_VERSION >= 11 case SVt_REGEXP: /* 8 */ #endif case SVt_PVLV: /* 9 */ case SVt_PVCV: /* 12 */ case SVt_PVGV: /* 13 */ case SVt_PVFM: /* 14 */ case SVt_PVIO: /* 15 */ TRACEME(("default: type = 0x%x\n", SvTYPE (ref))); clone = SvREFCNT_inc(ref); /* just return the ref */ break; default: croak("unknown type: 0x%x", SvTYPE(ref)); } /** * It is *vital* that this is performed *before* recursion, * to properly handle circular references. cb 2001-02-06 */ if ( visible ) CLONE_STORE(ref,clone); /* * We'll assume (in the absence of evidence to the contrary) that A) a * tied hash/array doesn't store its elements in the usual way (i.e. * the mg->mg_object(s) take full responsibility for them) and B) that * references aren't tied. * * If theses assumptions hold, the three options below are mutually * exclusive. * * More precisely: 1 & 2 are probably mutually exclusive; 2 & 3 are * definitely mutually exclusive; we have to test 1 before giving 2 * a chance; and we'll assume that 1 & 3 are mutually exclusive unless * and until we can be test-cased out of our delusion. * * chocolateboy: 2001-05-29 */ /* 1: TIED */ if (SvMAGICAL(ref) ) { MAGIC* mg; MGVTBL *vtable = 0; for (mg = SvMAGIC(ref); mg; mg = mg->mg_moremagic) { SV *obj = (SV *) NULL; /* we don't want to clone a qr (regexp) object */ /* there are probably other types as well ... */ TRACEME(("magic type: %c\n", mg->mg_type)); /* Some mg_obj's can be null, don't bother cloning */ if ( mg->mg_obj != NULL ) { switch (mg->mg_type) { case 'r': /* PERL_MAGIC_qr */ obj = mg->mg_obj; break; case 't': /* PERL_MAGIC_taint */ continue; break; case '<': /* PERL_MAGIC_backref */ continue; break; case '@': /* PERL_MAGIC_arylen_p */ continue; break; case 'P': /* PERL_MAGIC_tied */ case 'p': /* PERL_MAGIC_tiedelem */ case 'q': /* PERL_MAGIC_tiedscalar */ magic_ref++; /* fall through */ default: obj = sv_clone(mg->mg_obj, hseen, -1); } } else { TRACEME(("magic object for type %c in NULL\n", mg->mg_type)); } /* this is plain old magic, so do the same thing */ sv_magic(clone, obj, mg->mg_type, mg->mg_ptr, mg->mg_len); } /* major kludge - why does the vtable for a qr type need to be null? */ if ( mg = mg_find(clone, 'r') ) mg->mg_virtual = (MGVTBL *) NULL; } /* 2: HASH/ARRAY - (with 'internal' elements) */ if ( magic_ref ) { ;; } else if ( SvTYPE(ref) == SVt_PVHV ) clone = hv_clone (ref, clone, hseen, depth); else if ( SvTYPE(ref) == SVt_PVAV ) clone = av_clone (ref, clone, hseen, depth); /* 3: REFERENCE (inlined for speed) */ else if (SvROK (ref)) { TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); SvREFCNT_dec(SvRV(clone)); SvRV(clone) = sv_clone (SvRV(ref), hseen, depth); /* Clone the referent */ if (sv_isobject (ref)) { sv_bless (clone, SvSTASH (SvRV (ref))); } if (SvWEAKREF(ref)) { sv_rvweaken(clone); } } TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return clone; } MODULE = Clone PACKAGE = Clone PROTOTYPES: ENABLE void clone(self, depth=-1) SV *self int depth PREINIT: SV *clone = &PL_sv_undef; HV *hseen = newHV(); PPCODE: TRACEME(("ref = 0x%x\n", self)); clone = sv_clone(self, hseen, depth); hv_clear(hseen); /* Free HV */ SvREFCNT_dec((SV *)hseen); EXTEND(SP,1); PUSHs(sv_2mortal(clone)); Clone-0.36/META.yml0000664000175000017500000000114212250674227012440 0ustar garugaru--- abstract: 'recursively copy Perl datatypes' author: - 'Ray Finch ' build_requires: Test::More: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Clone no_index: directory: - t - inc requires: {} resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone license: http://dev.perl.org/licenses/ repository: http://github.com/garu/Clone version: 0.36 Clone-0.36/Changes0000755000175000017500000001333512250673550012470 0ustar garugaruRevision history for Perl module Clone 0.36 2013-12-07 17:36:04 garu - fixed compilation issue on AIX and C89 (GAAS) 0.35 2013-09-05 13:26:54 garu - SV's can be NULL (shit happens) (fixes RT86217) (HMBRAND) - making tests compatible with older versions of Test::More (GARU) 0.34 2012-12-09 14:46:09 garu - making some tests optional (fixes RT81774) (GARU) - modernizing synopsis (GARU) 0.33 2012-11-24 11:37:22 garu - fix typo in croak message (Salvatore Bonaccorso) 0.32 2012-11-22 12:14:07 garu - Stop skipping SvROK handling for all magical scalars. This fixes RT issues 67105, 79730 and 80201 (FLORA). - making the Changes file compliant to the CPAN::Changes spec (GARU). - Fixing tests when Scalar::Util::weaken is not available. As a result, tests should now pass even in odd OpenBSD versions (GARU). - removed dubious documentation on the optional parameter until it is 'fixed'. Right now it just increases the refcount when it's 0, and clones otherwise (which isn't exactly what it says). This fixes RT issue 57773 (GARU). - updated remark on Storable's dclone() to address RT issue 50174 (GARU) - updated Makefile.PL to include test dependencies (GARU) 0.31 2009-01-20 04:54:37 ray - Made changes for build failure on Solaris, apparently compiler warnings from the last patch are errors in Solaris. - Also, brought Changes file up to date. 0.30 2008-12-14 03:33:14 ray - Updating log: Applied patches from RT # 40957 and #41551. 0.29 2008-12-14 03:32:41 ray - Updating log: Applied patches supplied by Andreas Koenig, see RT #34317. 0.28 2008-12-14 03:31:33 ray - Updating log: Made a change in CLONE_KEY to the way Clone stores refs in the ref hash. - Perl no longer uses the SvANY part of the SV struct in the same way which means the old way of storing the hash key is no longer unique. Thanks to Slaven Rezic for the patch. 0.27 2008-12-14 03:30:40 ray - Updating Log: Latest patch from Ruslan Zakirov. Patched another memory leak. 0.26 2007-10-15 04:52:42 ray - Made a change in CLONE_KEY to the way Clone stores refs in the ref hash. - Perl no longer uses the SvANY part of the SV struct in the same way which means the old way of storing the hash key is no longer unique. Thanks to Slaven Rezic for the patch. 0.25 2007-07-25 03:41:04 ray - Latest patch from Ruslan Zakirov. Patched another memory leak. 0.24 2007-07-25 03:33:57 ray - Bug fix for 5.9.*, for some reason the 'visible' logic is no longer working. I #if 'ed it out until I figure out what is going on. - Also removed an old redundant CLONE_STORE, could have been the cause of some memory leaks. 0.23 2007-04-20 05:40:27 ray - Applied patch so clone will contiue to work with newer perls. - Also fixed test to work with older perls. 0.22 2006-10-08 05:35:19 ray - D'oh! The 0.21 tardist that I just uploaded to CPAN contained the 0.20 Clone.xs file. This release is just in case any of the 0.21 releases get mirrored. 0.21 2006-10-08 04:02:56 ray - Clone was segfaulting due to a null SV object in a magical reference (a PERL_MAGIC_utf8). - 21859: Clone segfault (isolated example) 0.20 2006-03-08 17:15:23 ray - Commented out VERSION causes errors with DynaLoader in perl 5.6.1 (and probably all earlier versions. It was removed. 0.19 2006-03-06 07:22:32 ray - added a test and fix for tainted variables. - use a static VERSION in Clone.pm. 0.18 2005-05-23 15:34:31 ray - moved declaration to top of function, M$ (and other) C compilers choke. 0.17 2005-05-05 22:26:01 ray - Changed PERL_MAGIC_backref to '<' for compatability with 5.6 0.16 2005-04-20 15:49:35 ray - Bug fix for id 11997, "Clone dies horribly when Scalar::Util::weaken is around" see http://rt.cpan.org/Ticket/Display.html?id=11997 for details. 0.15.2.1 2005-05-05 21:55:30 ray - changed PERL_MAGIC_backref to '<' for backward compatibility with 5.6 0.15 2003-09-07 22:02:35 ray - VERSION 0.15 0.13.2.3 2003-09-07 21:51:03 ray - added support for unicode hash keys. This is only really a bug in 5.8.0 and the test in t/03scalar supports this. 0.14 2003-09-07 05:48:10 ray - VERSION 0.14 0.13.2.2 2003-09-07 05:45:52 ray - bug fix: refs to a qr (regexp) expression was causing a segfault. 0.13.2.1 2003-09-06 20:18:37 ray - Bug fix on cloning references, only set ROK in clone if it's set in ref. 0.13 2002-02-03 02:12:29 ray - VERSION 0.13 0.11.2.1 2002-02-03 02:10:30 ray - removed dependency on Storable for tests. 0.12 2001-09-30 20:35:27 ray - Version 0.12 release. 0.11 2001-07-29 19:30:27 ray - VERSION 0.11 0.10.2.3 2001-07-28 21:53:03 ray - fixed memory leaks on un-blessed references. 0.10.2.2 2001-07-28 21:52:41 ray - added test cases for circular reference bugs and memory leaks. 0.10.2.1 2001-07-28 21:52:15 ray - fixed circular reference bugs. 0.10 2001-04-29 21:48:45 ray - VERSION 0.10 0.09.2.3 2001-03-11 00:54:41 ray - change call to rv_clone in clone to sv_clone; this allows any scalar to be cloned. 0.09.2.2 2001-03-11 00:50:01 ray - version 0.09.3: cleaned up code, consolidated MAGIC. 0.09.2.1 2001-03-05 16:01:52 ray - added support for double-types. 0.09 2000-08-21 23:05:55 ray - added support for code refs 0.08 2000-08-11 17:08:24 ray - Release 0.08. 0.07 2000-08-01 00:31:24 ray - release 0.07. 0.06.2.3 2000-07-28 20:40:25 ray - added support for circular references 0.06.2.2 2000-07-28 19:04:14 ray - first pass at circular references. 0.06.2.1 2000-07-28 18:54:33 ray - added support for scalar types. 0.06 Thu May 25 17:48:59 2000 GMT - initial release to CPAN. 0.01 Tue May 16 08:55:10 2000 - original version; created by h2xs 1.19 Clone-0.36/Clone.pm0000755000175000017500000000330212250674007012562 0ustar garugarupackage Clone; use strict; use Carp; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(); @EXPORT_OK = qw( clone ); $VERSION = '0.36'; bootstrap Clone $VERSION; 1; __END__ =head1 NAME Clone - recursively copy Perl datatypes =head1 SYNOPSIS package Foo; use parent 'Clone'; package main; my $original = Foo->new; $copy = $original->clone; # or use Clone qw(clone); $a = { 'foo' => 'bar', 'move' => 'zig' }; $b = [ 'alpha', 'beta', 'gamma', 'vlissides' ]; $c = Foo->new; $d = clone($a); $e = clone($b); $f = clone($c); =head1 DESCRIPTION This module provides a clone() method which makes recursive copies of nested hash, array, scalar and reference types, including tied variables and objects. clone() takes a scalar argument and duplicates it. To duplicate lists, arrays or hashes, pass them in by reference. e.g. my $copy = clone (\@array); # or my %copy = %{ clone (\%hash) }; =head1 SEE ALSO L's dclone() is a flexible solution for cloning variables, albeit slower for average-sized data structures. Simple and naive benchmarks show that Clone is faster for data structures with 3 or less levels, while dclone() can be faster for structures 4 or more levels deep. =head1 COPYRIGHT Copyright 2001-2013 Ray Finch. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Ray Finch C<< >> Breno G. de Oliveira C<< >> and Florian Ragwitz C<< >> perform routine maintenance releases since 2012. =cut Clone-0.36/Makefile.PL0000755000175000017500000000162212250667025013143 0ustar garugaruuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Clone', 'AUTHOR' => 'Ray Finch ', 'VERSION_FROM' => 'Clone.pm', 'ABSTRACT_FROM' => 'Clone.pm', 'LICENSE' => 'perl', 'PL_FILES' => {}, 'BUILD_REQUIRES' => { 'Test::More' => 0, }, 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' # 'OPTIMIZE' => '-g', # e.g., '-I/usr/include/other' 'OPTIMIZE' => '-O3', # e.g., '-I/usr/include/other' clean => { FILES => '_Inline' }, META_MERGE => { resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone', repository => 'http://github.com/garu/Clone', }, }, );