1# $Id: 06refcnt.t,v 0.22 2007/07/25 03:41:06 ray Exp $
2# Before `make install' is performed this script should be runnable with
3# `make test'. After `make install' it should work as `perl test.pl'
4
5######################### We start with some black magic to print on failure.
6
7# Change 1..1 below to 1..last_test_to_print .
8# (It may become useful if the test is moved to ./t subdirectory.)
9
10BEGIN { $| = 1; print "1..20\n"; }
11END {print "not ok 1\n" unless $loaded;}
12use Clone qw( clone );
13$loaded = 1;
14print "ok 1\n";
15
16######################### End of black magic.
17
18# Insert your test code below (better if it prints "ok 13"
19# (correspondingly "not ok 13") depending on the success of chunk 13
20# of the test code):
21
22# code to test for memory leaks
23
24## use Benchmark;
25use Data::Dumper;
26# use Storable qw( dclone );
27
28$^W = 1;
29$test = 2;
30
31sub ok     { printf("ok %d\n", $test++); }
32sub not_ok { printf("not ok %d\n", $test++); }
33
34use strict;
35
36package Test::Hash;
37
38@Test::Hash::ISA = qw( Clone );
39
40sub new()
41{
42  my ($class) = @_;
43  my $self = {};
44  bless $self, $class;
45}
46
47my $ok = 0;
48END { $ok = 1; };
49sub DESTROY
50{
51  my $self = shift;
52  printf("not ") if $ok;
53  printf("ok %d\n", $::test++);
54}
55
56package main;
57
58{
59  my $a = Test::Hash->new();
60  my $b = $a->clone;
61  # my $c = dclone($a);
62}
63
64# benchmarking bug
65{
66  my $a = Test::Hash->new();
67  my $sref = sub { my $b = clone($a) };
68  $sref->();
69}
70
71# test for cloning unblessed ref
72{
73  my $a = {};
74  my $b = clone($a);
75  bless $a, 'Test::Hash';
76  bless $b, 'Test::Hash';
77}
78
79# test for cloning unblessed ref
80{
81  my $a = [];
82  my $b = clone($a);
83  bless $a, 'Test::Hash';
84  bless $b, 'Test::Hash';
85}
86
87# test for cloning ref that was an int(IV)
88{
89  my $a = 1;
90  $a = [];
91  my $b = clone($a);
92  bless $a, 'Test::Hash';
93  bless $b, 'Test::Hash';
94}
95
96# test for cloning ref that was a string(PV)
97{
98  my $a = '';
99  $a = [];
100  my $b = clone($a);
101  bless $a, 'Test::Hash';
102  bless $b, 'Test::Hash';
103}
104
105# test for cloning ref that was a magic(PVMG)
106{
107  my $a = *STDOUT;
108  $a = [];
109  my $b = clone($a);
110  bless $a, 'Test::Hash';
111  bless $b, 'Test::Hash';
112}
113
114# test for cloning weak reference
115{
116  use Scalar::Util qw(weaken isweak);
117  my $a = new Test::Hash();
118  my $b = { r => $a };
119  $a->{r} = $b;
120  weaken($b->{'r'});
121  my $c = clone($a);
122}
123
124# another weak reference problem, this one causes a segfault in 0.24
125{
126  use Scalar::Util qw(weaken isweak);
127  my $a = new Test::Hash();
128  {
129    my $b = [ $a, $a ];
130    $a->{r} = $b;
131    weaken($b->[0]);
132    weaken($b->[1]);
133  }
134  my $c = clone($a);
135  # check that references point to the same thing
136  print  "not " unless $c->{'r'}[0] == $c->{'r'}[1];
137  printf "ok %d\n", $::test++;
138}
139