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
10my $HAS_WEAKEN;
11
12BEGIN {
13    $| = 1;
14    my $plan = 25;
15
16    eval 'use Scalar::Util qw( weaken isweak );';
17    if ($@) {
18        $HAS_WEAKEN = 0;
19        $plan       = 15;
20    }
21    else {
22        $HAS_WEAKEN = 1;
23    }
24
25    print "1..$plan\n";
26}
27END { print "not ok 1\n" unless $loaded; }
28use Clone qw( clone );
29$loaded = 1;
30print "ok 1\n";
31
32######################### End of black magic.
33
34# Insert your test code below (better if it prints "ok 13"
35# (correspondingly "not ok 13") depending on the success of chunk 13
36# of the test code):
37
38# code to test for memory leaks
39
40## use Benchmark;
41## use Data::Dumper;
42# use Storable qw( dclone );
43
44$^W   = 1;
45$test = 2;
46
47use strict;
48
49package Test::Hash;
50
51@Test::Hash::ISA = qw( Clone );
52
53sub new() {
54    my ($class) = @_;
55    my $self = {};
56    bless $self, $class;
57}
58
59my $ok = 0;
60END { $ok = 1; }
61
62sub DESTROY {
63    my $self = shift;
64    printf("not ") if $ok;
65    printf( "ok %d - DESTROY\n", $::test++ );
66}
67
68package main;
69
70{
71    my $a = Test::Hash->new();
72    my $b = $a->clone;
73
74    # my $c = dclone($a);
75}
76
77# benchmarking bug
78{
79    my $a = Test::Hash->new();
80    my $sref = sub { my $b = clone($a) };
81    $sref->();
82}
83
84# test for cloning unblessed ref
85{
86    my $a = {};
87    my $b = clone($a);
88    bless $a, 'Test::Hash';
89    bless $b, 'Test::Hash';
90}
91
92# test for cloning unblessed ref
93{
94    my $a = [];
95    my $b = clone($a);
96    bless $a, 'Test::Hash';
97    bless $b, 'Test::Hash';
98}
99
100# test for cloning ref that was an int(IV)
101{
102    my $a = 1;
103    $a = [];
104    my $b = clone($a);
105    bless $a, 'Test::Hash';
106    bless $b, 'Test::Hash';
107}
108
109# test for cloning ref that was a string(PV)
110{
111    my $a = '';
112    $a = [];
113    my $b = clone($a);
114    bless $a, 'Test::Hash';
115    bless $b, 'Test::Hash';
116}
117
118# test for cloning ref that was a magic(PVMG)
119{
120    my $a = *STDOUT;
121    $a = [];
122    my $b = clone($a);
123    bless $a, 'Test::Hash';
124    bless $b, 'Test::Hash';
125}
126
127# test for cloning weak reference
128if ($HAS_WEAKEN) {
129    {
130        my $a = Test::Hash->new;
131        my $b = { r => $a };
132        $a->{r} = $b;
133        weaken( $b->{'r'} );
134        my $c = clone($a);
135    }
136
137    # another weak reference problem, this one causes a segfault in 0.24
138    {
139        my $a = Test::Hash->new;
140        {
141            my $b = [ $a, $a ];
142            $a->{r} = $b;
143            weaken( $b->[0] );
144            weaken( $b->[1] );
145        }
146
147        my $c = clone($a);
148
149        # check that references point to the same thing
150        is( $c->{'r'}[0], $c->{'r'}[1], "references point to the same thing" );
151        isnt( $c->{'r'}[0], $a->{'r'}[0], "a->{r}->[0] ne c->{r}->[0]" );
152
153        require B;
154        my $c_obj = B::svref_2object($c);
155        is( $c_obj->REFCNT, 1, 'c REFCNT = 1' )
156          or diag( "refcnt is ", $c_obj->REFCNT );
157
158        my $cr_obj = B::svref_2object( $c->{'r'} );
159        is( $cr_obj->REFCNT, 1, 'cr REFCNT = 1' )
160          or diag( "refcnt is ", $cr_obj->REFCNT );
161
162        my $cr_0_obj = B::svref_2object( $c->{'r'}->[0] );
163        is( $cr_0_obj->REFCNT, 1, 'c->{r}->[0] REFCNT = 1' )
164          or diag( "refcnt is ", $cr_0_obj->REFCNT );
165
166        my $cr_1_obj = B::svref_2object( $c->{'r'}->[1] );
167        is( $cr_1_obj->REFCNT, 1, 'c->{r}->[1] REFCNT = 1' )
168          or diag( "refcnt is ", $cr_1_obj->REFCNT );
169
170    }
171}
172
173exit;
174
175sub diag {
176    my (@msg) = @_;
177
178    print STDERR join( ' ', '#', @msg, "\n" );
179    return;
180}
181
182sub ok {
183    my $msg = shift;
184    $msg = '' unless defined $msg;
185    $msg = ' - ' . $msg if length $msg;
186    printf( "ok %d%s\n", $::test++, $msg );
187
188    return 1;
189}
190
191sub not_ok {
192    my $msg = shift;
193    $msg = '' unless defined $msg;
194
195    printf( "not ok %d %s\n", $::test++, $msg );
196
197    return;
198}
199
200sub is {
201    my ( $x, $y, $msg ) = @_;
202
203    # dumb for now
204    $x = 'undef' if !defined $x;
205    $y = 'undef' if !defined $y;
206
207    if ( !defined $x && !defined $y ) {
208        return ok($msg);
209    }
210
211    if ( !defined $x || !defined $y ) {
212        return not_ok($msg);
213    }
214
215    if ( $x eq $y ) {
216        return ok($msg);
217    }
218    else {
219        return not_ok($msg);
220    }
221}
222
223sub isnt {
224    my ( $x, $y, $msg ) = @_;
225
226    # dumb for now
227    $x = 'undef' if !defined $x;
228    $y = 'undef' if !defined $y;
229
230    if ( !defined $x && !defined $y ) {
231        return no_ok($msg);
232    }
233
234    if ( !defined $x || !defined $y ) {
235        return ok($msg);
236    }
237
238    if ( $x eq $y ) {
239        return not_ok($msg);
240    }
241    else {
242        return ok($msg);
243    }
244}
245
246