r18023 - in /branches/upstream/libclone-pp-perl: ./ current/ current/t/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Thu Mar 27 09:47:48 UTC 2008
Author: eloy
Date: Thu Mar 27 09:47:47 2008
New Revision: 18023
URL: http://svn.debian.org/wsvn/?sc=1&rev=18023
Log:
[svn-inject] Installing original source of libclone-pp-perl
Added:
branches/upstream/libclone-pp-perl/
branches/upstream/libclone-pp-perl/current/
branches/upstream/libclone-pp-perl/current/MANIFEST
branches/upstream/libclone-pp-perl/current/Makefile.PL
branches/upstream/libclone-pp-perl/current/PP.pm
branches/upstream/libclone-pp-perl/current/README
branches/upstream/libclone-pp-perl/current/t/
branches/upstream/libclone-pp-perl/current/t/01array.t
branches/upstream/libclone-pp-perl/current/t/02hash.t
branches/upstream/libclone-pp-perl/current/t/03scalar.t
branches/upstream/libclone-pp-perl/current/t/04tie.t
branches/upstream/libclone-pp-perl/current/t/05dtype.t
branches/upstream/libclone-pp-perl/current/t/06refcnt.t
branches/upstream/libclone-pp-perl/current/t/dclone.t
branches/upstream/libclone-pp-perl/current/t/dump.pl
branches/upstream/libclone-pp-perl/current/t/tied.pl
Added: branches/upstream/libclone-pp-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/MANIFEST?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/MANIFEST (added)
+++ branches/upstream/libclone-pp-perl/current/MANIFEST Thu Mar 27 09:47:47 2008
@@ -1,0 +1,13 @@
+MANIFEST
+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
Added: branches/upstream/libclone-pp-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/Makefile.PL?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/Makefile.PL (added)
+++ branches/upstream/libclone-pp-perl/current/Makefile.PL Thu Mar 27 09:47:47 2008
@@ -1,0 +1,6 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ 'NAME' => 'Clone::PP',
+ 'VERSION_FROM' => 'PP.pm',
+);
+
Added: branches/upstream/libclone-pp-perl/current/PP.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/PP.pm?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/PP.pm (added)
+++ branches/upstream/libclone-pp-perl/current/PP.pm Thu Mar 27 09:47:47 2008
@@ -1,0 +1,173 @@
+package Clone::PP;
+
+use strict;
+use vars qw($VERSION @EXPORT_OK);
+use Exporter;
+
+$VERSION = 1.02;
+
+ at 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<clone_self>, it is called and the
+result returned without further processing. Alternately, if an
+object provides a method named C<clone_init>, 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<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone-PP> or send mail
+to C<Dist=Clone-PP#rt.cpan.org>, replacing C<#> with C<@>.
+
+=head1 SEE ALSO
+
+For a faster implementation in XS, see L<Clone/clone>, L<Util/clone>, or <Storable/dclone>.
+
+=head1 CREDITS AND COPYRIGHT
+
+Developed by Matthew Simon Cavalletto at Evolution Softworks.
+More free Perl software is available at C<www.evoscript.org>.
+
+Copyright 2003 Matthew Simon Cavalletto. You may contact the author
+directly at C<evo at cpan.org> or C<simonm at 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.
+
+=cut
Added: branches/upstream/libclone-pp-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/README?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/README (added)
+++ branches/upstream/libclone-pp-perl/current/README Thu Mar 27 09:47:47 2008
@@ -1,0 +1,90 @@
+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 <Storable/dclone>.
+
+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 at cpan.org" or "simonm at 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.
+
Added: branches/upstream/libclone-pp-perl/current/t/01array.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/01array.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/01array.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/01array.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,68 @@
+# 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;
+
+ at 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;
Added: branches/upstream/libclone-pp-perl/current/t/02hash.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/02hash.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/02hash.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/02hash.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,84 @@
+# 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;
+
+ at 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;
Added: branches/upstream/libclone-pp-perl/current/t/03scalar.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/03scalar.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/03scalar.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/03scalar.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,64 @@
+# 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;
+
+ at 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;
Added: branches/upstream/libclone-pp-perl/current/t/04tie.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/04tie.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/04tie.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/04tie.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,65 @@
+# 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";
+
Added: branches/upstream/libclone-pp-perl/current/t/05dtype.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/05dtype.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/05dtype.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/05dtype.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,62 @@
+# 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;
+
+ at 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);
Added: branches/upstream/libclone-pp-perl/current/t/06refcnt.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/06refcnt.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/06refcnt.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/06refcnt.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,84 @@
+# 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;
+
+ at 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';
+}
Added: branches/upstream/libclone-pp-perl/current/t/dclone.t
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/dclone.t?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/dclone.t (added)
+++ branches/upstream/libclone-pp-perl/current/t/dclone.t Thu Mar 27 09:47:47 2008
@@ -1,0 +1,112 @@
+#!./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);
+ at 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";
+
Added: branches/upstream/libclone-pp-perl/current/t/dump.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/dump.pl?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/dump.pl (added)
+++ branches/upstream/libclone-pp-perl/current/t/dump.pl Thu Mar 27 09:47:47 2008
@@ -1,0 +1,154 @@
+;# 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;
Added: branches/upstream/libclone-pp-perl/current/t/tied.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libclone-pp-perl/current/t/tied.pl?rev=18023&op=file
==============================================================================
--- branches/upstream/libclone-pp-perl/current/t/tied.pl (added)
+++ branches/upstream/libclone-pp-perl/current/t/tied.pl Thu Mar 27 09:47:47 2008
@@ -1,0 +1,131 @@
+#!./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;
More information about the Pkg-perl-cvs-commits
mailing list