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