|
Packit |
8df772 |
# $Id: 06refcnt.t,v 0.22 2007/07/25 03:41:06 ray Exp $
|
|
Packit |
8df772 |
# Before `make install' is performed this script should be runnable with
|
|
Packit |
8df772 |
# `make test'. After `make install' it should work as `perl test.pl'
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
######################### We start with some black magic to print on failure.
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# Change 1..1 below to 1..last_test_to_print .
|
|
Packit |
8df772 |
# (It may become useful if the test is moved to ./t subdirectory.)
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
my $HAS_WEAKEN;
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
BEGIN {
|
|
Packit |
8df772 |
$| = 1;
|
|
Packit |
8df772 |
my $plan = 20;
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
eval 'use Scalar::Util qw( weaken isweak );';
|
|
Packit |
8df772 |
if ($@) {
|
|
Packit |
8df772 |
$HAS_WEAKEN = 0;
|
|
Packit |
8df772 |
$plan = 15;
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
else {
|
|
Packit |
8df772 |
$HAS_WEAKEN = 1;
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
print "1..$plan\n";
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
END {print "not ok 1\n" unless $loaded;}
|
|
Packit |
8df772 |
use Clone qw( clone );
|
|
Packit |
8df772 |
$loaded = 1;
|
|
Packit |
8df772 |
print "ok 1\n";
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
######################### End of black magic.
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# Insert your test code below (better if it prints "ok 13"
|
|
Packit |
8df772 |
# (correspondingly "not ok 13") depending on the success of chunk 13
|
|
Packit |
8df772 |
# of the test code):
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# code to test for memory leaks
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
## use Benchmark;
|
|
Packit |
8df772 |
## use Data::Dumper;
|
|
Packit |
8df772 |
# use Storable qw( dclone );
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
$^W = 1;
|
|
Packit |
8df772 |
$test = 2;
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
sub ok { printf("ok %d\n", $test++); }
|
|
Packit |
8df772 |
sub not_ok { printf("not ok %d\n", $test++); }
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
use strict;
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
package Test::Hash;
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
@Test::Hash::ISA = qw( Clone );
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
sub new()
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my ($class) = @_;
|
|
Packit |
8df772 |
my $self = {};
|
|
Packit |
8df772 |
bless $self, $class;
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
my $ok = 0;
|
|
Packit |
8df772 |
END { $ok = 1; };
|
|
Packit |
8df772 |
sub DESTROY
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $self = shift;
|
|
Packit |
8df772 |
printf("not ") if $ok;
|
|
Packit |
8df772 |
printf("ok %d\n", $::test++);
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
package main;
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = Test::Hash->new();
|
|
Packit |
8df772 |
my $b = $a->clone;
|
|
Packit |
8df772 |
# my $c = dclone($a);
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# benchmarking bug
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = Test::Hash->new();
|
|
Packit |
8df772 |
my $sref = sub { my $b = clone($a) };
|
|
Packit |
8df772 |
$sref->();
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# test for cloning unblessed ref
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = {};
|
|
Packit |
8df772 |
my $b = clone($a);
|
|
Packit |
8df772 |
bless $a, 'Test::Hash';
|
|
Packit |
8df772 |
bless $b, 'Test::Hash';
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# test for cloning unblessed ref
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = [];
|
|
Packit |
8df772 |
my $b = clone($a);
|
|
Packit |
8df772 |
bless $a, 'Test::Hash';
|
|
Packit |
8df772 |
bless $b, 'Test::Hash';
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# test for cloning ref that was an int(IV)
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = 1;
|
|
Packit |
8df772 |
$a = [];
|
|
Packit |
8df772 |
my $b = clone($a);
|
|
Packit |
8df772 |
bless $a, 'Test::Hash';
|
|
Packit |
8df772 |
bless $b, 'Test::Hash';
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# test for cloning ref that was a string(PV)
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = '';
|
|
Packit |
8df772 |
$a = [];
|
|
Packit |
8df772 |
my $b = clone($a);
|
|
Packit |
8df772 |
bless $a, 'Test::Hash';
|
|
Packit |
8df772 |
bless $b, 'Test::Hash';
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# test for cloning ref that was a magic(PVMG)
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = *STDOUT;
|
|
Packit |
8df772 |
$a = [];
|
|
Packit |
8df772 |
my $b = clone($a);
|
|
Packit |
8df772 |
bless $a, 'Test::Hash';
|
|
Packit |
8df772 |
bless $b, 'Test::Hash';
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# test for cloning weak reference
|
|
Packit |
8df772 |
if ( $HAS_WEAKEN ) {
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = new Test::Hash();
|
|
Packit |
8df772 |
my $b = { r => $a };
|
|
Packit |
8df772 |
$a->{r} = $b;
|
|
Packit |
8df772 |
weaken($b->{'r'});
|
|
Packit |
8df772 |
my $c = clone($a);
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
|
|
Packit |
8df772 |
# another weak reference problem, this one causes a segfault in 0.24
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $a = new Test::Hash();
|
|
Packit |
8df772 |
{
|
|
Packit |
8df772 |
my $b = [ $a, $a ];
|
|
Packit |
8df772 |
$a->{r} = $b;
|
|
Packit |
8df772 |
weaken($b->[0]);
|
|
Packit |
8df772 |
weaken($b->[1]);
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
my $c = clone($a);
|
|
Packit |
8df772 |
# check that references point to the same thing
|
|
Packit |
8df772 |
print "not " unless $c->{'r'}[0] == $c->{'r'}[1];
|
|
Packit |
8df772 |
printf "ok %d\n", $::test++;
|
|
Packit |
8df772 |
}
|
|
Packit |
8df772 |
}
|