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