Test-Weaken-3.022000/0002755000175000017500000000000012056244371011651 5ustar ggggTest-Weaken-3.022000/Makefile.PL0000755000175000017500000000142511764775554013647 0ustar gggg#!/usr/bin/perl -w # No Scalar::Util weaken before 5.006 require 5.006; use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Test::Weaken', AUTHOR => 'Jeffrey Kegler ', VERSION_FROM => 'lib/Test/Weaken.pm', ABSTRACT_FROM => 'lib/Test/Weaken.pm', PL_FILES => {}, LICENSE => 'perl', MIN_PERL_VERSION => '5.006', PREREQ_PM => { 'Test::More' => 0, 'Scalar::Util' => '1.18', }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, # clean => { FILES => 'Test-Weaken-*' }, SIGN => 1, META_MERGE => { no_index => { directory=>['sandbox'], }, }, ); Test-Weaken-3.022000/SIGNATURE0000644000175000017500000000723112056244371013136 0ustar ggggThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.68. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 d558a962d05f28bbef4c5fd6902d544cc8c40793 Changes SHA1 528a6f5a4a70bd41e6fec86b21673cdcb6a664eb MANIFEST SHA1 fc5faf6b3e850fe148d15175098e42c348516ae9 MANIFEST.SKIP SHA1 623aa389c07dcadb2ff4058d33596d1bcf31a420 META.yml SHA1 44522742c753ef121b64696f4a4fc8d7b5db145a Makefile.PL SHA1 84ca423675ccd3f754c42ffcd81cb3cbbd49dbff README SHA1 ab789e5c62efa520a0fef2b1c91ce71d654e9dc9 author.t/Makefile SHA1 da1e92effa45c0b10dbae8ce2a9a95db3c6f1e56 author.t/critic.t SHA1 b7c2d03da45c1fcad1aea57c16a2745fe99567dd author.t/critic1 SHA1 08d8f2d9b526ec7eb22810983560ca9267cc3ac6 author.t/display.t SHA1 e09c101f413bcc042ee22de4ad9dedc66a3e57ac author.t/do_tidy.pl SHA1 730b38423b2281a33d7f6e2dc1ed28c9af9f0bf1 author.t/perlcriticrc SHA1 55e4e8121700f338fd48cfa78345bda56e0481e9 author.t/perltidyrc SHA1 bc1b193fd65b0f312428be12a19085c9af890a79 author.t/tidy1 SHA1 0986c8b3e55c7a51189921e6920067e5aa06507b etc/Makefile SHA1 48d46ae2d2d92620c25d429c185d0af3f086d19d etc/change_version.pl SHA1 6dc3a35896e37da10ac959ce5994c1811f23f979 etc/check_links.pl SHA1 a379ae152a7d3397079e323a9506fc8826326524 etc/last_minute_check.sh SHA1 a09d1a358a20c698d3faf67b0f4fac07c7693ce3 etc/not_in_manifest.pl SHA1 d0c3c2b98c42649f90aa27b0025b22918e45d047 lib/Test/Weaken.pm SHA1 cc7022abdc40c002a170c41abc8827cfc2721a05 sandbox/coderef.pl SHA1 0ea90a3a643941a247e7671bf7ec062433829a4d sandbox/dot.pl SHA1 167c2646003576cad95c84f250eb40a4240ed060 sandbox/elements.pl SHA1 e347e82757c4e05c2924ea39c4d4d22883f0cdfa sandbox/html-tree.pl SHA1 c23bbf801b303469d597679e29b1403d1196720b sandbox/ignore.pl SHA1 bb3e8d8523b5c283a529ee37cf80bb16e975bd60 sandbox/misc.pl SHA1 4af5f4607b388d1e739cdd662a613a689970709e sandbox/reftypes.pl SHA1 8ff4a4e10173a2d50de71a37c8eeaad09728db93 sandbox/scalar-util-instance.pl SHA1 a423d9158e2112c9afc7867cf83d3fa5bb9ef8e7 sandbox/tied.pl SHA1 f0501ee363990216d88240b07c3a568c8d8f6c51 t/00-load.t SHA1 3aa15ffe14c82d738f7da154a76204d3cdfbde07 t/Makefile SHA1 b3dd13fa656d4b3957d68c2e61532240bf241259 t/array.t SHA1 ba4b194184499e72cfa4e063133c05d5dbf32847 t/bug42903.t SHA1 daa6c20169d4e81bcd945d21b466d9c0e86fa863 t/circular.t SHA1 4b5ab9a6ec507e8cbc2fa3cfcdbd6f27a098ef5f t/contents.t SHA1 c36d428aabc808f2e7b43deebf75905c842c67eb t/faux_gtk.t SHA1 3235bc4504d0d89ae0b09f8695f201008990458b t/filehandle.t SHA1 0090ec05da42abecd5eb0945787a2d643bb2131f t/ignore.t SHA1 3bd2344683f026e0c04563bb88ba76a3e148359d t/lib/Test/Weaken/Test.pm SHA1 347489572fd329e591750a6a1abd24a7769f7d98 t/overload.t SHA1 6d479fdf2c338639187741e82164fe2ca001eeaf t/pod.t SHA1 6b531594aa11b1d8eca4851bc5d12e15da72ced4 t/poof.t SHA1 e78e6f844276129c25d44a6d05d77bc3cbc2f5db t/snippet.t SHA1 1c7261df0d88cb2bc1c0e11a688975613b03f565 t/stein.t SHA1 5c6ffacdcc558c3b9e70dcb35ecac2c9a4a4e344 t/synopsis.t SHA1 5bf1f3df40f7e04be3960623c08b8b7b6df726fc t/tied.t SHA1 776f2d8977e33cf5f67f4e6b8ab83ab4da2a0ba8 t/unfilled-array.t SHA1 97926e8ba169a8b91320e7071381224a5283ba9b t/various.t SHA1 abcb92c871d6c87cc4b890dc5df65aed4f28ca0a t/weaken.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.12 (GNU/Linux) iD8DBQFQuUj5LFMCIV9q3ToRAsckAJsE5Gn3ctLlvvmcUvwzUR8BCOUqcACeIoRn yl1bd0afnTUIlcba67IXNfc= =ukZY -----END PGP SIGNATURE----- Test-Weaken-3.022000/MANIFEST.SKIP0000644000175000017500000000072011716377570013556 0ustar gggg^MYMETA[.]json$ ^MYMETA[.]yml$ ^Makefile$ ^Test-Weaken-[0-9].[0-9]{3}_[0-9]{3}/ ^Test-Weaken-[0-9].[0-9]{3}_[0-9]{3}[.]tar[.]gz$ ^Test-Weaken-[0-9].[0-9]{6}/ ^Test-Weaken-[0-9].[0-9]{6}[.]tar[.]gz$ ^[.]git/* ^\.svn/ ^author[.]t/[.]gitignore$ ^author\.t/display\.errs$ ^author\.t/perlcritic\.errs$ ^blib/ ^junk$ ^pm_to_blib$ ^save/ # emacs backups ~$ # ExtUtils::MakeMaker leaving Makefile.old ^Makefile\.old$ # Kevin's dist stuff ^dist-deb ^up$ ^MANIFEST\.old$ Test-Weaken-3.022000/t/0002755000175000017500000000000012056244371012114 5ustar ggggTest-Weaken-3.022000/t/stein.t0000644000175000017500000000402111465421356013421 0ustar gggg#!perl use strict; use warnings; # The tests from Lincoln Stein's Devel::Cycle module use Scalar::Util qw(weaken isweak); use Test::More tests => 4; use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken') } sub brief_result { my $test = shift; my $unfreed_count = $test->test(); my $unfreed_proberefs = $test->unfreed_proberefs(); my @unfreed_strong = (); my @unfreed_weak = (); for my $proberef ( @{$unfreed_proberefs} ) { if ( ref $proberef eq 'REF' and isweak ${$proberef} ) { push @unfreed_weak, $proberef; } else { push @unfreed_strong, $proberef; } } return 'total: weak=' . $test->weak_probe_count() . q{; } . 'strong=' . $test->strong_probe_count() . q{; } . 'unfreed: weak=' . ( scalar @unfreed_weak ) . q{; } . 'strong=' . ( scalar @unfreed_strong ); } sub stein_1 { my $test = { fred => [qw(a b c d e)], ethel => [qw(1 2 3 4 5)], george => { martha => 23, agnes => 19 } }; $test->{george}{phyllis} = $test; $test->{fred}[3] = $test->{george}; $test->{george}{mary} = $test->{fred}; return $test; } sub stein_w1 { my $test = stein_1(); weaken( $test->{george}->{phyllis} ); return $test; } sub stein_w2 { my $test = stein_1(); weaken( $test->{george}->{phyllis} ); weaken( $test->{fred}[3] ); return $test; } Test::Weaken::Test::is( brief_result( Test::Weaken->new( \&stein_1 ) ), 'total: weak=0; strong=22; unfreed: weak=0; strong=21', q{Stein's test} ); Test::Weaken::Test::is( brief_result( Test::Weaken->new( \&stein_w1 ) ), 'total: weak=1; strong=21; unfreed: weak=0; strong=11', q{Stein's test weakened once} ); Test::Weaken::Test::is( brief_result( Test::Weaken->new( \&stein_w2 ) ), 'total: weak=2; strong=20; unfreed: weak=0; strong=0', q{Stein's test weakened twice} ); Test-Weaken-3.022000/t/bug42903.t0000644000175000017500000000362111465421356013463 0ustar gggg#!perl # This is the test case for Bug 42903. This bug was found by Kevin Ryde, # and he supplied the basics of this test case. use strict; use warnings; use Test::More tests => 3; use Data::Dumper; use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken'); } my $result = q{}; { my $leak; my $test = Test::Weaken::leaks( sub { my $aref = ['abc']; my $obj = { array => $aref }; $leak = $aref; return $obj; } ); my $unfreed_proberefs = $test ? $test->unfreed_proberefs() : []; for my $ix ( 0 .. $#{$unfreed_proberefs} ) { $result .= Data::Dumper->Dump( [ $unfreed_proberefs->[$ix] ], ["unfreed_$ix"] ); } $result .= Data::Dumper->Dump( [$leak], ['leak'] ); } Test::Weaken::Test::is( $result, <<'EOS', 'CPAN Bug ID 42903, example 1' ); $unfreed_0 = [ 'abc' ]; $unfreed_1 = \'abc'; $leak = [ 'abc' ]; EOS $result = q{}; { my $leak; my $test = Test::Weaken::leaks( sub { my $aref = [ 'def', ['ghi'] ]; my $obj = { array => $aref }; $leak = $aref; return $obj; } ); my $unfreed_proberefs = $test ? $test->unfreed_proberefs() : []; for my $ix ( 0 .. $#{$unfreed_proberefs} ) { $result .= Data::Dumper->Dump( [ $unfreed_proberefs->[$ix] ], ["unfreed_$ix"] ); } $result .= Data::Dumper->Dump( [$leak], ['leak'] ); } Test::Weaken::Test::is( $result, <<'EOS', 'CPAN Bug ID 42903, example 2' ); $unfreed_0 = [ 'def', [ 'ghi' ] ]; $unfreed_1 = \'def'; $unfreed_2 = \[ 'ghi' ]; $unfreed_3 = [ 'ghi' ]; $unfreed_4 = \'ghi'; $leak = [ 'def', [ 'ghi' ] ]; EOS Test-Weaken-3.022000/t/circular.t0000644000175000017500000000203311465421356014104 0ustar gggg#!perl # Based on the test case created by Kevin Ryde for #42502 # This is a basic circular reference class which undoes its circularities # under an explicit undo() method. This is a little like HTML::Tree. package MyCircular; use strict; use warnings; sub new { my ($class) = @_; my $self = bless { data => 'this is mycircular' }, $class; $self->{'circular'} = [$self]; return $self; } sub undo { my ($self) = @_; @{ $self->{'circular'} } = (); return 1; } package main; use strict; use warnings; use Test::Weaken; use Test::More tests => 2; use lib 't/lib'; use Test::Weaken::Test; my $test = Test::Weaken::leaks( sub { MyCircular->new }, sub { my ($obj) = @_; $obj->undo; } ); my $unfreed_count = $test ? $test->unfreed_count() : 0; Test::Weaken::Test::is( $unfreed_count, 0, 'good destructor' ); $test = Test::Weaken::leaks( sub { MyCircular->new }, sub { } ); $unfreed_count = $test ? $test->unfreed_count() : 0; Test::Weaken::Test::is( $unfreed_count, 5, 'null destructor' ); Test-Weaken-3.022000/t/various.t0000644000175000017500000003206111765215651013776 0ustar gggg#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 58; use Test::Weaken; # uncomment this to run the ### lines #use Smart::Comments; #------------------------------------------------------------------------------ # constructor returning multiple values { my $global = [ 123 ]; my $test = Test::Weaken::leaks(sub { my $local = [ 456 ]; return ($global, $local); }); my $unfreed_count = $test ? $test->unfreed_count() : 0; ok (defined $test, 'global/local multiple return -- leak detected'); is ($unfreed_count, 2, 'global/local multiple return -- count'); } { my $global = [ 123 ]; my $test = Test::Weaken::leaks(sub { my $local = [ 456 ]; return ($local, $global); }); ok (defined $test, 'local/global multiple return -- leak detected'); my $unfreed_count = $test ? $test->unfreed_count() : 0; is ($unfreed_count, 2, 'local/global multiple return -- count'); } #------------------------------------------------------------------------------ # destructor calls { my $destructor_called; Test::Weaken::leaks( sub { return [] }, sub { $destructor_called = 1; is (scalar(@_), 1, 'destructor called with 1 constructor values'); ok ($_[0] && ref $_[0] eq 'ARRAY'); } ); ok ($destructor_called); } # destructor called on multiple constructor values { my $destructor_called; Test::Weaken::leaks( sub { return [], {} }, sub { $destructor_called = 1; is (scalar(@_), 2, 'destructor called with 2 constructor values'); ok ($_[0] && ref $_[0] eq 'ARRAY'); ok ($_[1] && ref $_[1] eq 'HASH'); } ); ok ($destructor_called); } #------------------------------------------------------------------------------ # destructor_method calls { my $my_destroy_called; my @my_destroy_objects; { package MyDestructorMethod; sub new { my $class = shift; return bless { @_ }, $class; } sub my_destroy { my ($self) = @_; Test::More::is (scalar(@_), 1, 'my_destroy() called with 1 value'); $my_destroy_called++; push @my_destroy_objects, $self->{'n'}; } } # destructor_method called { $my_destroy_called = 0; Test::Weaken::leaks({ constructor => sub { return MyDestructorMethod->new; }, destructor_method => 'my_destroy'}); is ($my_destroy_called, 1); } # destructor_method called on each constructor return { $my_destroy_called = 0; @my_destroy_objects = (); Test::Weaken::leaks({ constructor => sub { return (MyDestructorMethod->new(n=>1), MyDestructorMethod->new(n=>2), MyDestructorMethod->new(n=>3)); }, destructor_method => 'my_destroy'}); is ($my_destroy_called, 3); is_deeply (\@my_destroy_objects, [1,2,3]); } } #------------------------------------------------------------------------------ # GLOB not tracked by default, but can be requested is (Test::Weaken::leaks(sub { return \*FOO }), undef); ok (Test::Weaken::leaks({ constructor => sub { return \*FOO }, tracked_types => ['GLOB'] })); #------------------------------------------------------------------------------ # file handle tracking claimed in the POD { my $contents_glob_IO = sub { my ($ref) = @_; if (ref($ref) eq 'GLOB') { return *$ref{IO}; } else { return; } }; { my $leaky_IO; my $leaks = Test::Weaken::leaks ({ constructor => sub { require Symbol; require File::Spec; my $fh = Symbol::gensym(); open $fh, File::Spec->devnull; $leaky_IO = *$fh{IO}; return [ $fh ]; }, contents => $contents_glob_IO, tracked_types => [ 'GLOB', 'IO' ], }); ok ($leaks); my $unfreed = ($leaks ? $leaks->unfreed_proberefs : []); is ($unfreed->[0], $leaky_IO); } { my $leaky_GLOB; my $leaks = Test::Weaken::leaks ({ constructor => sub { require Symbol; require File::Spec; my $fh = Symbol::gensym(); open $fh, File::Spec->devnull; $leaky_GLOB = $fh; return [ $fh ]; }, contents => $contents_glob_IO, tracked_types => [ 'GLOB', 'IO' ], }); ok ($leaks); my $unfreed = ($leaks ? $leaks->unfreed_proberefs : []); is ($unfreed->[0], $leaky_GLOB); } } #------------------------------------------------------------------------------ # poof { my ($weak_count, $strong_count, $weak_unfreed_aref, $strong_unfreed_aref) = Test::Weaken::poof (sub { return [] }); is ($weak_count, 0); is ($strong_count, 2); is (ref $weak_unfreed_aref, 'ARRAY'); is (ref $strong_unfreed_aref, 'ARRAY'); } #------------------------------------------------------------------------------ # weak reference not descended into { my $global = []; my $leaks = Test::Weaken::leaks ({ constructor => sub { my $href = { foo => $global }; require Scalar::Util; Scalar::Util::weaken($href->{'foo'}); return $href; }, # trace_following => 1, }); ok (defined $leaks); is ($leaks && $leaks->unfreed_count, 1); } #------------------------------------------------------------------------------ # ignore_preds { my $one = [ ]; my $two = { }; my $threething = 3; my $three = \$threething; sub my_pred1 { my ($ref) = @_; return $ref == $one; } sub my_pred2 { my ($ref) = @_; return $ref == $two; } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_preds => [ \&my_pred1 ], }); is ($leaks && $leaks->unfreed_count, 2); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two); }, ignore_preds => [ \&my_pred1, \&my_pred2 ], }); is ($leaks, undef); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_preds => [ \&my_pred1 ], ignore => \&my_pred2, }); is ($leaks && $leaks->unfreed_count, 1); } } #------------------------------------------------------------------------------ # ignore_class, ignore_classes { { package MyClassOne; sub new { my $class = shift; return bless { @_ }, $class; } } { package MyClassTwo; sub new { my $class = shift; return bless { @_ }, $class; } } { package MyClassThree; sub new { my $class = shift; my $self = shift; return bless \$self, $class; } } my $one = MyClassOne->new; my $two = MyClassTwo->new; my $three = MyClassThree->new; { my $leaks = Test::Weaken::leaks({ constructor => sub { return $one; }, ignore_class => 'MyClassOne', }); ok (! $leaks, 'ignore_class'); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_class => 'MyClassOne', }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 2); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_classes => ['MyClassOne', 'MyClassTwo'], }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 1); is ($leaks && $leaks->unfreed_proberefs->[0], $three); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_class => 'MyClassTwo', ignore_classes => ['MyClassThree'], }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 1); is ($leaks && $leaks->unfreed_proberefs->[0], $one); } } #------------------------------------------------------------------------------ # ignore_object, ignore_objects { my $one = [ ]; my $two = { }; my $threething = 3; my $three = \$threething; { my $leaks = Test::Weaken::leaks({ constructor => sub { return $one; }, ignore_object => $one, }); ok (! $leaks, 'ignore_object'); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return $one; }, ignore_object => undef, }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 1); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return $one; }, ignore_object => undef, ignore_objects => [ undef, undef ], }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 1); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_object => $two, }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 2); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_objects => [$one, $two], }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 1); is ($leaks && $leaks->unfreed_proberefs->[0], $three); } { my $leaks = Test::Weaken::leaks({ constructor => sub { return ($one, $two, $three); }, ignore_object => $two, ignore_objects => [$three], }); ok ($leaks); is ($leaks && $leaks->unfreed_count, 1); is ($leaks && $leaks->unfreed_proberefs->[0], $one); } } #------------------------------------------------------------------------------ # ignore of tied hashes as shown in the POD { my %global; my $test = Test::Weaken::leaks(sub { my $aref = [ \%global ]; return $aref; }, sub { my ($ref) = @_; return (ref $ref eq 'HASH' && tied %$ref); }); my $unfreed_count = $test ? $test->unfreed_count() : 0; ok (defined $test); is ($unfreed_count, 1); } { { package MyTieHash; sub TIEHASH { my ($class) = @_; return bless {}, $class; } sub FIRSTKEY { return; } } sub ignore_all_tied_hashes { my ($ref) = @_; return (ref $ref eq 'HASH' && tied %$ref); } my %global; tie %global, 'MyTieHash'; ### tied: tied %global my $test = Test::Weaken::leaks({ constructor => sub { my $aref = [ \%global ]; return $aref; }, ignore => \&ignore_all_tied_hashes, }); is ($test, undef); } #------------------------------------------------------------------------------ exit 0; Test-Weaken-3.022000/t/overload.t0000644000175000017500000000163611465421356014123 0ustar gggg#!perl # This is the test case for Bug 56722. This bug was found by Kevin Ryde. # He also suggested the right fix and supplied the core of the test case. use strict; use warnings; use Test::More tests => 3; use Data::Dumper; use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken'); } our $OVERLOAD_CALLS = 0; package MyOverload; use Carp; use overload '+' => \&add; use overload 'bool' => \&bool; sub new { my ( $class, $x ) = @_; return bless \$x, $class; } sub bool { $::OVERLOAD_CALLS++; return 1; } sub add { $::OVERLOAD_CALLS++; return 0; } package main; my $x = MyOverload->new('123'); my $leaks = Test::Weaken::leaks( sub { my $y = MyOverload->new('123'); return [ $x, $y ]; } ); Test::More::ok( $leaks, 'CPAN Bug ID 56722 leaks' ); Test::Weaken::Test::is( $::OVERLOAD_CALLS, 0, 'CPAN Bug ID 56722 no calls to overload functions' ); Test-Weaken-3.022000/t/00-load.t0000644000175000017500000000030111465421356013430 0ustar gggg#!perl use strict; use warnings; use Test::More tests => 1; BEGIN { Test::More::use_ok('Test::Weaken'); } Test::More::diag("Testing Test::Weaken $Test::Weaken::VERSION, Perl $], $^X"); Test-Weaken-3.022000/t/poof.t0000644000175000017500000000646311465421356013256 0ustar gggg#!perl # Test of deprecated, legacy interface. # I may remove this interface, but until I do, I guess I should test it. use strict; use warnings; use Test::More tests => 2; use Scalar::Util qw(isweak weaken reftype); use Data::Dumper; use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken'); } my ( $weak_count, $strong_count, $weak_unfreed_array, $strong_unfreed_array ) = Test::Weaken::poof( sub { my $x; my $y = [ \$x, 42 ]; $x = [ \$y, 711 ]; weaken( my $w1 = \$x ); weaken( my $w2 = \$y ); $x->[2] = \$w1; $y->[2] = \$w2; $x; } ); my $text = "Starting counts: w=$weak_count s=$strong_count\n" . 'Unfreed counts: w=' . scalar @{$weak_unfreed_array} . ' s=' . scalar @{$strong_unfreed_array} . "\n"; # names for the references, so checking the dump does not depend # on the specific hex value of locations for my $strong_unfreed ( @{$strong_unfreed_array} ) { $text .= Data::Dumper->Dump( [$strong_unfreed], [qw(strong)] ); } for my $weak_unfreed ( @{$weak_unfreed_array} ) { $text .= Data::Dumper->Dump( [$weak_unfreed], [qw(weak)] ); } Test::Weaken::Test::is( $text, <<'EOS', 'Dump of unfreed arrays' ); Starting counts: w=2 s=11 Unfreed counts: w=2 s=10 $strong = [ \[ \$strong, 42, \$strong->[0] ], 711, \${$strong->[0]}->[0] ]; $strong = \\[ \[ ${$strong}, 711, \${${$strong}}->[0] ], 42, \${$strong} ]; $strong = \711; $strong = \\\[ \[ ${${$strong}}, 42, \${${${$strong}}}->[0] ], 711, ${$strong} ]; $strong = \[ \[ $strong, 42, \${$strong}->[0] ], 711, \$strong ]; $strong = \[ \[ $strong, 711, \${$strong}->[0] ], 42, \$strong ]; $strong = [ \[ \$strong, 711, \$strong->[0] ], 42, \${$strong->[0]}->[0] ]; $strong = \\[ \[ ${$strong}, 42, \${${$strong}}->[0] ], 711, \${$strong} ]; $strong = \42; $strong = \\\[ \[ ${${$strong}}, 711, \${${${$strong}}}->[0] ], 42, ${$strong} ]; $weak = \\[ \[ ${$weak}, 42, \${${$weak}}->[0] ], 711, $weak ]; $weak = \\[ \[ ${$weak}, 711, \${${$weak}}->[0] ], 42, $weak ]; EOS Test-Weaken-3.022000/t/synopsis.t0000644000175000017500000000454211710142103014155 0ustar gggg#!/usr/bin/perl -w use strict; use warnings; use Test::More; use Fatal qw(open close); BEGIN { unless ($] >= 5.008) { plan skip_all => 'due to test code no good for 5.006 yet'; } plan tests => 2; } use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken') } ## no critic (InputOutput::RequireBriefOpen) open my $save_stdout, '>&STDOUT'; ## use critic close STDOUT; my $code_output; open STDOUT, q{>}, \$code_output; ## use Marpa::Test::Display synopsis use Test::Weaken qw(leaks); use Data::Dumper; use Math::BigInt; use Math::BigFloat; use Carp; use English qw( -no_match_vars ); my $good_test = sub { my $obj1 = Math::BigInt->new('42'); my $obj2 = Math::BigFloat->new('7.11'); [ $obj1, $obj2 ]; }; if ( !leaks($good_test) ) { print "No leaks in test 1\n" or Carp::croak("Cannot print to STDOUT: $ERRNO"); } else { print "There were memory leaks from test 1!\n" or Carp::croak("Cannot print to STDOUT: $ERRNO"); } my $bad_test = sub { my $array = [ 42, 711 ]; push @{$array}, $array; $array; }; my $bad_destructor = sub {'I am useless'}; my $tester = Test::Weaken::leaks( { constructor => $bad_test, destructor => $bad_destructor, } ); if ($tester) { my $unfreed_proberefs = $tester->unfreed_proberefs(); my $unfreed_count = @{$unfreed_proberefs}; printf "Test 2: %d of %d original references were not freed\n", $tester->unfreed_count(), $tester->probe_count() or Carp::croak("Cannot print to STDOUT: $ERRNO"); print "These are the probe references to the unfreed objects:\n" or Carp::croak("Cannot print to STDOUT: $ERRNO"); for my $ix ( 0 .. $#{$unfreed_proberefs} ) { print Data::Dumper->Dump( [ $unfreed_proberefs->[$ix] ], ["unfreed_$ix"] ) or Carp::croak("Cannot print to STDOUT: $ERRNO"); } } ## no Marpa::Test::Display open STDOUT, q{>&}, $save_stdout; Test::Weaken::Test::is( $code_output, <<'EOS', 'synopsis output' ); No leaks in test 1 Test 2: 4 of 5 original references were not freed These are the probe references to the unfreed objects: $unfreed_0 = [ 42, 711, $unfreed_0 ]; $unfreed_1 = \42; $unfreed_2 = \711; $unfreed_3 = \[ 42, 711, ${$unfreed_3} ]; EOS Test-Weaken-3.022000/t/snippet.t0000644000175000017500000002402711710141334013755 0ustar gggg#!perl use strict; use warnings; use Test::More; use Fatal qw(open close); BEGIN { unless ($] >= 5.008) { plan skip_all => 'due to test code no good for 5.006 yet'; } plan tests => 9; } use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken') } use Carp; package My_Object; use Math::BigInt; use Math::BigFloat; sub new { my $obj1 = Math::BigInt->new('42'); my $obj2 = Math::BigFloat->new('7.11'); return [ $obj1, $obj2 ]; } package Buggy_Object; use Scalar::Util qw(weaken); sub new { my $array = [ 42, 711 ]; my $weak_ref; weaken( $weak_ref = $array ); my $strong_ref = $array; push @{$array}, $array; push @{$array}, \$weak_ref; push @{$array}, \$strong_ref; return $array; } package main; my $test_output; package Test::Weaken::Test::Snippet::leaks; sub destroy_buggy_object { } $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output = q{}; open STDOUT, q{>}, \$code_output; ## use Marpa::Test::Display leaks snippet use Test::Weaken; use English qw( -no_match_vars ); my $tester = Test::Weaken::leaks( { constructor => sub { Buggy_Object->new() }, destructor => \&destroy_buggy_object, } ); if ($tester) { print "There are leaks\n" or Carp::croak("Cannot print to STDOUT: $ERRNO"); } ## no Marpa::Test::Display open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'leaks snippet' ); There are leaks EOS package Test::Weaken::Test::Snippet::unfreed_proberefs; $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output = q{!!!}; open STDOUT, q{>}, \$code_output; ## use Marpa::Test::Display unfreed_proberefs snippet use Test::Weaken; use English qw( -no_match_vars ); my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() } ); if ($tester) { my $unfreed_proberefs = $tester->unfreed_proberefs(); my $unfreed_count = @{$unfreed_proberefs}; printf "%d of %d references were not freed\n", $tester->unfreed_count(), $tester->probe_count() or Carp::croak("Cannot print to STDOUT: $ERRNO"); print "These are the probe references to the unfreed objects:\n" or Carp::croak("Cannot print to STDOUT: $ERRNO"); for my $ix ( 0 .. $#{$unfreed_proberefs} ) { print Data::Dumper->Dump( [ $unfreed_proberefs->[$ix] ], ["unfreed_$ix"] ) or Carp::croak("Cannot print to STDOUT: $ERRNO"); } } ## no Marpa::Test::Display open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'unfreed_proberefs snippet' ); 8 of 9 references were not freed These are the probe references to the unfreed objects: $unfreed_0 = [ 42, 711, $unfreed_0, \$unfreed_0, \$unfreed_0 ]; $unfreed_1 = \42; $unfreed_2 = \711; $unfreed_3 = \[ 42, 711, ${$unfreed_3}, \${$unfreed_3}, \${$unfreed_3} ]; $unfreed_4 = \\[ 42, 711, ${${$unfreed_4}}, ${$unfreed_4}, \${${$unfreed_4}} ]; $unfreed_5 = \\[ 42, 711, ${${$unfreed_5}}, \${${$unfreed_5}}, ${$unfreed_5} ]; $unfreed_6 = \[ 42, 711, ${$unfreed_6}, \${$unfreed_6}, $unfreed_6 ]; $unfreed_7 = \[ 42, 711, ${$unfreed_7}, $unfreed_7, \${$unfreed_7} ]; EOS package Test::Weaken::Test::Snippet::unfreed_count; $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output = q{}; open STDOUT, q{>}, \$code_output; TEST: for my $i (0) { ## use Marpa::Test::Display unfreed_count snippet use Test::Weaken; use English qw( -no_match_vars ); my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() } ); next TEST if not $tester; printf "%d objects were not freed\n", $tester->unfreed_count(), or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## no Marpa::Test::Display } # TEST open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'unfreed_count snippet' ); 8 objects were not freed EOS package Test::Weaken::Test::Snippet::probe_count; sub destroy_buggy_object { } $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output = q{}; open STDOUT, q{>}, \$code_output; TEST: for my $i (0) { ## use Marpa::Test::Display probe_count snippet use Test::Weaken; use English qw( -no_match_vars ); my $tester = Test::Weaken::leaks( { constructor => sub { Buggy_Object->new() }, destructor => \&destroy_buggy_object, } ); next TEST if not $tester; printf "%d of %d objects were not freed\n", $tester->unfreed_count(), $tester->probe_count() or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## no Marpa::Test::Display } # TEST open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'probe_count snippet' ); 8 of 9 objects were not freed EOS package Test::Weaken::Test::Snippet::weak_probe_count; $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output = q{}; open STDOUT, q{>}, \$code_output; TEST: for my $i (0) { ## use Marpa::Test::Display weak_probe_count snippet use Test::Weaken; use Scalar::Util qw(isweak); use English qw( -no_match_vars ); my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() }, ); next TEST if not $tester; my $weak_unfreed_reference_count = scalar grep { ref $_ eq 'REF' and isweak( ${$_} ) } @{ $tester->unfreed_proberefs() }; printf "%d of %d weak references were not freed\n", $weak_unfreed_reference_count, $tester->weak_probe_count(), or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## no Marpa::Test::Display } # TEST open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'weak_probe_count snippet' ); 1 of 1 weak references were not freed EOS package Test::Weaken::Test::Snippet::strong_probe_count; sub destroy_buggy_object { } $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output = q{}; open STDOUT, q{>}, \$code_output; TEST: for my $i (0) { ## use Marpa::Test::Display strong_probe_count snippet use Test::Weaken; use English qw( -no_match_vars ); use Scalar::Util qw(isweak); my $tester = Test::Weaken::leaks( { constructor => sub { Buggy_Object->new() }, destructor => \&destroy_buggy_object, } ); next TEST if not $tester; my $proberefs = $tester->unfreed_proberefs(); my $strong_unfreed_object_count = grep { ref $_ ne 'REF' or not isweak( ${$_} ) } @{$proberefs}; my $strong_unfreed_reference_count = grep { ref $_ eq 'REF' and not isweak( ${$_} ) } @{$proberefs}; printf "%d of %d strong objects were not freed\n", $strong_unfreed_object_count, $tester->strong_probe_count(), or Carp::croak("Cannot print to STDOUT: $ERRNO"); printf "%d of the unfreed strong objects were references\n", $strong_unfreed_reference_count or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## no Marpa::Test::Display } # TEST open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'strong_probe_count snippet' ); 7 of 8 strong objects were not freed 4 of the unfreed strong objects were references EOS package Test::Weaken::Test::Snippet::new; $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output; open STDOUT, q{>}, \$code_output; no warnings 'redefine'; use warnings; ## use Marpa::Test::Display new snippet use Test::Weaken; use English qw( -no_match_vars ); my $tester = Test::Weaken->new( sub { My_Object->new() } ); my $unfreed_count = $tester->test(); my $proberefs = $tester->unfreed_proberefs(); printf "%d of %d objects freed\n", $unfreed_count, $tester->probe_count() or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## no Marpa::Test::Display open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'new snippet' ); 0 of 18 objects freed EOS package Test::Weaken::Test::Snippet::test; sub destroy_my_object { } $test_output = do { open my $save_stdout, '>&STDOUT'; close STDOUT; my $code_output; open STDOUT, q{>}, \$code_output; no warnings 'redefine'; use warnings; ## use Marpa::Test::Display test snippet use Test::Weaken; use English qw( -no_match_vars ); my $tester = Test::Weaken->new( { constructor => sub { My_Object->new() }, destructor => \&destroy_my_object, } ); printf "There are %s\n", ( $tester->test() ? 'leaks' : 'no leaks' ) or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## no Marpa::Test::Display open STDOUT, q{>&}, $save_stdout; close $save_stdout; $code_output; }; Test::Weaken::Test::is( $test_output, <<'EOS', 'test snippet' ); There are no leaks EOS Test-Weaken-3.022000/t/array.t0000644000175000017500000000673411723005007013416 0ustar gggg#!perl use strict; use warnings; use Test::More tests => 2; use Scalar::Util qw(weaken); use Data::Dumper; use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken'); } my $test = Test::Weaken->new( sub { my $x; my $y = [ \$x, 42 ]; $x = [ \$y, 711 ]; weaken( my $w1 = \$x ); weaken( my $w2 = \$y ); $x->[2] = \$w1; $y->[2] = \$w2; $x; } ); my $unfreed_count = $test->test(); my $probe_count = $test->probe_count(); my $unfreed_proberefs = $test->unfreed_proberefs(); my $text = "Checking $probe_count objects\n" . "$unfreed_count objects were not freed:\n"; # names for the references, so checking the dump does not depend # on the specific hex value of locations for my $ix ( 0 .. $#{$unfreed_proberefs} ) { $text .= Data::Dumper->Dump( [ $unfreed_proberefs->[$ix] ], ["unfreed_$ix"] ); } Test::Weaken::Test::is( $text, <<'EOS', 'Dump of unfreed arrays' ); Checking 13 objects 12 objects were not freed: $unfreed_0 = [ \[ \$unfreed_0, 42, \$unfreed_0->[0] ], 711, \${$unfreed_0->[0]}->[0] ]; $unfreed_1 = \\[ \[ ${$unfreed_1}, 711, \${${$unfreed_1}}->[0] ], 42, \${$unfreed_1} ]; $unfreed_2 = \711; $unfreed_3 = \\\[ \[ ${${$unfreed_3}}, 42, \${${${$unfreed_3}}}->[0] ], 711, ${$unfreed_3} ]; $unfreed_4 = \\[ \[ ${$unfreed_4}, 42, \${${$unfreed_4}}->[0] ], 711, $unfreed_4 ]; $unfreed_5 = \[ \[ $unfreed_5, 42, \${$unfreed_5}->[0] ], 711, \$unfreed_5 ]; $unfreed_6 = \[ \[ $unfreed_6, 711, \${$unfreed_6}->[0] ], 42, \$unfreed_6 ]; $unfreed_7 = [ \[ \$unfreed_7, 711, \$unfreed_7->[0] ], 42, \${$unfreed_7->[0]}->[0] ]; $unfreed_8 = \\[ \[ ${$unfreed_8}, 42, \${${$unfreed_8}}->[0] ], 711, \${$unfreed_8} ]; $unfreed_9 = \42; $unfreed_10 = \\\[ \[ ${${$unfreed_10}}, 711, \${${${$unfreed_10}}}->[0] ], 42, ${$unfreed_10} ]; $unfreed_11 = \\[ \[ ${$unfreed_11}, 711, \${${$unfreed_11}}->[0] ], 42, $unfreed_11 ]; EOS Test-Weaken-3.022000/t/faux_gtk.t0000644000175000017500000000217311465421356014115 0ustar gggg#!perl # Based on the test case created by Kevin Ryde for #42502 # All MyObject instances are held in @INSTANCES, only removed by an explicit # destroy(). This is like Gtk2::Window from perl-gtk2 where top-level # windows are held by gtk in the "list_toplevels" and stay alive until # explicitly destroyed. package MyObject; use strict; use warnings; our @INSTANCES; sub new { my ($class) = @_; my $self = bless { data => ['this is a myobject'] }, $class; push @INSTANCES, $self; return $self; } sub destroy { my ($self) = @_; return ( @INSTANCES = grep { $_ != $self } @INSTANCES ); } package main; use strict; use warnings; use Test::Weaken; use Test::More tests => 2; use lib 't/lib'; use Test::Weaken::Test; @INSTANCES = (); my $test = Test::Weaken::leaks( sub { MyObject->new }, sub { my ($obj) = @_; $obj->destroy; } ); Test::More::ok( ( !$test ), 'good destructor' ); @INSTANCES = (); $test = Test::Weaken::leaks( sub { return MyObject->new }, sub { } ); my $unfreed_count = $test ? $test->unfreed_count() : 0; Test::Weaken::Test::is( $unfreed_count, 4, 'no-op destructor' ); Test-Weaken-3.022000/t/Makefile0000644000175000017500000000011011465421356013545 0ustar gggg .PHONY: all critic display all: -(cd ..; prove -I../lib -Ilib t/*.t) Test-Weaken-3.022000/t/lib/0002755000175000017500000000000012056244371012662 5ustar ggggTest-Weaken-3.022000/t/lib/Test/0002755000175000017500000000000012056244371013601 5ustar ggggTest-Weaken-3.022000/t/lib/Test/Weaken/0002755000175000017500000000000012056244371015013 5ustar ggggTest-Weaken-3.022000/t/lib/Test/Weaken/Test.pm0000644000175000017500000000115711465421356016275 0ustar ggggpackage Test::Weaken::Test; use strict; use warnings; use Carp; Carp::croak('Test::More not loaded') unless defined &Test::More::is; BEGIN { ## no critic (BuiltinFunctions::ProhibitStringyEval) ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval) eval 'use Test::Differences'; ## use critic } use Data::Dumper; ## no critic (Subroutines::RequireArgUnpacking) sub is { ## use critic goto &Test::Differences::eq_or_diff if defined &Test::Differences::eq_or_diff && @_ > 1; @_ = map { ref $_ ? Data::Dumper::Dumper(@_) : $_ } @_; goto &Test::More::is; } ## end sub is 1; Test-Weaken-3.022000/t/unfilled-array.t0000644000175000017500000000161211465421356015220 0ustar gggg#!/usr/bin/perl # These test cases were created by Kevin Ryde. use strict; use warnings; use Test::Weaken; use Test::More tests => 4; { my $leaks = Test::Weaken::leaks( sub { my @array; $#array = 1; return \@array; } ); Test::More::ok( !$leaks, 'pre-extended array' ); } { my $leaks = Test::Weaken::leaks( sub { my @array = ( 123, 456 ); delete $array[0]; return \@array; } ); Test::More::ok( !$leaks, 'array element delete()' ); } { my @global; $#global = 1; my $leaks = Test::Weaken::leaks( sub { return \@global; } ); Test::More::ok( !exists $global[0], q{leaks doesn't bring global[0] into existence} ); Test::More::ok( !exists $global[1], q{leaks doesn't bring global[1] into existence} ); } exit 0; Test-Weaken-3.022000/t/ignore.t0000644000175000017500000004350512055030060013554 0ustar gggg#!perl # The first, basic test case for the ignore option # was supplied by Kevin Ryde. use strict; use warnings; use Test::More; use Data::Dumper; use English qw( -no_match_vars ); use Fatal qw(open close); # force sorted in got/want checks # (though checking the string display is probably a bit fragile) $Data::Dumper::Sortkeys = 1; BEGIN { unless ($] >= 5.008) { plan skip_all => 'due to test code no good for 5.006 yet'; } plan tests => 24; } use lib 't/lib'; use Test::Weaken::Test; sub divert_stderr { my $stderr = q{}; open my $save_stderr, '>&STDERR'; close STDERR; open STDERR, '>', \$stderr; return sub { open STDERR, '>&', $save_stderr; close $save_stderr; return $stderr; }; } package MyGlobal; my %cache; sub new { my ( $class, $name ) = @_; return ( $cache{$name} ||= bless { name => $name, array => ["something for $name"], }, $class ); } package MyObject; sub new { my ($class) = @_; return bless { one => MyGlobal->new('ishtar'), two => MyGlobal->new('ereskigal'), }, $class; } package MyCycle; sub new { my ($class) = @_; my $weak; my $strong = \$weak; my $self = \$strong; Scalar::Util::weaken( $weak = \$self ); return bless [ \$self ], $class; } package DeepObject; sub new { my ($class) = @_; return bless { one => { two => { three => 4 } } }, $class; } package main; use Scalar::Util; use Data::Dumper; BEGIN { Test::More::use_ok('Test::Weaken'); } use lib 't/lib'; use Test::Weaken::Test; #------------------------------------------------------------------------------ # ignore option ## use Marpa::Test::Display ignore snippet sub ignore_my_global { my ($probe) = @_; return ( Scalar::Util::blessed($probe) && $probe->isa('MyGlobal') ); } { my $tester = Test::Weaken::leaks({ constructor => sub { MyObject->new() }, ignore => \&ignore_my_global, }); is ($tester, undef, 'ignore of ignore_my_global() ignores everything'); } { # This test previously looked at all the $tester->unfreed_proberefs(), but # think it's enough to just ask that this form results in some unfreed # whereas ignore_my_global() above does not. my $tester = Test::Weaken::leaks({ constructor => sub { MyObject->new() }, ignore => sub { return; } }); ok ($tester, 'ignore of always false leaves unfreed'); } #------------------------------------------------------------------------------ # ignore option with check_ignore() wrapper ## use Marpa::Test::Display check_ignore 1 arg snippet my $tester = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore => Test::Weaken::check_ignore( \&ignore_my_global ), } ); ## no Marpa::Test::Display if ( not $tester ) { Test::More::pass('wrappered good ignore'); } else { Test::Weaken::Test::is( $tester->unfreed_proberefs, q{}, 'wrappered good ignore' ); } sub overwriting_ignore { my ($probe_ref) = @_; ${$probe_ref} = 'XXX'; return 0; } my $restore = divert_stderr(); my $eval_return = eval { Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore => Test::Weaken::check_ignore( \&overwriting_ignore ), } ); 1; }; my $stderr = &{$restore}; my $eval_result = 'proberef overwrite not caught'; if ( not $eval_return ) { $eval_result = $EVAL_ERROR; } # \.? allows either "at line 170." or "at line 170" # Normally Carp.pm makes a string ending "170\n" which die() leaves alone. # But have seen "170.\n" which is from die() when it gets a string without # a newline already. Dunno why the croak()s in Weaken.pm would reach there. # Old Carp.pm might have done it if not finding a caller to report, maybe. # $eval_result =~ s{ [ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $ }{ at line }gxms; Test::Weaken::Test::is( ( $stderr . $eval_result ), <<'EOS', Probe referent changed by ignore call Terminating ignore callbacks after finding 1 error(s) at line EOS 'wrappered overwriting ignore' ); ## no critic (Subroutines::RequireArgUnpacking) # Trigger warnings, while replacing everything with its equivalent sub buggy_ignore { $_[0] = \${ $_[0] } if Scalar::Util::reftype $_[0] eq 'REF'; if ( Scalar::Util::reftype $_[0] eq 'ARRAY' ) { my @temp = @{ $_[0] }; $_[0] = \@temp; } if ( Scalar::Util::reftype $_[0] eq 'HASH' ) { my %temp = %{ $_[0] }; $_[0] = \%temp; } if ( Scalar::Util::reftype $_[0] eq 'REF' ) { my $temp = ${ $_[0] }; $_[0] = \$temp; } return; } ## use critic my %counted_error_expected = ( 0 => <<'EOS', Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line EOS 1 => <<'EOS', Probe referent changed by ignore call Terminating ignore callbacks after finding 1 error(s) at line EOS 2 => <<'EOS', Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Terminating ignore callbacks after finding 2 error(s) at line EOS 3 => <<'EOS', Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Terminating ignore callbacks after finding 3 error(s) at line EOS 9 => <<'EOS', Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line Probe referent changed by ignore call Above errors reported at line EOS ); sub counted_errors { my ($error_count) = @_; $restore = divert_stderr(); $eval_return = eval { ## use Marpa::Test::Display check_ignore snippet Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore => Test::Weaken::check_ignore( \&buggy_ignore, $error_count ), } ); ## no Marpa::Test::Display }; $stderr = &{$restore}; # the exact addresses will vary, so just X them out $stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms; $stderr .= $EVAL_ERROR if not $eval_return; $stderr =~ s{ [ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $ }{ at line }gxms; Test::Weaken::Test::is( $stderr, $counted_error_expected{$error_count}, "wrappered overwriting ignore, max_errors=$error_count" ); return 1; } counted_errors(0); counted_errors(1); counted_errors(2); counted_errors(3); counted_errors(9); sub noop_ignore { return 0; } $tester = Test::Weaken::leaks( { constructor => sub { MyCycle->new() }, ignore => \&noop_ignore, } ); if ( not $tester ) { Test::More::pass('cycle w/ no-op ignore'); } else { Test::Weaken::Test::is( $tester->unfreed_proberefs, q{}, 'cycle w/ no-op ignore' ); } ## no critic (Subroutines::RequireArgUnpacking) sub copying_ignore { if ( Scalar::Util::reftype $_[0] eq 'REF' ) { my $temp = ${ $_[0] }; ${ $_[0] } = $temp; } return 0; } ## use critic $tester = Test::Weaken::leaks( { constructor => sub { MyCycle->new() }, ignore => \©ing_ignore, } ); if ( not $tester ) { Test::More::pass('cycle w/ copying ignore'); } else { my $unfreed = $tester->unfreed_proberefs; Test::Weaken::Test::is( Data::Dumper->Dump( [$unfreed], [qw(unfreed)] ), <<'EOS', $unfreed = [ \\\$unfreed->[0], ${$unfreed->[0]}, ${${$unfreed->[0]}} ]; EOS 'cycle w/ copying ignore' ); } $restore = divert_stderr(); $eval_return = eval { $tester = Test::Weaken::leaks( { constructor => sub { MyCycle->new() }, ignore => Test::Weaken::check_ignore( \©ing_ignore, 2 ), } ); }; $stderr = &{$restore}; if ( not $tester ) { Test::More::pass('cycle w/ copying & error callback'); } else { my $unfreed = $tester->unfreed_proberefs; Test::Weaken::Test::is( Data::Dumper->Dump( [$unfreed], [qw(unfreed)] ), <<'EOS', $unfreed = [ \\\$unfreed->[0], ${$unfreed->[0]}, ${${$unfreed->[0]}} ]; EOS 'unfreed refs for cycle w/ copying' ); } # the exact addresses will vary, so just X them out $stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms; $stderr .= $EVAL_ERROR if not $eval_return; $stderr =~ s{ [ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $ }{ at line }gxms; Test::Weaken::Test::is( $stderr, <<'EOS', Probe referent strengthened by ignore call Above errors reported at line EOS 'stderr for cycle w/ copying' ); sub cause_deep_problem { my ($proberef) = @_; if ( ref $proberef eq 'REF' and Scalar::Util::reftype ${$proberef} eq 'HASH' and exists ${$proberef}->{one} ) { ${$proberef}->{one}->{bad} = 42; } return 0; } my %counted_compare_depth_expected = ( 0 => <<'EOS', $proberef_before_callback = \bless( { 'one' => { 'two' => { 'three' => 4 } } }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => { 'bad' => 42, 'two' => { 'three' => 4 } } }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS 1 => <<'EOS', EOS 2 => <<'EOS', EOS 3 => <<'EOS', $proberef_before_callback = \bless( { 'one' => { 'two' => 'HASH(0xXXXXXXX)' } }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => { 'bad' => 42, 'two' => 'HASH(0xXXXXXXX)' } }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS 4 => <<'EOS', $proberef_before_callback = \bless( { 'one' => { 'two' => { 'three' => 4 } } }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => { 'bad' => 42, 'two' => { 'three' => 4 } } }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS ); sub counted_compare_depth { my ($compare_depth) = @_; $restore = divert_stderr(); $eval_return = eval { Test::Weaken::leaks( { constructor => sub { DeepObject->new() }, ignore => Test::Weaken::check_ignore( \&cause_deep_problem, 99, $compare_depth, $compare_depth ), } ); }; $stderr = &{$restore}; # the exact addresses will vary, so just X them out $stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms; $stderr .= $EVAL_ERROR if not $eval_return; $stderr =~ s{ [ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $ }{ at line }gxms; Test::Weaken::Test::is( $stderr, $counted_compare_depth_expected{$compare_depth}, "deep problem, compare depth=$compare_depth" ); return 1; } counted_compare_depth(0); counted_compare_depth(1); counted_compare_depth(2); counted_compare_depth(3); counted_compare_depth(4); my %counted_reporting_depth_expected = ( 0 => <<'EOS', $proberef_before_callback = \bless( { 'one' => { 'two' => { 'three' => 4 } } }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => { 'bad' => 42, 'two' => { 'three' => 4 } } }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS 1 => <<'EOS', $proberef_before_callback = \'DeepObject=HASH(0xXXXXXXX)'; $proberef_after_callback = \'DeepObject=HASH(0xXXXXXXX)'; Probe referent changed by ignore call Above errors reported at line EOS 2 => <<'EOS', $proberef_before_callback = \bless( { 'one' => 'HASH(0xXXXXXXX)' }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => 'HASH(0xXXXXXXX)' }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS 3 => <<'EOS', $proberef_before_callback = \bless( { 'one' => { 'two' => 'HASH(0xXXXXXXX)' } }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => { 'bad' => 42, 'two' => 'HASH(0xXXXXXXX)' } }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS 4 => <<'EOS', $proberef_before_callback = \bless( { 'one' => { 'two' => { 'three' => 4 } } }, 'DeepObject' ); $proberef_after_callback = \bless( { 'one' => { 'bad' => 42, 'two' => { 'three' => 4 } } }, 'DeepObject' ); Probe referent changed by ignore call Above errors reported at line EOS ); sub counted_reporting_depth { my ($reporting_depth) = @_; $restore = divert_stderr(); $eval_return = eval { ## use Marpa::Test::Display check_ignore 4 arg snippet $tester = Test::Weaken::leaks( { constructor => sub { DeepObject->new() }, ignore => Test::Weaken::check_ignore( \&cause_deep_problem, 99, 0, $reporting_depth ), } ); ## no Marpa::Test::Display }; $stderr = &{$restore}; # the exact addresses will vary, so just X them out $stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms; $stderr .= $EVAL_ERROR if not $eval_return; $stderr =~ s{ [ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $ }{ at line }gxms; Test::Weaken::Test::is( $stderr, $counted_reporting_depth_expected{$reporting_depth}, "deep problem, reporting depth=$reporting_depth" ); return 1; } counted_reporting_depth(0); counted_reporting_depth(1); counted_reporting_depth(2); counted_reporting_depth(3); counted_reporting_depth(4); Test-Weaken-3.022000/t/tied.t0000644000175000017500000000540611710137453013227 0ustar gggg#!/usr/bin/perl # Test cases provided by Kevin Ryde, # most with only minor changes. use strict; use warnings; use Test::Weaken; use Test::More tests => 5; use Fatal qw(open read); use Symbol; ## no critic (Miscellanea::ProhibitTies) package MyTiedFileHandle; my $leaky_file_handle; sub TIEHANDLE { my ($class) = @_; my $i; my $tied_object = bless \$i, $class; $leaky_file_handle = $tied_object; return $tied_object; } ## end sub TIEHANDLE ## no critic (Subroutines::RequireArgUnpacking) sub READ { my $bufref = \$_[1]; ## use critic my ( $self, undef, $len, $offset ) = @_; defined $offset or $offset = 0; ${$bufref} .= 'a'; return 1; } ## end sub READ package MyTie; my $leaky; sub TIESCALAR { my ($class) = @_; my $tobj = bless {}, $class; $leaky = $tobj; return $tobj; } ## end sub TIESCALAR sub TIEHASH { goto \&TIESCALAR; } sub FIRSTKEY { return; # no keys } sub TIEARRAY { goto \&TIESCALAR; } sub FETCHSIZE { return 0; # no array elements } sub TIEHANDLE { goto \&TIESCALAR; } package main; { my $test = Test::Weaken::leaks( sub { my $var; tie $var, 'MyTie'; return \$var; } ); my $unfreed_count = $test ? $test->unfreed_count() : 0; Test::More::is( $unfreed_count, 1, 'caught unfreed tied scalar' ); } { my $test = Test::Weaken::leaks( sub { my %var; tie %var, 'MyTie'; return \%var; } ); my $unfreed_count = $test ? $test->unfreed_count() : 0; Test::More::is( $unfreed_count, 1, 'caught unfreed tied hash' ); } { my $test = Test::Weaken::leaks( sub { my @var; tie @var, 'MyTie'; return \@var; } ); my $unfreed_count = $test ? $test->unfreed_count() : 0; Test::More::is( $unfreed_count, 1, 'caught unfreed tied array' ); } { my $test = Test::Weaken::leaks( { constructor => sub { our $FILEHANDLE; my $fh = *FILEHANDLE{'GLOB'}; tie ${$fh}, 'MyTiedFileHandle'; my $read; read $fh, $read, 1; if ( $read ne 'a' ) { Carp::croak('Problem with tied file handle'); } return $fh; }, } ); my $unfreed_count = $test ? $test->unfreed_count() : 0; my $unfreed_reftypes = q{}; if ($test) { my $unfreed = $test->unfreed_proberefs; $unfreed_reftypes = ( join q{ }, sort map { ref $_ } @{$unfreed} ); } Test::More::is( $unfreed_count, 1, 'caught unfreed tied file handle' ); Test::More::is( $unfreed_reftypes, 'MyTiedFileHandle', 'matched unfreed refs from tied file handle' ); } exit 0; Test-Weaken-3.022000/t/contents.t0000644000175000017500000000623111465421356014141 0ustar gggg#!/usr/bin/perl # This code, as is the case with much of the other test code is # modified in minor ways from the original test case created # by Kevin Ryde. # Kevin Ryde: MyObject has data hidden away from Test::Weaken's normal # traversals, in this case separate %data and %moredata hashes. This is # like an "inside-out" object, and as is sometimes done for extra data # in a subclass. It also resembles case where data is kept only in C # code structures. package MyObject; use strict; use warnings; use Test::More tests => 3; use English qw( -no_match_vars ); use Fatal qw(open close); use Test::Weaken; use Data::Dumper; use lib 't/lib'; use Test::Weaken::Test; my %data; my %moredata; sub construct_data { return ['extra data']; } sub construct_more_data { return [ 'more extra data', ['with a sub-array too'] ]; } sub new { my ($class) = @_; my $scalar = 42; my $self = \$scalar; $data{ $self + 0 } = construct_data; $moredata{ $self + 0 } = construct_more_data; return bless $self, $class; } ## end sub new sub DESTROY { my ($self) = @_; delete $data{ $self + 0 }; delete $moredata{ $self + 0 }; return; } ## end sub DESTROY sub data { my ($self) = @_; return $data{ $self + 0 }; } sub moredata { my ($self) = @_; return $moredata{ $self + 0 }; } ## use Marpa::Test::Display contents sub snippet sub contents { my ($probe) = @_; return unless Scalar::Util::reftype $probe eq 'REF'; my $thing = ${$probe}; return unless Scalar::Util::blessed($thing); return unless $thing->isa('MyObject'); return ( $thing->data, $thing->moredata ); } ## end sub MyObject::contents ## no Marpa::Test::Display package main; { ## use Marpa::Test::Display contents named arg snippet my $tester = Test::Weaken::leaks( { constructor => sub { return MyObject->new }, contents => \&MyObject::contents } ); ## no Marpa::Test::Display Test::More::is( $tester, undef, 'good weaken of MyObject' ); } # Leaky Data Detection { my $leak; my $self_index; my $tester = Test::Weaken::leaks( { constructor => sub { my $obj = MyObject->new; $self_index = $obj + 0; $leak = $obj->data; return $obj; }, contents => \&MyObject::contents } ); my $test_name = 'leaky data detection'; if ( not $tester ) { Test::More::fail($test_name); } else { Test::More::is_deeply( $leak, MyObject->construct_data, $test_name ); } } # More Leaky Data Detection { my $leak; my $self_index; my $tester = Test::Weaken::leaks( { constructor => sub { my $obj = MyObject->new; $self_index = $obj + 0; $leak = $obj->moredata; return $obj; }, contents => \&MyObject::contents } ); my $test_name = q{more leaky data detection}; if ( not $tester ) { Test::More::fail($test_name); } else { Test::More::is_deeply( $leak, MyObject->construct_more_data, $test_name ); } } exit 0; Test-Weaken-3.022000/t/filehandle.t0000644000175000017500000000240611465421356014377 0ustar gggg#!/usr/bin/perl # A test case provided by Kevin Ryde, # with minor changes. package MyObject; use strict; use warnings; use Scalar::Util; use Fatal qw(open); sub new { my ($class) = @_; ## no critic (InputOutput::RequireBriefOpen) open my $out, '<', '/dev/null'; ## use critic return bless { fh => $out }, $class; } ## end sub new package main; use strict; use warnings; use Test::Weaken; use Test::More tests => 3; { my $leak; my $test = Test::Weaken::leaks( { constructor => sub { my $obj = MyObject->new; $leak = $obj->{'fh'} or Carp::croak('MyObject has no fh attribute'); return $obj; }, tracked_types => ['GLOB'], } ); Test::More::ok( $test, 'leaky file handle detection' ); Test::More::is( $test && $test->unfreed_count, 1, 'one object leaked' ); } { ## use Marpa::Test::Display tracked_types snippet my $test = Test::Weaken::leaks( { constructor => sub { my $obj = MyObject->new; return $obj; }, tracked_types => ['GLOB'], } ); ## no Marpa::Test::Display Test::More::ok( ( not defined $test ), 'file handle detection' ); } exit 0; Test-Weaken-3.022000/t/weaken.t0000644000175000017500000000467611465421356013571 0ustar gggg#!perl use strict; use warnings; use Test::More tests => 6; use Scalar::Util qw(weaken isweak); use lib 't/lib'; use Test::Weaken::Test; BEGIN { Test::More::use_ok('Test::Weaken'); } sub brief_result { my $test = shift; my $unfreed_count = $test->test(); my $unfreed_proberefs = $test->unfreed_proberefs(); my @unfreed_strong = (); my @unfreed_weak = (); for my $proberef ( @{$unfreed_proberefs} ) { if ( ref $proberef eq 'REF' and isweak ${$proberef} ) { push @unfreed_weak, $proberef; } else { push @unfreed_strong, $proberef; } } return 'total: weak=' . $test->weak_probe_count() . q{; } . 'strong=' . $test->strong_probe_count() . q{; } . 'unfreed: weak=' . ( scalar @unfreed_weak ) . q{; } . 'strong=' . ( scalar @unfreed_strong ); } my $test = Test::Weaken::leaks( sub { my $x = []; my $y = \$x; weaken( my $z = \$x ); $z; } ); Test::More::ok( ( !$test ), 'Simple weak ref' ); Test::Weaken::Test::is( brief_result( Test::Weaken->new( sub { my $x = 42; my $y = \$x; $x = \$y; } ) ), 'total: weak=0; strong=3; unfreed: weak=0; strong=2', 'Bad Less Simple Cycle' ); Test::Weaken::Test::is( brief_result( Test::Weaken->new( sub { my $x; weaken( my $y = \$x ); $x = \$y; $y; } ) ), 'total: weak=1; strong=2; unfreed: weak=0; strong=0', 'Fixed simple cycle' ); Test::Weaken::Test::is( brief_result( Test::Weaken->new( sub { my $x; my $y = [ \$x ]; my $z = { k1 => \$y }; $x = \$z; my $result = [ $x, $y, $z ]; $result; } ) ), 'total: weak=0; strong=12; unfreed: weak=0; strong=7', 'Bad Complicated Cycle' ); Test::Weaken::Test::is( brief_result( Test::Weaken->new( sub { my $x = 42; my $y = [ \$x ]; my $z = { k1 => \$y }; weaken( $x = \$z ); my $result = [ $x, $y, $z ]; $result; } ) ), 'total: weak=1; strong=11; unfreed: weak=0; strong=0', 'Fixed Complicated Cycle' ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Test-Weaken-3.022000/t/pod.t0000644000175000017500000000325611746351641013073 0ustar gggg#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 1; sub extract_more_from { return; } sub some_condition { return 0; } #------------------------------------------------------------------------------ use Test::Weaken qw(leaks); my $leaks = leaks(sub { my $obj = { one => 1, two => [], three => [3,3,3] }; return $obj; }); if ($leaks) { print "There were memory leaks from test 1!\n"; printf "%d of %d original references were not freed\n", $leaks->unfreed_count(), $leaks->probe_count(); } else { print "No leaks in test 1\n"; } $leaks = Test::Weaken::leaks( { constructor => sub { my @array = (42, 711); push @array, \@array; # circular reference return \@array; }, destructor => sub { print "This could invoke an object destructor\n"; }, ignore => sub { my ($ref) = @_; if (some_condition($ref)) { return 1; # ignore } return 0; # don't ignore }, contents => sub { my ($ref) = @_; return extract_more_from($ref); }, }); if ($leaks) { print "There were memory leaks from test 2!\n"; my $unfreed_proberefs = $leaks->unfreed_proberefs(); print "These are the probe references to the unfreed objects:\n"; require Data::Dumper; foreach my $ref (@$unfreed_proberefs) { print "ref $ref\n"; print Data::Dumper->Dump([$ref], ['unfreed']); } } #------------------------------------------------------------------------------ ok(1); exit 0; Test-Weaken-3.022000/MANIFEST0000644000175000017500000000142611771445662013014 0ustar ggggauthor.t/critic.t author.t/critic1 author.t/display.t author.t/do_tidy.pl author.t/Makefile author.t/perlcriticrc author.t/perltidyrc author.t/tidy1 Changes etc/change_version.pl etc/check_links.pl etc/last_minute_check.sh etc/Makefile etc/not_in_manifest.pl lib/Test/Weaken.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README sandbox/coderef.pl sandbox/dot.pl sandbox/elements.pl sandbox/html-tree.pl sandbox/ignore.pl sandbox/misc.pl sandbox/reftypes.pl sandbox/scalar-util-instance.pl sandbox/tied.pl SIGNATURE t/00-load.t t/array.t t/bug42903.t t/circular.t t/contents.t t/faux_gtk.t t/filehandle.t t/ignore.t t/lib/Test/Weaken/Test.pm t/Makefile t/overload.t t/pod.t t/poof.t t/snippet.t t/stein.t t/synopsis.t t/tied.t t/unfilled-array.t t/various.t t/weaken.t Test-Weaken-3.022000/Changes0000644000175000017500000000441112056244363013143 0ustar ggggRevision history for Test-Weaken 3.022000 December 2012 * tests ignore.t don't depend on proberef order 3.020000 July 2012 * new destructor_method option 3.018000 June 2012 * new options ignore_preds, ignore_object, ignore_objects 3.016000 May 2012 * new ignore_class and ignore_classes options 3.014000 February 2012 * tests force Dumper sortkeys 3.012000 February 2012 * tests allow for "at line 123." with a "." 3.010000 February 2012 * constructor can return multiple values 3.008000 January 2012 * Try for Perl 5.6.0 too. * XSUB bits in the main docs. * Slightly more compact SYNOPSIS. 3.007_001 Sun Jan 6 19:58:00 PST 2012 * Cope with some tied glob warnings of perl 5.14 and up. 3.007_000 Sun Jan 1 17:29:41 PST 2012 * New developer's release * Add Kevin Ryde's XSUB doc 3.006000 Mon Nov 15 20:52:06 2010 * Documentation changes * Added Test::Weaken::Gtk2 to SEE ALSO 3.004000 Sun May 16 15:36:51 2010 * Ticket 56722: When addition is overloaded, it confuses Test::Weaken. 3.002000 Sat Aug 1 15:40:36 2009 Now descends into objects underlying tied objects. Added tracked_types named option. Ticket 44835. 3.000000 Tue Jul 7 Added 'contents' option. New major release because, in there are leaks, they may be reported in a different order. 2.002000 Sat Mar 14 Added 'ignore' option. 2.000000 Thu Feb 19 Complete interface change and code rewrite. Documentation rewrite. Code now perltidy clean. Ticket 42903. Ticket 43608. 1.002000 Wed Jan 28 Adding a destructor argument to poof(). Adding various developer's utilities. Make code perlcritic clean. Some documentation improvements. 1.000000 Fri Sep 19 First official release 0.002006 Mon Sep 15 Fixed META.yml 0.002003 Mon Sep 15 Added a META.yml Rewrote documentation. No longer change undef's in test data to 42 -- that was unnecessary 0.002002 Sun Oct 28 Fixed POD 0.002001 Thu Oct 25 First beta version 0.001_nnn Tue Oct 9 Various, alpha versions, beginning on the above date Test-Weaken-3.022000/etc/0002755000175000017500000000000012056244371012424 5ustar ggggTest-Weaken-3.022000/etc/last_minute_check.sh0000755000175000017500000000006411465421356016445 0ustar ggggmake build make -B perlcritic wc -l perlcritic.errs Test-Weaken-3.022000/etc/check_links.pl0000644000175000017500000000500211465421356015234 0ustar gggg#!perl use strict; use warnings; use LWP::UserAgent; use URI::URL; use HTML::LinkExtor; use English qw( -no_match_vars ); use Carp; use IO::Handle; use Fatal qw(open close); my $fh; open $fh, q{<}, 'lib/Test/Weaken.pm'; LINE: while ( my $line = <$fh> ) { if ($line =~ m{ ([\$*]) ( ([\w\:\']*) \b VERSION ) \b .* \= }xms ) { { package Test::Weaken; ## no critic (BuiltinFunctions::ProhibitStringyEval) my $retval = eval $line; ## use critic if ( not defined $retval ) { Carp::croak("eval of $line failed"); } last LINE; } } ## end if ( $line =~ / /xms ) } ## end while ( my $line = <$fh> ) close $fh; my $cpan_base = 'http://search.cpan.org'; my $doc_base = $cpan_base . '/~jkegl/Test-Weaken-' . $Test::Weaken::VERSION . '/lib/Test/'; print "Starting at $doc_base\n" or Carp::croak("Cannot print: $ERRNO"); my @url = qw( Weaken.pm ); my %link; sub cb { my ( $tag, %links ) = @_; return unless $tag eq 'a'; my $href = $links{href}; return if $href =~ /^[#]/xms; return ( $link{$href} = 1 ); } my %link_ok; $OUTPUT_AUTOFLUSH = 1; PAGE: for my $url (@url) { $url = $doc_base . $url; my $p = HTML::LinkExtor->new( \&cb ); my $ua = LWP::UserAgent->new; %link = (); # Request document and parse it as it arrives my $request_response = $ua->request( HTTP::Request->new( GET => $url ), sub { $p->parse( $_[0] ) } ); my $page_response_status_line = $request_response->status_line; if ( $request_response->code != 200 ) { print 'PAGE: ', $page_response_status_line, q{ }, $url, "\n" or Carp::croak("Cannot print: $ERRNO"); next PAGE; } LINK: for my $link ( keys %link ) { $link = 'http://search.cpan.org' . $link if $link =~ m{^/}xms; next LINK if $link_ok{$link}; my $response = $ua->request( HTTP::Request->new( GET => $link ) ); if ( $response->code == 200 ) { $link_ok{$link} = 1; print q{.} or Carp::croak("Cannot print: $ERRNO"); next LINK; } print 'LINK: ', $response->status_line, q{ }, $link, "\n" or Carp::croak("Cannot print: $ERRNO"); } print " PAGE: $page_response_status_line: $url\n" or Carp::croak("Cannot print: $ERRNO"); } Test-Weaken-3.022000/etc/change_version.pl0000755000175000017500000000600411465421356015757 0ustar gggg#!perl use strict; use warnings; use Fatal qw(open close unlink select rename); use English qw( -no_match_vars ); use Carp; our $FH; Carp::croak("usage: $PROGRAM_NAME: old_version new_version") unless scalar @ARGV == 2; my ( $old, $new ) = @ARGV; print {*STDERR} "$old $new\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); sub check_version { my $version = shift; my ( $major, $minor1, $underscore, $minor2 ) = ( $version =~ m/^ ([0-9]+) [.] ([0-9.]{3}) ([_]?) ([0-9.]{3}) $/xms ); if ( not defined $minor2 ) { Carp::croak("Bad format in version number: $version"); } if ( $minor1 % 2 and $underscore ne '_' ) { Carp::croak("No underscore in developer's version number: $version"); } if ( $minor1 % 2 == 0 and $underscore eq '_' ) { Carp::croak( "Underscore in official release version number: $version"); } } ## end sub check_version check_version($old); check_version($new); ## no critic (BuiltinFunctions::ProhibitStringyEval) Carp::croak("$old >= $new") if eval $old >= eval $new; ## use critic sub change { my ( $fix, @files ) = @_; for my $file (@files) { open my $fh, '<', $file; my $text = do { local ($RS) = undef; <$fh> }; close $fh; my $backup = "save/$file"; rename $file, $backup; open my $argvout, '>', $file; print {$argvout} ${ $fix->( \$text, $file ) } or Carp::croak("Could not print to argvout: $ERRNO"); close $argvout; } return 1; } sub fix_META_yml { my $text_ref = shift; my $file_name = shift; unless ( ${$text_ref} =~ s/(version:\s*)$old/$1$new/gxms ) { print {*STDERR} "failed to change version from $old to $new in $file_name\n" or Carp::croak("Could not print to argvout: $ERRNO"); } return $text_ref; } sub fix_Weaken_pm { my $text_ref = shift; my $file_name = shift; unless ( ${$text_ref} =~ s{ ( our \s+ [\$] VERSION \s* = \s* ['] ) $old ['] [;] }{$1$new';}xms ) { print {*STDERR} "failed to change VERSION from $old to $new in $file_name\n" or Carp::croak("Could not print to STDERR: $ERRNO"); } return $text_ref; } sub update_changes { my $text_ref = shift; my $file_name = shift; my $date_stamp = localtime; unless ( ${$text_ref} =~ s/(\ARevision\s+history\s+[^\n]*\n\n)/$1$new $date_stamp\n/xms ) { print {*STDERR} "failed to add $new to $file_name\n" or Carp::croak("Could not print to STDERR: $ERRNO"); } return $text_ref; } change( \&fix_META_yml, 'META.yml' ); change( \&fix_Weaken_pm, 'lib/Test/Weaken.pm' ); change( \&update_changes, 'Changes' ); print {*STDERR} "REMEMBER TO UPDATE Changes file\n" or Carp::croak("Could not print to STDERR: $ERRNO"); Test-Weaken-3.022000/etc/Makefile0000644000175000017500000000037711465421356014074 0ustar gggg .PHONY: build display build: (cd ..;perl Makefile.PL) (cd ..;make realclean) (cd ..;perl Makefile.PL) (cd ..;make) (cd ..;make test) (cd ..;make disttest) display: display.errs # check displays display.errs: perl display_test.pl > $@ wc -l $@ Test-Weaken-3.022000/etc/not_in_manifest.pl0000644000175000017500000000136011465421356016136 0ustar gggg#!perl use strict; use warnings; use Fatal qw( waitpid close ); use English qw( -no_match_vars ); my %manifest; ## no critic (InputOutput::RequireBriefOpen) open my $manifest, '<', '../MANIFEST' or Carp::croak("open of MANIFEST failed: $ERRNO"); FILE: while ( my $line = <$manifest> ) { chomp $line; $line =~ s/ \s* [#] .* \z//xms; $manifest{$line} = 1; } close $manifest; my $pid = open my $rdr, q{-|}, 'svn', 'list', '-R', q{..} or Carp::croak("open of svn list pipe failed: $ERRNO"); waitpid $pid, 0; FILE: while ( my $line = <$rdr> ) { chomp $line; next FILE if $line =~ m{ [/] \z }xms; next FILE if -d $line; next FILE if $manifest{$line}; print "$line\n" or Carp::croak("Cannot print: $ERRNO"); } Test-Weaken-3.022000/lib/0002755000175000017500000000000012056244371012417 5ustar ggggTest-Weaken-3.022000/lib/Test/0002755000175000017500000000000012056244371013336 5ustar ggggTest-Weaken-3.022000/lib/Test/Weaken.pm0000644000175000017500000020213712056244316015110 0ustar ggggpackage Test::Weaken; # maybe: # contents_funcs => arrayref of funcs # multiple contents, or sub{} returning list enough ? # track_filehandles => 1 GLOB and IO # # locations=>1 # top->{'foo'}->[10]->REF->*{IO} # top.H{'foo'}.A[10].REF.*{IO} # unfreed_locations() arrayref of strings # first location encountered # locations_maxdepth use 5.006; use strict; use warnings; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw(leaks poof); our $VERSION = '3.022000'; #use Smart::Comments; ### Using Smart Comments ... =begin Implementation: The basic strategy: get a list of all the objects which allocate memory, create probe references to them, weaken those probe references, attempt to free the memory, and check the references. If the memory is free, the probe references will be undefined. Probe references also serve a second purpose -- to avoid copying any weak reference in the original object. When you copy a weak reference, the result is a strong reference. There may be good reasons for Perl strengthen-on-copy policy, but that behavior is a big problem for this module. A lot of what might seem like needless indirection in the code below is done to avoid working with references directly in situations which could involve making a copy of them, even implicitly. =end Implementation: =cut package Test::Weaken::Internal; use English qw( -no_match_vars ); use Carp; use Scalar::Util 1.18 qw(); my @default_tracked_types = qw(REF SCALAR VSTRING HASH ARRAY CODE); sub follow { my ( $self, @base_probe_list ) = @_; my $ignore_preds = $self->{ignore_preds}; my $contents = $self->{contents}; my $trace_maxdepth = $self->{trace_maxdepth}; my $trace_following = $self->{trace_following}; my $trace_tracking = $self->{trace_tracking}; my $user_tracked_types = $self->{tracked_types}; my @tracked_types = @default_tracked_types; if ( defined $user_tracked_types ) { push @tracked_types, @{$user_tracked_types}; } my %tracked_type = map { ( $_, 1 ) } @tracked_types; defined $trace_maxdepth or $trace_maxdepth = 0; # Initialize the results with a reference to the dereferenced # base reference. # The initialization assumes each $base_probe is a reference, # not part of the test object, whose referent is also a reference # which IS part of the test object. my @follow_probes = @base_probe_list; my @tracking_probes = @base_probe_list; my %already_followed = (); my %already_tracked = (); FOLLOW_OBJECT: while ( defined( my $follow_probe = pop @follow_probes ) ) { # The follow probes are to objects which either will not be # tracked or which have already been added to @tracking_probes next FOLLOW_OBJECT if $already_followed{ Scalar::Util::refaddr $follow_probe }++; my $object_type = Scalar::Util::reftype $follow_probe; my @child_probes = (); if ($trace_following) { require Data::Dumper; ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls) print {*STDERR} 'Following: ', Data::Dumper->new( [$follow_probe], [qw(tracking)] )->Terse(1) ->Maxdepth($trace_maxdepth)->Dump or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## use critic } ## end if ($trace_following) if ( defined $contents ) { my $safe_copy = $follow_probe; push @child_probes, map { \$_ } ( $contents->($safe_copy) ); } FIND_CHILDREN: { foreach my $ignore (@$ignore_preds) { my $safe_copy = $follow_probe; last FIND_CHILDREN if $ignore->($safe_copy); } if ( $object_type eq 'ARRAY' ) { if ( my $tied_var = tied @{$follow_probe} ) { push @child_probes, \($tied_var); } foreach my $i ( 0 .. $#{$follow_probe} ) { if ( exists $follow_probe->[$i] ) { push @child_probes, \( $follow_probe->[$i] ); } } last FIND_CHILDREN; } ## end if ( $object_type eq 'ARRAY' ) if ( $object_type eq 'HASH' ) { if ( my $tied_var = tied %{$follow_probe} ) { push @child_probes, \($tied_var); } push @child_probes, map { \$_ } values %{$follow_probe}; last FIND_CHILDREN; } ## end if ( $object_type eq 'HASH' ) # GLOB is not tracked by default, # but we follow ties if ( $object_type eq 'GLOB' ) { if ( my $tied_var = tied *${$follow_probe} ) { push @child_probes, \($tied_var); } last FIND_CHILDREN; } ## end if ( $object_type eq 'GLOB' ) # LVALUE is not tracked by default, # but we follow ties if ( $object_type eq 'SCALAR' or $object_type eq 'VSTRING' or $object_type eq 'LVALUE' ) { if ( my $tied_var = tied ${$follow_probe} ) { push @child_probes, \($tied_var); } last FIND_CHILDREN; } ## end if ( $object_type eq 'SCALAR' or $object_type eq ...) if ( $object_type eq 'REF' ) { if ( my $tied_var = tied ${$follow_probe} ) { push @child_probes, \($tied_var); } push @child_probes, ${$follow_probe}; last FIND_CHILDREN; } ## end if ( $object_type eq 'REF' ) } ## end FIND_CHILDREN: push @follow_probes, @child_probes; CHILD_PROBE: for my $child_probe (@child_probes) { my $child_type = Scalar::Util::reftype $child_probe; next CHILD_PROBE unless $tracked_type{$child_type}; my $new_tracking_probe = $child_probe; next CHILD_PROBE if $already_tracked{ Scalar::Util::refaddr $new_tracking_probe }++; foreach my $ignore (@$ignore_preds) { my $safe_copy = $new_tracking_probe; next CHILD_PROBE if $ignore->($safe_copy); } if ($trace_tracking) { ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls) print {*STDERR} 'Tracking: ', Data::Dumper->new( [$new_tracking_probe], [qw(tracking)] ) ->Terse(1)->Maxdepth($trace_maxdepth)->Dump or Carp::croak("Cannot print to STDOUT: $ERRNO"); ## use critic # print {*STDERR} 'Tracking: ', # "$new_tracking_probe\n"; } ## end if ($trace_tracking) push @tracking_probes, $new_tracking_probe; } ## end for my $child_probe (@child_probes) } # FOLLOW_OBJECT return \@tracking_probes; } # sub follow # See POD, below sub Test::Weaken::new { my ( $class, $arg1, $arg2 ) = @_; my $self = {}; bless $self, $class; $self->{test} = 1; my @ignore_preds; my @ignore_classes; my @ignore_objects; $self->{ignore_preds} = \@ignore_preds; UNPACK_ARGS: { if ( ref $arg1 eq 'CODE' ) { $self->{constructor} = $arg1; if ( defined $arg2 ) { $self->{destructor} = $arg2; } return $self; } if ( ref $arg1 ne 'HASH' ) { Carp::croak('arg to Test::Weaken::new is not HASH ref'); } if (defined (my $constructor = delete $arg1->{constructor})) { $self->{constructor} = $constructor; } if (defined (my $destructor = delete $arg1->{destructor})) { $self->{destructor} = $destructor; } if (defined (my $destructor_method = delete $arg1->{destructor_method})) { $self->{destructor_method} = $destructor_method; } if (defined (my $coderef = delete $arg1->{ignore})) { if (ref $coderef ne 'CODE') { Carp::croak('Test::Weaken: ignore must be CODE ref'); } push @ignore_preds, $coderef; } if (defined (my $ignore_preds = delete $arg1->{ignore_preds})) { push @ignore_preds, @$ignore_preds; } if ( defined (my $ignore_class = delete $arg1->{ignore_class} )) { push @ignore_classes, $ignore_class; } if ( defined (my $ignore_classes = delete $arg1->{ignore_classes} )) { push @ignore_classes, @$ignore_classes; } push @ignore_objects, delete $arg1->{ignore_object}; if ( defined (my $ignore_objects = delete $arg1->{ignore_objects} )) { push @ignore_objects, @$ignore_objects; } if ( defined $arg1->{trace_maxdepth} ) { $self->{trace_maxdepth} = $arg1->{trace_maxdepth}; delete $arg1->{trace_maxdepth}; } if ( defined $arg1->{trace_following} ) { $self->{trace_following} = $arg1->{trace_following}; delete $arg1->{trace_following}; } if ( defined $arg1->{trace_tracking} ) { $self->{trace_tracking} = $arg1->{trace_tracking}; delete $arg1->{trace_tracking}; } if ( defined $arg1->{contents} ) { $self->{contents} = $arg1->{contents}; delete $arg1->{contents}; } if ( defined $arg1->{test} ) { $self->{test} = $arg1->{test}; delete $arg1->{test}; } if ( defined $arg1->{tracked_types} ) { $self->{tracked_types} = $arg1->{tracked_types}; delete $arg1->{tracked_types}; } my @unknown_named_args = keys %{$arg1}; if (@unknown_named_args) { my $message = q{}; for my $unknown_named_arg (@unknown_named_args) { $message .= "Unknown named arg: '$unknown_named_arg'\n"; } Carp::croak( $message . 'Test::Weaken failed due to unknown named arg(s)' ); } } # UNPACK_ARGS if ( my $ref_type = ref $self->{constructor} ) { Carp::croak('Test::Weaken: constructor must be CODE ref') unless ref $self->{constructor} eq 'CODE'; } if ( my $ref_type = ref $self->{destructor} ) { Carp::croak('Test::Weaken: destructor must be CODE ref') unless ref $self->{destructor} eq 'CODE'; } if ( my $ref_type = ref $self->{contents} ) { Carp::croak('Test::Weaken: contents must be CODE ref') unless ref $self->{contents} eq 'CODE'; } if ( my $ref_type = ref $self->{tracked_types} ) { Carp::croak('Test::Weaken: tracked_types must be ARRAY ref') unless ref $self->{tracked_types} eq 'ARRAY'; } if (@ignore_classes) { push @ignore_preds, sub { my ($ref) = @_; if (Scalar::Util::blessed($ref)) { foreach my $class (@ignore_classes) { if ($ref->isa($class)) { return 1; } } } return 0; }; } # undefs in ignore objects are skipped @ignore_objects = grep {defined} @ignore_objects; if (@ignore_objects) { push @ignore_preds, sub { my ($ref) = @_; $ref = Scalar::Util::refaddr($ref); foreach my $object (@ignore_objects) { if (Scalar::Util::refaddr($object) == $ref) { return 1; } } return 0; }; } return $self; } # sub new sub Test::Weaken::test { my $self = shift; if ( defined $self->{unfreed_probes} ) { Carp::croak('Test::Weaken tester was already evaluated'); } my $constructor = $self->{constructor}; my $destructor = $self->{destructor}; # my $ignore = $self->{ignore}; my $contents = $self->{contents}; my $test = $self->{test}; my @test_object_probe_list = map {\$_} $constructor->(); foreach my $test_object_probe (@test_object_probe_list) { if ( not ref ${$test_object_probe} ) { Carp::carp( 'Test::Weaken test object constructor returned a non-reference' ); } } my $probes = Test::Weaken::Internal::follow( $self, @test_object_probe_list ); $self->{probe_count} = @{$probes}; $self->{weak_probe_count} = grep { ref $_ eq 'REF' and Scalar::Util::isweak ${$_} } @{$probes}; $self->{strong_probe_count} = $self->{probe_count} - $self->{weak_probe_count}; if ( not $test ) { $self->{unfreed_probes} = $probes; return scalar @{$probes}; } for my $probe ( @{$probes} ) { Scalar::Util::weaken($probe); } # Now free everything. if (defined (my $destructor_method = $self->{destructor_method})) { foreach my $test_object_probe (@test_object_probe_list) { my $obj = $$test_object_probe; $obj->$destructor_method; } } if (defined $destructor) { $destructor->( map {$$_} @test_object_probe_list ) ; } @test_object_probe_list = (); my $unfreed_probes = [ grep { defined $_ } @{$probes} ]; $self->{unfreed_probes} = $unfreed_probes; return scalar @{$unfreed_probes}; } # sub test # Undocumented and deprecated sub poof_array_return { my $tester = shift; my $results = $tester->{unfreed_probes}; my @unfreed_strong = (); my @unfreed_weak = (); for my $probe ( @{$results} ) { if ( ref $probe eq 'REF' and Scalar::Util::isweak ${$probe} ) { push @unfreed_weak, $probe; } else { push @unfreed_strong, $probe; } } return ( $tester->weak_probe_count(), $tester->strong_probe_count(), \@unfreed_weak, \@unfreed_strong ); } ## end sub poof_array_return; sub Test::Weaken::poof { my @args = @_; my $tester = Test::Weaken->new(@args); my $result = $tester->test(); return Test::Weaken::Internal::poof_array_return($tester) if wantarray; return $result; } sub Test::Weaken::leaks { my @args = @_; my $tester = Test::Weaken->new(@args); my $result = $tester->test(); return $tester if $result; return; } sub Test::Weaken::unfreed_proberefs { my $tester = shift; my $result = $tester->{unfreed_probes}; if ( not defined $result ) { Carp::croak('Results not available for this Test::Weaken object'); } return $result; } sub Test::Weaken::unfreed_count { my $tester = shift; my $result = $tester->{unfreed_probes}; if ( not defined $result ) { Carp::croak('Results not available for this Test::Weaken object'); } return scalar @{$result}; } sub Test::Weaken::probe_count { my $tester = shift; my $count = $tester->{probe_count}; if ( not defined $count ) { Carp::croak('Results not available for this Test::Weaken object'); } return $count; } # Undocumented and deprecated sub Test::Weaken::weak_probe_count { my $tester = shift; my $count = $tester->{weak_probe_count}; if ( not defined $count ) { Carp::croak('Results not available for this Test::Weaken object'); } return $count; } # Undocumented and deprecated sub Test::Weaken::strong_probe_count { my $tester = shift; my $count = $tester->{strong_probe_count}; if ( not defined $count ) { Carp::croak('Results not available for this Test::Weaken object'); } return $count; } sub Test::Weaken::check_ignore { my ( $ignore, $max_errors, $compare_depth, $reporting_depth ) = @_; my $error_count = 0; $max_errors = 1 if not defined $max_errors; if ( not Scalar::Util::looks_like_number($max_errors) ) { Carp::croak('Test::Weaken::check_ignore max_errors must be a number'); } $max_errors = 0 if $max_errors <= 0; $reporting_depth = -1 if not defined $reporting_depth; if ( not Scalar::Util::looks_like_number($reporting_depth) ) { Carp::croak( 'Test::Weaken::check_ignore reporting_depth must be a number'); } $reporting_depth = -1 if $reporting_depth < 0; $compare_depth = 0 if not defined $compare_depth; if ( not Scalar::Util::looks_like_number($compare_depth) or $compare_depth < 0 ) { Carp::croak( 'Test::Weaken::check_ignore compare_depth must be a non-negative number' ); } return sub { my ($probe_ref) = @_; my $array_context = wantarray; my $before_weak = ( ref $probe_ref eq 'REF' and Scalar::Util::isweak( ${$probe_ref} ) ); my $before_dump = Data::Dumper->new( [$probe_ref], [qw(proberef)] ) ->Maxdepth($compare_depth)->Dump(); my $before_reporting_dump; if ( $reporting_depth >= 0 ) { #<<< perltidy doesn't do this well $before_reporting_dump = Data::Dumper->new( [$probe_ref], [qw(proberef_before_callback)] ) ->Maxdepth($reporting_depth) ->Dump(); #>>> } my $scalar_return_value; my @array_return_value; if ($array_context) { @array_return_value = $ignore->($probe_ref); } else { $scalar_return_value = $ignore->($probe_ref); } my $after_weak = ( ref $probe_ref eq 'REF' and Scalar::Util::isweak( ${$probe_ref} ) ); my $after_dump = Data::Dumper->new( [$probe_ref], [qw(proberef)] ) ->Maxdepth($compare_depth)->Dump(); my $after_reporting_dump; if ( $reporting_depth >= 0 ) { #<<< perltidy doesn't do this well $after_reporting_dump = Data::Dumper->new( [$probe_ref], [qw(proberef_after_callback)] ) ->Maxdepth($reporting_depth) ->Dump(); #<<< } my $problems = q{}; my $include_before = 0; my $include_after = 0; if ( $before_weak != $after_weak ) { my $changed = $before_weak ? 'strengthened' : 'weakened'; $problems .= "Probe referent $changed by ignore call\n"; $include_before = defined $before_reporting_dump; } if ( $before_dump ne $after_dump ) { $problems .= "Probe referent changed by ignore call\n"; $include_before = defined $before_reporting_dump; $include_after = defined $after_reporting_dump; } if ($problems) { $error_count++; my $message = q{}; $message .= $before_reporting_dump if $include_before; $message .= $after_reporting_dump if $include_after; $message .= $problems; if ( $max_errors > 0 and $error_count >= $max_errors ) { $message .= "Terminating ignore callbacks after finding $error_count error(s)"; Carp::croak($message); } Carp::carp( $message . 'Above errors reported' ); } return $array_context ? @array_return_value : $scalar_return_value; }; } 1; __END__ =for stopwords abend misdesign misimplement unfreed deallocated deallocation referenceable builtin recursing globals Builtin OO destructor VSTRING LVALUE unevaluated subdirectory refaddr refcount indiscernable XSUB XSUBs mortalizing mortalize pre-calculated subr refcounts recurses dereferences filehandle filehandles Kegler perldoc AnnoCPAN CPAN CPAN's perl Ryde jettero Juerd morgon perrin Perlmonks ie GLOBs hashref coderef isa unblessed numize OOPery arrayref autovivified dup typemap arrayrefs Gtk2-Perl =head1 NAME Test::Weaken - Test that freed memory objects were, indeed, freed =head1 SYNOPSIS =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/synopsis.t', 'synopsis') =end Marpa::Test::Display: use Test::Weaken qw(leaks); # basic leaks detection my $leaks = leaks(sub { my $obj = { one => 1, two => [], three => [3,3,3] }; return $obj; }); if ($leaks) { print "There were memory leaks from test 1!\n"; printf "%d of %d original references were not freed\n", $leaks->unfreed_count(), $leaks->probe_count(); } else { print "No leaks in test 1\n"; } # or with various options $leaks = Test::Weaken::leaks( { constructor => sub { my @array = (42, 711); push @array, \@array; # circular reference return \@array; }, destructor => sub { print "This could invoke an object destructor\n"; }, ignore => sub { my ($ref) = @_; if (some_condition($ref)) { return 1; # ignore } return 0; # don't ignore }, contents => sub { my ($ref) = @_; return extract_more_from($ref); }, }); if ($leaks) { print "There were memory leaks from test 2!\n"; my $unfreed_proberefs = $leaks->unfreed_proberefs(); print "These are the probe references to the unfreed objects:\n"; require Data::Dumper; foreach my $ref (@$unfreed_proberefs) { print "ref $ref\n"; print Data::Dumper->Dump([$ref], ['unfreed']); } } =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: =head1 DESCRIPTION C helps detect unfreed Perl data in arrays, hashes, scalars, objects, etc, by descending recursively through structures and watching that everything is freed. Unfreed data is a useless overhead and may cause an application to abend due to lack of memory. Normally if the last reference to something is discarded then it and anything in it is freed automatically. But this might not occur due to circular references, unexpected global variables or closures, or reference counting mistakes in XSUBs. C is named for the strategy used to detect leaks. References are taken to the test objects and all their contents, then those references are weakened and expected to be then freed. There's options to ignore intentional globals, or include extra associated data held elsewhere, or invoke an explicit destructor. Unfreed parts are reported and can be passed to other modules such as L to try to discover why they weren't freed. C examines structures to an unlimited depth and is safe on circular structures. =head2 Tracking and Children C determines the contents of a data structure by the contents of the top object of the test data structure, and recursively into the contents of those sub-parts. The following data types are tracked and their contents examined, ARRAY each of its values HASH each of its values SCALAR if a reference then the target thing CODE no contents as yet tie ANY the associated tie object from tied() In an array or hash each scalar value has an independent existence and C tracks each individually (see L below). C objects, ie. subroutines, are not examined for children. This is a limitation, because closures do hold internal references to data objects. Future versions of C might descend into CODE objects. The following types are not tracked by default and not examined for contents, GLOB IO underlying a file handle FORMAT always global LVALUE GLOBs are usually either an entry in the Perl symbol table or a filehandle. An IO is the file object underlying a filehandle. Perl symbol tables are usually permanent and shouldn't be tracked, but see L below for tracking open files. Builtin types added to Perl in the future and not known to C will not be tracked by default but could be requested with C below. A variable of builtin type GLOB may be a scalar which was assigned a GLOB value (a scalar-GLOB) or it may simply be a GLOB (a pure-GLOB). The issue that arises for C is that, in the case of a scalar-GLOB, the scalar and the GLOB may be tied separately. At present, the underlying tied variable of the scalar side of a scalar-GLOB is ignored. Only the underlying tied variable of the GLOB is a child for C's purposes. =head2 Returns and Exceptions The methods of C do not return errors. Errors are always thrown as exceptions. =head1 EXPORTS By default, C exports nothing. Optionally, C may be requested in usual C style (see L). (And C from L too if desired.) use Test::Weaken 'leaks'; # import my $tester = leaks (...); =head1 PORCELAIN METHODS =head2 leaks =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/snippet.t', 'leaks snippet') =end Marpa::Test::Display: my $leaks = Test::Weaken::leaks( { constructor => sub { Buggy_Object->new() }, destructor => \&destroy_buggy_object, } ); if ($leaks) { print "There are leaks\n"; } =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: Check for leaks in the object created by the constructor function and return either an evaluated C object instance if there are leaks, or Perl false if there are no leaks. Instances of the C class are called B. An B tester is one on which the tests have been run and for which results are available. Users who only want to know if there were unfreed data objects can check the return value of C for Perl true or false. Arguments to C are passed as a hashref of named arguments. C can also be called in a "short form", where the constructor and destructor are passed directly as code references. =over 4 =item C $coderef> The C argument is required. Its value must be a coderef returning a reference to the test data structure. my $leaks = leaks ({ constructor => sub { return Some::Object->new(123); }, }); For "short form" the constructor coderef is the first argument, leaks (sub { return Some::Object->new(123); }); If the constructor returns a list of objects then all are checked. leaks (sub { return (Foo->new(), Bar->new()); }); Usually this is when two objects are somehow inter-related and should weaken away together, or perhaps sub-parts of an object not reached by the contents tracing (or see C below for a more general way to reach such sub-parts.) =item C $coderef> =item C $methodname> An optional destructor is called just before C tries to free everything. Some test objects or structures might require explicit destruction when they're to be freed. C is called with the objects returned by the constructor &$destructor ($obj, ...) For example, leaks ({ constructor => sub { return make_some_thing() }, destructor => sub { my ($thing) = @_; delete $thing->{'circular_ref'}; }, }); For "short form" the destructor is an optional second argument, leaks (sub { Foo->new }, sub { my ($foo) = @_; $foo->destroy; }); C is called as a method on each object returned by the constructor, $obj->$methodname(); For example if the constructed object (or objects) require an explicit C<$foo-Edestroy()> then leaks ({ constructor => sub { Foo->new }, destructor_method => 'destroy' }); If both C and C are given then C calls are first, then C. An explicit destructor may be needed for things like toplevel windows in GUI toolkits such as Wx and Gtk (and perhaps also some main loop iterations if actual destruction is delayed). Some object-oriented tree structures may need explicit destruction too if parent and child nodes keep hard references to each other, though it's usually more convenient if child-Eparent is only a weak reference. (See also L.) =item C $coderef> =item C [ $coderef, $coderef, ...]> =item C $classname> =item C [ $classname, $classname, ... ]> =item C $ref> =item C [ $ref, $ref, ... ]> Ignore some things. When a thing is ignored it's not tracked for leaks and its contents are not examined. C and C take predicate functions. If any of them return true then the thing C<$ref> refers to is ignored. $bool = &$coderef ($ref); For example =begin Marpa::Test::Display: ## start display ## next 2 displays is_file($_, 't/ignore.t', 'ignore snippet') =end Marpa::Test::Display: sub ignore_all_tied_hashes { my ($ref) = @_; return (ref $ref eq 'HASH' && defined (tied %$ref)); } my $tester = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore => \&ignore_all_tied_hashes, }); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: C and C ignore blessed objects which are of the given class or classes. For example, my $leaks = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore_class => 'My::Singleton', } my $leaks = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore_classes => [ 'My::Singleton', 'My::PrinterDriver' ], } Objects are checked with blessed($ref) && $ref->isa($classname) which reaches any class-specific C in the object in the usual way. That allows classes to masquerade or have a dynamic "isa". That's normally fine and can be highly desirable in things like lazy loaders. C and C ignore the particular things referred to by the each given C<$ref>. For example, my $leaks = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore_object => \%global_data, } my $leaks = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore_objects => [ $obj1, $obj2 ], } For both C and C any Cs among the refs are ignored. This is handy if a global might or might not have been initialized yet. These options are called "object" because they're most often used with blessed objects, but unblessed things are fine too. C callbacks should not change the contents of C<$ref>. Doing so might cause an exception, an infinite loop, or erroneous results. See L for a little help against bad C. When comparing references in a predicate it's good to use C. Plain C<$ref==$something> can be tricked if C<$ref> is an object with overloaded numize or C<==> (see L). Another way to ignore is let globals etc go through as leaks and then filter them from the C<$leaks-Eunfreed_proberefs()> afterwards. The benefit of C is that it excludes object contents too. =item contents An optional C function can tell C about additional Perl data objects which should be checked. =begin Marpa::Test::Display: ## start display ## next 2 displays is_file($_, 't/contents.t', 'contents sub snippet') =end Marpa::Test::Display: sub my_extra_contents { my ($ref) = @_; if (blessed($ref) && $ref->isa('MyObject')) { return $ref->data, $ref->moredata; } else { return; } } my $leaks = Test::Weaken::leaks( { constructor => sub { return MyObject->new }, contents => \&my_extra_contents }); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: The given C<$coderef> is called for each Perl data object. It should return a list of additional Perl data objects, or an empty list if no extra contents. @extra_contents = &$coderef ($ref); C allows OOPery such as "inside-out" where object contents are held separately. It can also be used on wrappers for C-code objects where some of the contents of a widget etc are not in Perl level structures but only available through object method calls etc. C and C can be used together. C is called first and if not ignored then C is called. =item tracked_types Optional C is an arrayref of additional builtin types to track. =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/filehandle.t', 'tracked_types snippet') =end Marpa::Test::Display: my $test = Test::Weaken::leaks( { constructor => sub { my $obj = MyObject->new; return $obj; }, tracked_types => ['GLOB'], } ); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: The default tracking is per L above. The additional types which may be tracked are GLOB IO FORMAT LVALUE These names are per C of L. See L below for setting up to track GLOBs as filehandles. =back =head2 unfreed_proberefs =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/snippet.t', 'unfreed_proberefs snippet') =end Marpa::Test::Display: my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() } ); if ($tester) { my $unfreed_proberefs = $tester->unfreed_proberefs(); foreach my $ref (@$unfreed_proberefs) { print "unfreed: $ref\n"; } } =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: Return an arrayref of references to unfreed data objects. Throws an exception if there is a problem, for example if the tester has not yet been evaluated. The return value can be examined to pinpoint the source of a leak or produce statistics about unfreed data objects. =head2 unfreed_count =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/snippet.t', 'unfreed_count snippet') =end Marpa::Test::Display: my $tester = Test::Weaken::leaks( sub { Buggy_Object->new() } ); if ($tester) { printf "%d objects were not freed\n", $tester->unfreed_count(); } =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: Return the count of unfreed data objects. This is the length of the C arrayref. Throws an exception if there is a problem, for example if the tester has not yet been evaluated. =head2 probe_count =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/snippet.t', 'probe_count snippet') =end Marpa::Test::Display: my $tester = Test::Weaken::leaks( { constructor => sub { Buggy_Object->new() }, destructor => \&destroy_buggy_object, } ); next TEST if not $tester; printf "%d of %d objects were not freed\n", $tester->unfreed_count(), $tester->probe_count(); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: Return the total number of probe references in the test, including references to freed data objects. This is the count of probe references after C was finished finding the descendants of the test structure reference, but before C called the test structure destructor or reset the test structure reference to C. Throws an exception if there is a problem, for example if the tester has not yet been evaluated. =head1 PLUMBING METHODS Most users can skip this section. The plumbing methods exist to satisfy object-oriented purists, and to accommodate the rare user who wants to access the probe counts even when the test did find any unfreed data objects. =head2 new =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/snippet.t', 'new snippet') =end Marpa::Test::Display: my $tester = Test::Weaken->new( sub { My_Object->new() } ); my $unfreed_count = $tester->test(); my $proberefs = $tester->unfreed_proberefs(); printf "%d of %d objects freed\n", $unfreed_count, $tester->probe_count(); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: The L method takes the same arguments as the L method, described above. Unlike the L method, it always returns an B tester. An B tester is one on which the test has not yet been run and for which results are not yet available. If there are any problems, the L method throws an exception. The L method is the only method that can be called successfully on an unevaluated tester. Calling any other method on an unevaluated tester causes an exception to be thrown. =head2 test =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/snippet.t', 'test snippet') =end Marpa::Test::Display: my $tester = Test::Weaken->new( { constructor => sub { My_Object->new() }, destructor => \&destroy_my_object, } ); printf "There are %s\n", ( $tester->test() ? 'leaks' : 'no leaks' ); Converts an unevaluated tester into an evaluated tester. It does this by performing the test specified by the arguments to the L constructor and recording the results. Throws an exception if there is a problem, for example if the tester had already been evaluated. The L method returns the count of unfreed data objects. This will be identical to the length of the array returned by L and the count returned by L. =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: =head1 ADVANCED TECHNIQUES =head2 File Handles File handles are references to GLOBs and by default are not tracked. If a handle is a package global like C then that's probably what you want. But if you use anonymous handles either from the L module or Perl 5.6 autovivified then it's good to check the handle is freed. This can be done by asking for GLOB and IO in C, and extracting the IO from any GLOB encountered, sub contents_glob_IO { my ($ref) = @_; if (ref($ref) eq 'GLOB') { return *$ref{IO}; } else { return; } } my $leaks = Test::Weaken::leaks ({ constructor => sub { return MyFileObject->new }, contents => \&contents_glob_IO, tracked_types => [ 'GLOB', 'IO' ], }); It's good to check the IO too since it's possible for a reference elsewhere to keep it alive, in particular a Perl-level "dup" can make another handle GLOB pointing to that same IO, open my $dupfh, '<', $fh; # $dupfh holds and uses *$fh{IO} See L for such a C, if you want to use a module rather than copying couple of lines for that function. =head2 Array and Hash Keys and Values As noted above each value in a hash or array is a separate scalar and is tracked separately. Usually such scalars are only used in their containing hash or array, but it's possible to hold a reference to a particular element and C can notice if that causes it to be unfreed. my %hash = (foo => 123); my $ref = \$hash{'foo'}; # ref to hash value It's possible to put specific scalars as the values in a hash or array. They might be globals or whatever. Usually that would arise from XSUB code, but L can do the same from Perl code, use Array::RefElem 'av_store'; my $global; my @array; av_store (@array, 0, $global); In XSUB code a little care is needed that refcounts are correct after C or C takes ownership of one count etc. In all cases C can notice when an array or hash element doesn't destroy with its container. C etc will be needed for those which are intentionally persistent. Hash keys are not separate scalars. They're strings managed entirely by the hash and there's nothing separate for C to track. L and similar which allow arbitrary objects as keys of a hash do so by using the object C internally as the string key but presenting objects in C, C, etc. As of L 1.39 and L 0.09 those two modules hold the key objects within their tie object and therefore those key objects are successfully reached by C for leak checking in the usual way. =head2 Tracing Leaks =head3 Avoidance C makes tracing leaks easier, but avoidance is still by far the best way, and C helps with that. You need to use test-driven development, L, modular tests in a C subdirectory, and revision control. These are all very good ideas for many other reasons. Make C part of your test suite. Test frequently, so that when a leak occurs, you'll have a good idea of what changes were made since the last successful test. Often, examining these changes is enough to tell where the leak was introduced. =head3 Adding Tags The L method returns an array containing probes to the unfreed data objects. This can be used to find the source of leaks. If circumstances allow it, you might find it useful to add "tag" elements to arrays and hashes to aid in identifying the source of a leak. =head3 Using Referent Addresses You can quasi-uniquely identify data objects using the referent addresses of the probe references. A referent address can be determined by using C from L. You can also obtain the referent address of a reference by adding 0 to the reference. Note that in other Perl documentation, the term "reference address" is often used when a referent address is meant. Any given reference has both a reference address and a referent address. The B is the reference's own location in memory. The B is the address of the Perl data object to which the reference refers. It is the referent address that interests us here and, happily, it is the referent address that both zero addition and L return. =head3 Other Techniques Sometimes, when you are interested in why an object is not being freed, you want to seek out the reference that keeps the object's refcount above 0. L can be useful for this. =head2 More About Quasi-Unique Addresses I call referent addresses "quasi-unique", because they are only unique at a specific point in time. Once an object is freed, its address can be reused. Absent other evidence, a data object with a given referent address is not 100% certain to be the same data object as the object that had the same address earlier. This can bite you if you're not careful. To be sure an earlier data object and a later object with the same address are actually the same object, you need to know that the earlier object will be persistent, or to compare the two objects. If you want to be really pedantic, even an exact match from a comparison doesn't settle the issue. It is possible that two indiscernable (that is, completely identical) objects with the same referent address are different in the following sense: the first data object might have been destroyed and a second, identical, object created at the same address. But for most practical programming purposes, two indiscernable data objects can be regarded as the same object. =head2 Debugging Ignore Subroutines =head3 check_ignore =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/ignore.t', 'check_ignore 1 arg snippet') =end Marpa::Test::Display: $tester = Test::Weaken::leaks( { constructor => sub { MyObject->new() }, ignore => Test::Weaken::check_ignore( \&ignore_my_global ), } ); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: =begin Marpa::Test::Display: ## start display ## next display is_file($_, 't/ignore.t', 'check_ignore 4 arg snippet') =end Marpa::Test::Display: $tester = Test::Weaken::leaks( { constructor => sub { DeepObject->new() }, ignore => Test::Weaken::check_ignore( \&cause_deep_problem, 99, 0, $reporting_depth ), } ); =begin Marpa::Test::Display: ## end display =end Marpa::Test::Display: It can be hard to determine if C callback subroutines are inadvertently modifying the test structure. The L static method is provided to make this task easier. L constructs a debugging wrapper from four arguments, three of which are optional. The first argument must be the ignore callback that you are trying to debug. This callback is called the test subject, or B. The second, optional argument, is the maximum error count. Below this count, errors are reported as warnings using L. When the maximum error count is reached, an exception is thrown using L. The maximum error count, if defined, must be an number greater than or equal to 0. By default the maximum error count is 1, which means that the first error will be thrown as an exception. If the maximum error count is 0, all errors will be reported as warnings and no exception will ever be thrown. Infinite loops are a common behavior of buggy lab rats, and setting the maximum error count to 0 will usually not be something you want to do. The third, optional, argument is the B. It is the depth to which the probe referents will be checked, as described below. It must be a number greater than or equal to 0. If the compare depth is 0, the probe referent is checked to unlimited depth. By default the compare depth is 0. This fourth, optional, argument is the B. It is the depth to which the probe referents are dumped in L error messages. It must be a number greater than or equal to -1. If the reporting depth is 0, the object is dumped to unlimited depth. If the reporting depth is -1, there is no dump in the error message. By default, the reporting depth is -1. L returns a reference to the wrapper callback. If no problems are detected, the wrapper callback behaves exactly like the lab rat callback, except that the wrapper is slower. To discover when and if the lab rat callback is altering its arguments, L compares the test structure before the lab rat is called, to the test structure after the lab rat returns. L compares the before and after test structures in two ways. First, it dumps the contents of each test structure using L. For comparison purposes, the dump using L is performed with C set to the compare depth as described above. Second, if the immediate probe referent has builtin type REF, L determines whether the immediate probe referent is a weak reference or a strong one. If either comparison shows a difference, the wrapper treats it as a problem, and produces an error message. This error message is either a L warning or a L exception, depending on the number of error messages already reported and the setting of the maximum error count. If the reporting depth is a non-negative number, the error message includes a dump from L of the test structure. C's C for reporting purposes is the reporting depth as described above. A user who wants other features, such as deep checking of the test structure for strengthened references, can easily copy C from the C source and hack it up. C is a static method that does not use any C package resources. The hacked version can reside anywhere, and does not need to be part of the C package. =head1 XSUB Mortalizing When a C code XSUB returns a newly created scalar it should "mortalize" so the scalar is freed once the caller has finished with it. See L. Failing to do so leaks memory. SV *ret = newSViv(123); sv_2mortal (ret); /* must mortalize */ XPUSHs (ret); C can check this by taking a reference to the returned scalar, my $leaks = leaks (sub { return \( somexsub() ); }); if ($leaks) ... Don't store to a new local scalar and then return that since doing so will only check the local scalar, not the one made by C. If you want the value for further calculations then first take a reference to the return and then look through that for the value. leaks (sub { my $ref = \( somexsub() ); my $value = $$ref; # ... do something with $value return $ref; }); If an XSUB returns a list of values then take a reference to each as follows. This works because C and C make the loop variable (C<$_> or named) an alias to each value successively (see L and L). leaks (sub { return [ map {\$_} somexsub() ]; }); # or with a for loop leaks (sub { my @refs; foreach my $value (somexsub()) { push @refs, \$value; } return \@refs; }); Don't store a returned list to an array (named or anonymous) since this copies into new scalars in that array and the returned ones from C then aren't checked. If you want the returned values for extra calculations then take the references first and look through them for the values, as in the single case above. For example, leaks (sub { my @refs = map {\$_} somexsub(); my $first_ref = $refs[0] my $value = $$first_ref; # ... do something with $value return \@refs; }); An XSUB might deliberately return the same scalar each time, perhaps a pre-calculated constant or a global variable it maintains. In that case the scalar intentionally won't weaken away and this C checking is not applicable. Returning the same scalar every time occurs in pure Perl too with an anonymous constant subr such as created by the C module (see L). This is unlikely to arise directly, but might be seen through a scalar ref within an object etc. # FOO() returns same scalar every time *FOO = sub () { 123 }; # same from the constant module use constant BAR => 456; It's up to an XSUB etc how long return values are supposed to live. But generally if the code has any sort of C or C etc to make a new scalar as its return then that ought to weaken away. The details of an XSUB return are often hidden in a F file for brevity and consistency (see L). The standard typemap conversions of F are easy to use correctly. But code with explicit C etc is worth checking. The reference counting rules for C etc are slightly subtle too if building nested structures in XS. Usually missing mortalizing or ref count sinking will leak objects which C can detect. Too much mortalizing or ref count sinking will cause negative refcounts and probable segfaults. =head1 OLD FUNCTIONS The following C was from C 1.0 and has been superseded in 2.0 by C which is easier to use. =over =item C =item C Check that C<$obj> returned by the given constructor subroutine is freed when weakened. This is the same as C except for the style of the return values. In scalar context the return is a count of unfreed references. If everything is freed then this is 0. my $unfreed_count = Test::Weaken::poof(sub { return [1,2,3] }); if ($unfreed_count == 0 { print "No leaks\n"; } else { print "There were leaks\n"; } In array context the return is four values my ($weak_count, $strong_count, $weak_unfreed_aref, $strong_unfreed_aref) = Test::Weaken::poof (sub { return $obj }); $weak_count count of weak refs examined $strong_count count of strong refs examined $weak_unfreed_aref arrayref of unfreed weak refs $strong_unfreed_aref arrayref of unfreed strong refs The counts are total references examined. The arrayrefs give the unfreed ones. A distinction is made between strong references and weak references in the test structure. If there's no leaks then both C<$weak_unfreed_aref> and C<$strong_unfreed_aref> are empty arrays. There's usually not much interest in whether an unfreed thing was from a weak or strong reference. In the new C the C gives both together. The could be separated there by checking C on each if desired. =back =head1 IMPLEMENTATION DETAILS =head2 Overview C first recurses through the test structure. Starting from the test structure reference, it examines data objects for children recursively, until it has found the complete contents of the test structure. The test structure is explored to unlimited depth. For each tracked Perl data object, a probe reference is created. Tracked data objects are recorded. In the recursion, no object is visited twice, and infinite loops will not occur, even in the presence of cycles. Once recursion through the test structure is complete, the probe references are weakened. This prevents the probe references from interfering with the normal deallocation of memory. Next, the test structure destructor is called, if there is one. Finally, the test structure reference is set to C. This should trigger the deallocation of the entire contents of the test structure. To check that this happened, C dereferences the probe references. If the referent of a probe reference was deallocated, the value of that probe reference will be C. If a probe reference is still defined at this point, it refers to an unfreed Perl data object. =head2 Why the Test Structure is Passed Via a Closure C gets its test structure reference indirectly, as the return value from a B. Why so roundabout? Because the indirect way is the easiest. When you create the test structure in C's calling environment, it takes a lot of craft to avoid leaving unintended references to the test structure in that calling environment. It is easy to get this wrong. Those unintended references will create memory leaks that are artifacts of the test environment. Leaks that are artifacts of the test environment are very difficult to sort out from the real thing. The B is the easiest way to avoid leaving unintended references to the contents of Perl data objects. Using the closure-local strategy means working entirely within a closure, using only data objects local to that closure. Data objects local to a closure will be destroyed when the closure returns, and any references they held will be released. The closure-local strategy makes it relatively easy to be sure that nothing is left behind that will hold an unintended reference to any of the contents of the test structure. Nothing prevents a user from subverting the closure-local strategy. A test structure constructor can return a reference to a test structure created from Perl data objects in any scope the user desires. =head1 AUTHOR Jeffrey Kegler =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Weaken =head1 SUPPORT You can find documentation for this module with the perldoc command. =begin Marpa::Test::Display: ## skip display =end Marpa::Test::Display: perldoc Test::Weaken You can also look for information at: =over 4 =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * RT: CPAN's request tracker L =item * Search CPAN L =back =head1 SEE ALSO L, miscellaneous extras L, extras for use with Gtk2-Perl L, L C at this point is robust and has seen extensive use. Its tracking of memory is careful enough that it has even stumbled upon a bug in perl itself L. =head1 ACKNOWLEDGEMENTS Thanks to jettero, Juerd, morgon and perrin of Perlmonks for their advice. Thanks to Lincoln Stein (developer of L) for test cases and other ideas. Kevin Ryde made many important suggestions and provided the test cases which provided the impetus for the versions 2.000000 and after. For version 3.000000, Kevin also provided patches. =head1 LICENSE AND COPYRIGHT Copyright 2012 Jeffrey Kegler, all rights reserved. Copyright 2012 Kevin Ryde This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10. =cut 1; # End of Test::Weaken # For safety, L passes # the L callback a copy of the internal # probe reference. # This prevents the user # altering # the probe reference itself. # However, # the data object referred to by the probe reference is not copied. # Everything that is referred to, directly or indirectly, # by this # probe reference # should be left unchanged by the L # callback. # The result of modifying the probe referents might be # an exception, an abend, an infinite loop, or erroneous results. # Use of the L argument should be avoided # when possible. # Instead of using the L argument, it is # often possible to have the constructor # create a reference to a "wrapper structure", # L. # The L argument is # for situations where the "wrapper structure" # technique is not practical. # If, for example, # creating the wrapper structure would involve a recursive # descent through the lab rat object, # using the L argument may be easiest. # When specified, the value of the L argument must be a # reference to a callback subroutine. # If the reference is C<$contents>, # L's call to it will be the equivalent # of C<< $contents->($safe_copy) >>, # where C<$safe_copy> is a copy of the probe reference to # a Perl data object. # The L callback is made once # for every Perl data object # when that Perl data object is # about to be examined for children. # This can impose a significant overhead. # # The example of a L callback above adds data objects whenever it # encounters a I to a blessed object. # Compare this with the example for the L callback above. # Checking for references to blessed objects will not produce the same # behavior as checking for the blessed objects themselves -- # there may be many references to a single # object. # =head2 Persistent Objects # # As a practical matter, a descendant that is not # part of the contents of a # test structure is only a problem # if its lifetime extends beyond that of the test # structure. # A descendant that is expected to stay around after # the test structure is destroyed # is called a B. # # A persistent object is not a memory leak. # That's the problem. # L is trying to find memory leaks # and it looks for data objects that remain # after the test structure is freed. # But a persistent object is not expected to # disappear when the test structure goes away. # # We need to # separate the unfreed data objects which are memory leaks, # from those which are persistent data objects. # It's usually easiest to do this after the test by # examining the return value of L. # The C named argument can also be used # to pass L a closure # that separates out persistent data objects "on the fly". # These methods are described in detail # L. # =head2 Nieces # # A B (also a B or just a B) # is a data object that is part of the contents of a data # structure, # but that is not a descendant of the top object of that # data structure. # When the OO technique called # "inside-out objects" is used, # most of the attributes of the blessed object will be # nieces. # # In L, # usually the easiest way to deal with non-descendant contents # is to make the # data structure you are trying to test # the B in a B. # In this scheme, # your test structure constructor will return a reference # to the top object of the wrapper structure, # instead of to the top object of the lab rat. # # The top object of the wrapper structure will be a B. # The wrapper array will contain the top object of the lab rat, # along with other objects. # The other objects need to be # chosen so that the contents of the # wrapper array are exactly # the wrapper array itself, plus the contents # of the lab rat. # # It is not always easy to find the right objects to put into the wrapper array. # For example, determining the contents of the lab rat may # require a recursive scan from the lab rat's # top object. # Depending on the logical structure of the lab rat, # this may be far from trivial. # # As an alternative to using a wrapper, # it is possible to have L add # contents "on the fly," while it is scanning the lab rat. # This can be done using L named argument|/contents>, # which takes a closure as its value. # =head2 Data Objects, Blessed Objects and Structures # # B is a heavily overloaded term in the Perl world. # This document will use the term B # or B to refer to any referenceable Perl datum, # including # scalars, arrays, hashes, references themselves, and code objects. # The full list of types of referenceable Perl data objects # is given in # L. # An B that has been blessed using the Perl # L, will be called a B. # # In this document, # a Perl B (often just called a B) # is any group of Perl objects that are # co-mortal. # B means that the maintainer # expects those objects to be destroyed at the same time. # For example, if a group of Perl objects is referenced, # directly or indirectly, # through a hash, # and is referenced only through that hash, # a programmer will usually expect all of those objects # to be destroyed when the hash is. # # Perl data structures can be any set of # Perl data objects. # Since the question is one of I lifetime, # whether an object is part of a data structure # is, in the last analysis, subjective. # # =head2 The Contents of a Data Structure # # A B must have one object # that is designated as its B. # In most data structures, it is obvious which # data object should be designated as the top object. # The objects # in the data structure, including the top object, # are the B of that data structure. # # L gets its B, # or B, # from a closure. # The closure should return # a reference to the test structure. # This reference is called the B. # =head2 Builtin Types # # This document will refer to the builtin type of objects. # Perl's B are the types Perl originally gives objects, # as opposed to B, the types assigned objects by # the L. # The builtin types are listed in # L. # # Perl's L returns the blessed type of its # argument, if the argument has been blessed into a package. # Otherwise the # L returns the builtin type. # The L always returns the builtin type, # even for blessed objects. # L does not deal with # IO and LVALUE objects # gracefully, # issuing a cryptic warning whenever it encounters them. # Since L is a Perl core module # in extremely wide use, this suggests that these IO and LVALUE # objects are, to put it mildly, # not commonly encountered as the contents of data structures. # fill-column: 100 # # Local Variables: # mode: cperl # cperl-indent-level: 4 # End: # vim: expandtab shiftwidth=4: Test-Weaken-3.022000/README0000644000175000017500000000153011465421356012531 0ustar ggggTest-Weaken Test that freed memory objects were, indeed, freed INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Test::Weaken You can also look for information at: Search CPAN http://search.cpan.org/dist/Test-Weaken CPAN Request Tracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Weaken AnnoCPAN, annotated CPAN documentation: http://annocpan.org/dist/Test-Weaken CPAN Ratings: http://cpanratings.perl.org/d/Test-Weaken COPYRIGHT AND LICENCE Copyright (C) 2007-2009 Jeffrey Kegler This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10. Test-Weaken-3.022000/author.t/0002755000175000017500000000000012056244371013415 5ustar ggggTest-Weaken-3.022000/author.t/critic10000755000175000017500000000011211465421356014674 0ustar gggg#!/bin/sh cat $1 | ( cd ..; perlcritic --profile author.t/perlcriticrc ) Test-Weaken-3.022000/author.t/tidy10000755000175000017500000000007011465421356014373 0ustar gggg#!/bin/sh perltidy --profile=perltidyrc $1 | diff $1 - Test-Weaken-3.022000/author.t/Makefile0000644000175000017500000000023211465421356015053 0ustar gggg .PHONY: all critic display all: -(cd ..; prove author.t/*.t) critic: -(cd ..; prove author.t/critic.t) display: -(cd ..; prove author.t/display.t) Test-Weaken-3.022000/author.t/display.t0000644000175000017500000003175411465421356015262 0ustar gggg#!perl use Pod::Parser; use warnings; use strict; use English qw( -no_match_vars ); use Fatal qw(close); use Carp; use Getopt::Long qw(GetOptions); use Test::More; my $warnings = 0; my $options_result = GetOptions( 'warnings' => \$warnings ); Carp::croak("$PROGRAM_NAME options parsing failed") unless $options_result; package Marpa::Test::Display; @Marpa::Test::Display::ISA = qw(Exporter); @Marpa::Test::Display::EXPORT_OK = qw(test_file); use Text::Diff; use Carp; use Fatal qw(close); use English qw( -no_match_vars ); our $FILE_ERROR = 'No error'; our $PREAMBLE = q{1}; our $IN_COMMAND = 0; our @DISPLAY; our $DEFAULT_CODE = q{ no_code_defined($_) }; our $CURRENT_CODE = $DEFAULT_CODE; our $COLLECTING_FROM_LINE_NUM = -1; our $COLLECTED_DISPLAY; our $COMMAND_COUNTDOWN = 0; our $CURRENT_FILE = '!!! NO CURRENT FILE !!!'; our $DISPLAY_SKIP = 0; sub no_code_defined { my $display = shift; return 'No code defined to test display:'; } my %raw = (); my %normalized = (); my %raw_display = (); my %normalized_display = (); my %normalized_display_uses = (); sub normalize_whitespace { my $raw_ref = shift; my $text = ${$raw_ref}; $text =~ s/\A\s*//xms; $text =~ s/\s*\z//xms; $text =~ s/\s+/ /gxms; return \$text; } sub slurp { my ($file_name) = @_; my $open_result = open my $fh, '<', $file_name; if ( not $open_result ) { $Marpa::Test::Display::FILE_ERROR = "Cannot open $file_name: $ERRNO"; return; } local ($RS) = undef; my $result = \<$fh>; close $fh; return $result; } sub parse_displays { my $raw_ref = shift; my $result = {}; my @matches = ${$raw_ref} =~ m{ ^ [ \t]* [#] \h* [#] [\h#]* use [ \t]+ Marpa[:][:]Test[:][:]Display \h+ (\w+(?:\s+\w+)*) \s* \h* $ (.*?) ^ [ \t]* [#] \h* [#] [\h#]* no [ \t]+ Marpa[:][:]Test[:][:]Display \h* $ }xmsg; while (@matches) { my $display_name = shift @matches; my $display_text = shift @matches; $result->{$display_name} = \$display_text; } return $result; } sub read_file { my $file_name = shift; my $display_name = shift; my $file_ref = $normalized{$file_name}; if ( not defined $file_ref ) { my $raw_ref = $raw{$file_name} = slurp($file_name); return if not defined $raw_ref; $file_ref = $normalized{$file_name} = normalize_whitespace($raw_ref); my $raw_display = $raw_display{$file_name} = parse_displays($raw_ref); for my $raw_display_name ( keys %{$raw_display} ) { $normalized_display{$file_name}{$raw_display_name} = normalize_whitespace( $raw_display->{$raw_display_name} ); } } return $file_ref if not defined $display_name; my $display_ref = $normalized_display{$file_name}{$display_name}; if ( not defined $display_ref ) { Carp::croak("No display named '$display_name' in file: $file_name"); } $normalized_display_uses{$file_name}{$display_name}++; return $display_ref; } sub in_file { my ( $pod_display, $file_name, $display_name ) = @_; my $pod_display_ref = normalize_whitespace( \$pod_display ); my $file_display_ref = read_file( $file_name, $display_name ); if ( not defined $file_display_ref ) { return ( "$Marpa::Test::Display::FILE_ERROR\n", 1 ); } my $location = index ${$file_display_ref}, ${$pod_display_ref}; return ( ( $location >= 0 ? q{} : "Display in $Marpa::Test::Display::CURRENT_FILE not in $file_name\n" . $pod_display ), 1 ); } sub is_file { my ( $pod_display, $file_name, $display_name ) = @_; my $pod_display_ref = normalize_whitespace( \$pod_display ); my $file_display_ref = read_file( $file_name, $display_name ); if ( not defined $file_display_ref ) { return ( "$Marpa::Test::Display::FILE_ERROR\n", 1 ); } return q{} if ${$file_display_ref} eq ${$pod_display_ref}; my $raw_file_display = defined $display_name ? $raw_display{$file_name}{$display_name} : $raw{$file_name}; $pod_display =~ s/^\h*//gxms; ${$raw_file_display} =~ s/^\h*//gxms; my $header = $display_name ? "Display '$display_name'" : 'Display'; $header .= " in $Marpa::Test::Display::CURRENT_FILE differs from the one in $file_name"; return ( ( $header . ( Text::Diff::diff \$pod_display, $raw_file_display, { STYLE => 'Table' } ) ), 1 ); } sub test_file { my $file = shift; $Marpa::Test::Display::CURRENT_FILE = $file; @Marpa::Test::Display::DISPLAY = (); $Marpa::Test::Display::DEFAULT_CODE = q{ no_code_defined($_) }; $Marpa::Test::Display::CURRENT_CODE = $DEFAULT_CODE; $Marpa::Test::Display::COMMAND_COUNTDOWN = 0; $Marpa::Test::Display::DISPLAY_SKIP = 0; my $mismatch_count = 0; my $mismatches = q{}; my $parser = MyParser->new(); $parser->parse_from_file($file); ## no critic (BuiltinFunctions::ProhibitStringyEval) my $eval_result = eval $PREAMBLE; ## use critic Carp::croak($EVAL_ERROR) unless $eval_result; for my $display_test (@Marpa::Test::Display::DISPLAY) { my ( $display, $code, $display_file, $display_line ) = @{$display_test}{qw(display code file line)}; local $_ = $display; ## no critic (BuiltinFunctions::ProhibitStringyEval) $eval_result = eval '[ do {' . $code . '} ] '; ## use critic if (my $message = $eval_result ? $eval_result->[0] : $EVAL_ERROR . "Code with problem was:\n$code\n" ) { my $do_not_add_display = $eval_result->[1]; unless ($do_not_add_display) { $message .= "\n$display"; } $mismatches .= "=== $message"; $mismatch_count++; } } # $display_test return ( $mismatch_count, \$mismatches ); } # sub test_file package MyParser; @MyParser::ISA = qw(Pod::Parser); use Carp; sub queue_display { my $display = shift; my $line_num = shift; push @Marpa::Test::Display::DISPLAY, { 'display' => $display, 'code' => $Marpa::Test::Display::CURRENT_CODE, 'file' => $Marpa::Test::Display::CURRENT_FILE, 'line' => $line_num, } if not $Marpa::Test::Display::DISPLAY_SKIP; $Marpa::Test::Display::COMMAND_COUNTDOWN--; if ( $Marpa::Test::Display::COMMAND_COUNTDOWN <= 0 ) { $Marpa::Test::Display::CURRENT_CODE = $Marpa::Test::Display::DEFAULT_CODE; $Marpa::Test::Display::DISPLAY_SKIP = 0; } return; } sub verbatim { my ( $parser, $paragraph, $line_num ) = @_; if ( defined $Marpa::Test::Display::COLLECTED_DISPLAY ) { $Marpa::Test::Display::COLLECTED_DISPLAY .= $paragraph; $Marpa::Test::Display::COLLECTING_FROM_LINE_NUM //= $line_num; return; } queue_display( $paragraph, $line_num ); return; } sub process_instruction { my $instruction = shift; my $code = shift; my $line_num = shift; $instruction =~ s/\s\z//xms; # eliminate trailing whitespace $instruction =~ s/\s/ /gxms; # normalize whitespace if ( $instruction =~ /^ next \s+ display $ /xms ) { $Marpa::Test::Display::COMMAND_COUNTDOWN = 1; $Marpa::Test::Display::CURRENT_CODE = join "\n", @{$code}; return; } if ( $instruction =~ / ^ next \s+ (\d+) \s+ display(s)? $ /xms ) { $Marpa::Test::Display::COMMAND_COUNTDOWN = $1; Carp::croak( "File: $Marpa::Test::Display::CURRENT_FILE Line: $line_num\n", " 'next $Marpa::Test::Display::COMMAND_COUNTDOWN display' has countdown less than one\n" ) if $Marpa::Test::Display::COMMAND_COUNTDOWN < 1; $Marpa::Test::Display::CURRENT_CODE = join "\n", @{$code}; return; } if ( $instruction =~ / ^ default $ /xms ) { $Marpa::Test::Display::DEFAULT_CODE = join "\n", @{$code}; $Marpa::Test::Display::CURRENT_CODE = $Marpa::Test::Display::DEFAULT_CODE if $Marpa::Test::Display::COMMAND_COUNTDOWN <= 0; return; } if ( $instruction =~ / ^ preamble $ /xms ) { $Marpa::Test::Display::PREAMBLE .= join "\n", @{$code}; return; } if ( $instruction =~ / ^ skip \s+ display $ /xms ) { $Marpa::Test::Display::COMMAND_COUNTDOWN = 1; $Marpa::Test::Display::DISPLAY_SKIP++; return; } if ( $instruction =~ / ^ skip \s+ (\d+) \s+ display(s)? $ /xms ) { $Marpa::Test::Display::COMMAND_COUNTDOWN = $1; Carp::croak( "File: $Marpa::Test::Display::CURRENT_FILE Line: $line_num\n", " 'display $Marpa::Test::Display::COMMAND_COUNTDOWN skip' has countdown less than one\n" ) if $Marpa::Test::Display::COMMAND_COUNTDOWN < 1; $Marpa::Test::Display::DISPLAY_SKIP++; return; } if ( $instruction =~ /^ start \s+ display $/xms ) { $Marpa::Test::Display::COLLECTED_DISPLAY = q{}; return; } if ( $instruction =~ / ^ end \s+ display $ /xms ) { # line num will be set when first part of display is found queue_display( $Marpa::Test::Display::COLLECTED_DISPLAY, $Marpa::Test::Display::COLLECTING_FROM_LINE_NUM ); $Marpa::Test::Display::COLLECTED_DISPLAY = undef; $Marpa::Test::Display::COLLECTING_FROM_LINE_NUM = -1; return; } Carp::croak( "Unrecognized instruction in file $Marpa::Test::Display::CURRENT_FILE at line $line_num: $instruction\n" ); } sub textblock { my ( $parser, $paragraph, $line_num ) = @_; return unless $Marpa::Test::Display::IN_COMMAND; ## Translate/Format this block of text; sample actions might be: my @lines = split /\n/xms, $paragraph; my $found_instruction = 0; LINE: while ( my $line = shift @lines ) { next LINE if $line =~ /^\s*$/xms; # skip whitespace if ( $line =~ /\A[#][#]/xms ) { $line =~ s/\A[#][#]\s*//xms; process_instruction( $line, \@lines, $line_num ); $found_instruction = 1; next LINE; } Carp::croak( "File: $Marpa::Test::Display::CURRENT_FILE Line: $line_num\n", "test block doesn't begin with ## instruction\n$paragraph" ) if not $found_instruction; last LINE; } return; } sub interior_sequence { } sub command { my ( $parser, $command, $paragraph ) = @_; if ( $command eq 'begin' ) { $Marpa::Test::Display::IN_COMMAND++ if $paragraph =~ m{ \A Marpa[:][:]Test[:][:]Display[:] \s* \Z }xms; $Marpa::Test::Display::IN_COMMAND++ if $paragraph =~ /\Amake:$/xms; } elsif ( $command eq 'end' ) { $Marpa::Test::Display::IN_COMMAND = 0; } return; } package main; my %exclude = map { ( $_, 1 ) } qw( Makefile.PL ); my @test_files = (); open my $manifest, '<', 'MANIFEST' or Carp::croak("Cannot open MANIFEST: $ERRNO"); FILE: while ( my $file = <$manifest> ) { chomp $file; $file =~ s/\s*[#].*\z//xms; next FILE if $exclude{$file}; next FILE if -d $file; my ($ext) = $file =~ / [.] ([^.]+) \z /xms; next FILE unless defined $ext; $ext = lc $ext; next FILE if $ext ne 'pod' and $ext ne 'pl' and $ext ne 'pm' and $ext ne 't'; push @test_files, $file; } # FILE close $manifest; Test::More::plan tests => 1 + scalar @test_files; open my $error_file, '>', 'author.t/display.errs' or Carp::croak("Cannot open display.errs: $ERRNO"); FILE: for my $file (@test_files) { if ( not -f $file ) { Test::More::fail("attempt to test displays in non-file: $file"); next FILE; } my ( $mismatch_count, $mismatches ) = Marpa::Test::Display::test_file($file); my $clean = $mismatch_count == 0; my $message = $clean ? "displays match for $file" : "displays in $file has $mismatch_count mismatches"; Test::More::ok( $clean, $message ); next FILE if $clean; print {$error_file} "=== $file ===\n" . ${$mismatches} or Carp::croak("print failed: $ERRNO"); } my $unused = q{}; my $unused_count = 0; while ( my ( $file_name, $displays ) = each %normalized_display_uses ) { DISPLAY: while ( my ( $display_name, $uses ) = each %{$displays} ) { next DISPLAY if $uses > 0; $unused .= "display '$display_name' in $file_name never used\n"; $unused_count++; } } if ($unused_count) { Test::More::fail('$unused count displays not used'); print {$error_file} "=== UNUSED DISPLAYS ===\n" . $unused or Carp::croak("print failed: $ERRNO"); } else { Test::More::pass('all displays used'); } close $error_file; Test-Weaken-3.022000/author.t/critic.t0000644000175000017500000000547611465421356015074 0ustar gggg#!perl use strict; use warnings; use Test::More; use Fatal qw( open close waitpid ); use English qw( -no_match_vars ); use IPC::Open2; use POSIX qw(WIFEXITED); my %exclude = map { ( $_, 1 ) } qw( Makefile.PL ); sub run_critic { my $file = shift; my @cmd = ( #<<< perltidy messes this up 'perlcritic', '--verbose', '%l:%c %p %r\n', '--exclude', 'Dynamic::*', '-profile', 'author.t/perlcriticrc', #>>> ); push @cmd, $file; my ( $child_out, $child_in ); my $pid = IPC::Open2::open2( $child_out, $child_in, @cmd ) or Carp::croak("IPC::Open2 of perlcritic pipe failed: $ERRNO"); close $child_in; my $critic_output = do { local ($RS) = undef; <$child_out>; }; close $child_out; waitpid $pid, 0; if ( my $child_error = $CHILD_ERROR ) { my $error_message; if (WIFEXITED( ## perlcritic does not seem to understand what CHILD_ERROR_NATIVE is ## no critic (Variables::ProhibitPunctuationVars) ${^CHILD_ERROR_NATIVE} ## use critic ) != 1 ) { $error_message = "perlcritic returned $child_error"; } ## end if ( WIFEXITED( ${^CHILD_ERROR_NATIVE} ) != 1 ) if ( defined $error_message ) { print {*STDERR} $error_message, "\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); $critic_output .= "$error_message\n"; } return \$critic_output; } return q{}; } open my $manifest, '<', 'MANIFEST' or Carp::croak("open of MANIFEST failed: $ERRNO"); my @test_files = (); FILE: while ( my $file = <$manifest> ) { chomp $file; $file =~ s/\s*[#].*\z//xms; next FILE if -d $file; next FILE if $exclude{$file}; my ($ext) = $file =~ / [.] ([^.]+) \z /xms; next FILE if not defined $ext; $ext = lc $ext; next FILE if $ext ne 'pl' and $ext ne 'pm' and $ext ne 't'; push @test_files, $file; } # FILE close $manifest; Test::More::plan tests => scalar @test_files; open my $error_file, '>', 'author.t/perlcritic.errs'; FILE: for my $file (@test_files) { if ( not -f $file ) { Test::More::fail("perlcritic of non-file: $file"); next FILE; } my $warnings = run_critic($file); my $clean = 1; my $message = "perlcritic clean for $file"; if ($warnings) { $clean = 0; my @newlines = ( ${$warnings} =~ m/\n/xmsg ); $message = "perlcritic for $file: " . ( scalar @newlines ) . ' lines of warnings'; } Test::More::ok( $clean, $message ); next FILE if $clean; print {$error_file} "=== $file ===\n" . ${$warnings} or Carp::croak("print failed: $ERRNO"); } close $error_file; Test-Weaken-3.022000/author.t/perlcriticrc0000644000175000017500000001635511465421356016040 0ustar gggg# my severity conventions: 5 is normal. I don't currently use the # 3 or 4 severity levels -- I'm reserving them. 2 is interesting # warnings. 1 means basically turn it off, I don't care, I don't # think the warning is useful, or I don't agree that it's # a bad thing. severity = 3 color = 0 [BuiltinFunctions::ProhibitBooleanGrep] severity=5 [BuiltinFunctions::ProhibitComplexMappings] severity=5 [BuiltinFunctions::ProhibitLvalueSubstr] severity=5 [BuiltinFunctions::ProhibitReverseSortBlock] severity=5 [BuiltinFunctions::ProhibitSleepViaSelect] severity=5 [BuiltinFunctions::ProhibitStringyEval] severity=5 [BuiltinFunctions::ProhibitStringySplit] severity=5 [BuiltinFunctions::ProhibitUniversalCan] severity=5 [BuiltinFunctions::ProhibitUniversalIsa] severity=5 [BuiltinFunctions::ProhibitVoidGrep] severity=5 [BuiltinFunctions::ProhibitVoidMap] severity=5 [BuiltinFunctions::RequireBlockGrep] severity=5 [BuiltinFunctions::RequireBlockMap] severity=5 [BuiltinFunctions::RequireGlobFunction] severity=5 [BuiltinFunctions::RequireSimpleSortBlock] severity=5 [ClassHierarchies::ProhibitAutoloading] severity=5 [ClassHierarchies::ProhibitExplicitISA] severity=5 [ClassHierarchies::ProhibitOneArgBless] severity=5 [CodeLayout::ProhibitHardTabs] severity=5 [CodeLayout::ProhibitParensWithBuiltins] severity=5 [CodeLayout::ProhibitQuotedWordLists] severity=5 [CodeLayout::ProhibitTrailingWhitespace] severity=5 [CodeLayout::RequireConsistentNewlines] severity=5 [CodeLayout::RequireTrailingCommas] severity=5 [CodeLayout::RequireTidyCode] severity=5 perltidyrc=author.t/perltidyrc [ControlStructures::ProhibitCStyleForLoops] severity=5 [ControlStructures::ProhibitCascadingIfElse] severity=5 [ControlStructures::ProhibitDeepNests] severity=5 [ControlStructures::ProhibitMutatingListFunctions] severity=5 [ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions] severity=5 [ControlStructures::ProhibitPostfixControls] severity=2 [ControlStructures::ProhibitUnlessBlocks] severity=2 [ControlStructures::ProhibitUnreachableCode] severity=5 [ControlStructures::ProhibitUntilBlocks] severity=5 [Documentation::RequirePodAtEnd] severity=5 [Documentation::RequirePodSections] severity=5 lib_sections = NAME | DESCRIPTION | SUPPORT | AUTHOR | LICENSE AND COPYRIGHT script_sections = NAME | USAGE | OPTIONS | EXIT STATUS | AUTHOR [ErrorHandling::RequireCarping] severity=5 [InputOutput::ProhibitBacktickOperators] severity=5 [InputOutput::ProhibitBarewordFileHandles] severity=5 [InputOutput::ProhibitExplicitStdin] severity=5 [InputOutput::ProhibitInteractiveTest] severity=5 [InputOutput::ProhibitJoinedReadline] severity=5 [InputOutput::ProhibitOneArgSelect] severity=5 [InputOutput::ProhibitReadlineInForLoop] severity=5 [InputOutput::ProhibitTwoArgOpen] severity=5 [InputOutput::RequireBracedFileHandleWithPrint] severity=5 [InputOutput::RequireBriefOpen] severity=5 lines=99 [InputOutput::RequireCheckedClose] severity=5 [InputOutput::RequireCheckedOpen] severity=5 [InputOutput::RequireCheckedSyscalls] severity=5 functions = :builtins [Miscellanea::ProhibitFormats] severity=5 [Miscellanea::ProhibitTies] severity=5 [Miscellanea::RequireRcsKeywords] severity=1 [Modules::ProhibitAutomaticExportation] severity=5 [Modules::ProhibitEvilModules] severity=5 [Modules::ProhibitExcessMainComplexity] severity=1 [Modules::ProhibitMultiplePackages] severity=1 [Modules::RequireBarewordIncludes] severity=5 [Modules::RequireEndWithOne] severity=5 [Modules::RequireExplicitPackage] severity=5 [Modules::RequireFilenameMatchesPackage] severity=1 [Modules::RequireNoMatchVarsWithUseEnglish] severity=5 [Modules::RequireVersionVar] severity=1 [NamingConventions::ProhibitAmbiguousNames] severity=5 forbid = last left right no abstract contract record second close # set is OK -- as in earley set [References::ProhibitDoubleSigils] severity=5 [RegularExpressions::ProhibitCaptureWithoutTest] severity=5 [RegularExpressions::ProhibitComplexRegexes] severity=5 [RegularExpressions::ProhibitEnumeratedClasses] severity=5 [RegularExpressions::ProhibitEscapedMetacharacters] severity=5 [RegularExpressions::ProhibitFixedStringMatches] severity=5 [RegularExpressions::ProhibitSingleCharAlternation] severity=5 [RegularExpressions::ProhibitUnusedCapture] severity=5 [RegularExpressions::ProhibitUnusualDelimiters] severity=5 [RegularExpressions::RequireBracesForMultiline] severity=5 [RegularExpressions::RequireExtendedFormatting] severity=5 [RegularExpressions::RequireLineBoundaryMatching] severity=5 [Subroutines::ProhibitAmpersandSigils] severity=5 [Subroutines::ProhibitBuiltinHomonyms] severity=5 [Subroutines::ProhibitExcessComplexity] severity=2 [Subroutines::ProhibitExplicitReturnUndef] severity=5 [Subroutines::ProhibitManyArgs] severity=5 [Subroutines::ProhibitNestedSubs] severity=5 [Subroutines::ProhibitSubroutinePrototypes] severity=5 [Subroutines::ProtectPrivateSubs] severity=5 [Subroutines::RequireArgUnpacking] severity=5 [Subroutines::RequireFinalReturn] severity=5 [TestingAndDebugging::ProhibitNoStrict] severity=5 [TestingAndDebugging::ProhibitNoWarnings] severity=5 allow_with_category_restriction = 1 [TestingAndDebugging::ProhibitProlongedStrictureOverride] severity=5 [TestingAndDebugging::RequireTestLabels] severity=5 [TestingAndDebugging::RequireUseStrict] severity=5 [TestingAndDebugging::RequireUseWarnings] severity=5 [ValuesAndExpressions::ProhibitCommaSeparatedStatements] severity=5 [ValuesAndExpressions::ProhibitConstantPragma] severity=1 [ValuesAndExpressions::ProhibitEmptyQuotes] severity=5 [ValuesAndExpressions::ProhibitEscapedCharacters] severity=5 [ValuesAndExpressions::ProhibitImplicitNewlines] severity=5 [ValuesAndExpressions::ProhibitInterpolationOfLiterals] severity=5 [ValuesAndExpressions::ProhibitLeadingZeros] severity=5 [ValuesAndExpressions::ProhibitLongChainsOfMethodCalls] severity=5 [ValuesAndExpressions::ProhibitMismatchedOperators] severity=5 [ValuesAndExpressions::ProhibitMixedBooleanOperators] severity=5 [ValuesAndExpressions::ProhibitNoisyQuotes] severity=5 [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] severity=5 [ValuesAndExpressions::ProhibitVersionStrings] severity=5 [ValuesAndExpressions::RequireInterpolationOfMetachars] severity=2 [ValuesAndExpressions::RequireNumberSeparators] severity=5 [ValuesAndExpressions::RequireQuotedHeredocTerminator] severity=5 [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] severity=5 [Variables::ProhibitConditionalDeclarations] severity=5 [Variables::ProhibitLocalVars] severity=5 [Variables::ProhibitMatchVars] severity=5 [Variables::ProhibitPackageVars] severity=5 add_packages = Parse::Marpa::Read_Only Parse::Marpa::Internal::This Parse::Marpa::Internal [Variables::ProhibitPerl4PackageNames] severity=5 [Variables::ProhibitPunctuationVars] severity=5 [Variables::ProtectPrivateVars] severity=5 [Variables::RequireInitializationForLocalVars] severity=5 [Variables::RequireLexicalLoopIterators] severity=5 [Variables::RequireLocalizedPunctuationVars] severity=5 [Variables::RequireNegativeIndices] severity=5 [Subroutines::ProhibitCallsToUndeclaredSubs] severity=5 [Subroutines::ProhibitCallsToUnexportedSubs] severity=1 [Subroutines::ProhibitQualifiedSubDeclarations] severity=1 [Modules::RequireExplicitInclusion] severity=1 Test-Weaken-3.022000/author.t/perltidyrc0000644000175000017500000000135311465421356015524 0ustar gggg-l=78 # Max line width is 78 cols -i=4 # Indent level is 4 cols -ci=4 # Continuation indent is 4 cols -st # Output to STDOUT -se # Errors to STDERR -vt=2 # Maximum vertical tightness -cti=0 # No extra indentation for closing brackets -pt=1 # Medium parenthesis tightness -bt=1 # Medium brace tightness -sbt=1 # Medium square bracket tightness -bbt=1 # Medium block brace tightness -nsfs # No space before semicolons -nola # Don't outdent labels -nolq # Don't outdent long quoted strings -hsc # hanging side comments -nolc # Don't outdent long comments -ibc # Indent block comments -wbb="% + - * / x != == >= <= =~ !~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" # Break before all operators Test-Weaken-3.022000/author.t/do_tidy.pl0000644000175000017500000000351611465421356015413 0ustar gggg#!perl use strict; use warnings; use Fatal qw( open close waitpid ); use English qw( -no_match_vars ); use IPC::Open2; use POSIX qw(WIFEXITED); use Text::Diff; { package CountHunks; @CountHunks::ISA = qw( Text::Diff::Base ); sub hunk { return '1' } } package main; my %exclude = map { ( $_, 1 ) } qw( Changes MANIFEST META.yml Makefile.PL README etc/perlcriticrc etc/perltidyrc etc/last_minute_check.sh ); sub run_tidy { my $file = shift; my @cmd = qw(perltidy --profile=perltidyrc); push @cmd, $file; my ( $child_out, $child_in ); my $pid = IPC::Open2::open2( $child_out, $child_in, @cmd ) or Carp::croak("IPC::Open2 of perltidy pipe failed: $ERRNO"); close $child_in; my $tidy_output = do { local ($RS) = undef; <$child_out>; }; close $child_out; waitpid $pid, 0; my $diff = Text::Diff::diff $file, \$tidy_output, { STYLE => 'CountHunks', CONTEXT => 0 }; if ( my $child_error = $CHILD_ERROR ) { Carp::croak("perltidy returned $child_error"); } return $diff; } open my $manifest, '<', '../MANIFEST' or Carp::croak("open of MANIFEST failed: $ERRNO"); FILE: while ( my $file = <$manifest> ) { chomp $file; $file =~ s/\s*[#].*\z//xms; next FILE if $file =~ /.pod\z/xms; next FILE if $file =~ /.marpa\z/xms; next FILE if $file =~ /\/Makefile\z/xms; next FILE if $exclude{$file}; $file = '../' . $file; next FILE if -d $file; Carp::croak("No such file: $file") unless -f $file; my $result = run_tidy($file); if ($result) { print "$file: ", ( length $result ), " perltidy issues\n" or Carp::croak('Cannot print to STDOUT'); } else { print "$file: clean\n" or Carp::croak('Cannot print to STDOUT'); } } close $manifest; Test-Weaken-3.022000/sandbox/0002755000175000017500000000000012056244371013307 5ustar ggggTest-Weaken-3.022000/sandbox/elements.pl0000644000175000017500000000113411465421356015460 0ustar gggg#!perl # This is a sandbox for experiments with referencing and dereferencing. # It is not part of a test suite, not even an "author" test suite. use strict; use warnings; use Scalar::Util qw(reftype weaken); use Devel::Peek qw(); use Carp; use English qw( -no_match_vars ); use Fatal qw(open); my $scalar = 42; my @data; weaken( $data[0] = \$scalar ); print {*STDERR} "Dumping data array\n" or Carp::croak('Cannot print to STDERR'); Devel::Peek::Dump \@data; print {*STDERR} "\n" or Carp::croak('Cannot print to STDERR'); my ($probe_ref) = map { \$_ } @data; Devel::Peek::Dump $probe_ref; Test-Weaken-3.022000/sandbox/coderef.pl0000644000175000017500000000114611761623370015255 0ustar gggg#!/usr/bin/perl use strict; use warnings; use Test::Weaken; # uncomment this to run the ### lines use Smart::Comments; use constant und => \undef; my $global = 123; { package MyOverload; use overload '&{}' => sub { return sub { print "hello\n"; return [ \$global ]; return [ \\\undef ]; return main::und(); } }; sub new { return bless {}, shift; } } sub my_constructor { return [ \$global ]; } my $obj = MyOverload->new; &$obj(); my $tw = Test::Weaken::leaks ({ constructor => 'main::my_constructor', # constructor => $obj, }); ### $tw exit 0; Test-Weaken-3.022000/sandbox/dot.pl0000644000175000017500000000015611722236436014434 0ustar gggg#!/usr/bin/perl -w # perl -MO=Terse dot.pl require Carp; sub dd { die("foo"); } dd(1,2,3); die("foo","xx "); Test-Weaken-3.022000/sandbox/misc.pl0000644000175000017500000000275611763764473014625 0ustar gggg#!/usr/bin/perl use strict; use warnings; use Test::Weaken; # uncomment this to run the ### lines use Smart::Comments; { # Array::RefElem stored global detected use Array::RefElem; my $global = 123; my $tw = Test::Weaken::leaks ({ constructor => sub { my @array; my $aref = \@array; &Array::RefElem::av_store (\$aref, 0, $global); # Array::RefElem::av_store (@$aref, 0, $global); return \@array; # Array::RefElem::av_store (\@array, 0, $global); # return \@array; }, }); ### $tw exit 0; } { # Tie::RefHash::Weak key objects are detected my $global; my $tw = Test::Weaken::leaks ({ constructor => sub { require Tie::RefHash::Weak; my %hash; my $key = [ 123 ]; # $global = $key; my $value = [ 456 ]; tie %hash, 'Tie::RefHash::Weak', $key => $value; print values %hash,"\n"; ### keyaddr: $key+0 ### tieobj: tied %hash return \%hash; }, }); ### $tw exit 0; } { # Tie::RefHash key objects are detected my $global; my $tw = Test::Weaken::leaks ({ constructor => sub { require Tie::RefHash; my %hash; my $key = [ 123 ]; $global = $key; my $value = [ 456 ]; tie %hash, 'Tie::RefHash', $key => $value; print values %hash,"\n"; ### keyaddr: $key+0 ### tieobj: tied %hash return \%hash; }, }); ### $tw exit 0; } Test-Weaken-3.022000/sandbox/tied.pl0000644000175000017500000000633711465421356014603 0ustar gggg#!/usr/bin/perl use strict; use warnings; use Fatal qw(open read); use Symbol; use Data::Dumper; use Scalar::Util; use IO::File; use English qw( -no_match_vars ); use Carp; ## no critic (Miscellanea::ProhibitTies) package MyTiedFileHandle; use English qw( -no_match_vars ); use Carp; my $leaky_file_handle; sub TIEHANDLE { my ($class) = @_; my $i; my $tied_object = bless \$i, $class; $leaky_file_handle = $tied_object; return $tied_object; } ## end sub TIEHANDLE sub PRINT { my ( $r, @rest ) = @_; ${$r}++; print join( $OFS, map { uc $_ } @rest ), $ORS or Carp::croak("Cannot print to STDOUT: $ERRNO"); return; } ## end sub PRINT ## no critic (Subroutines::RequireArgUnpacking) sub READ { my $bufref = \$_[1]; ## use critic ## no critic (Miscellanea::ProhibitTies) my ( $self, undef, $len, $offset ) = @_; defined $offset or $offset = 0; ${$bufref} .= 'a'; return 1; } ## end sub READ package MyTie; my $leaky; sub TIESCALAR { my ($class) = @_; my $tobj = bless {}, $class; $leaky = $tobj; return $tobj; } ## end sub TIESCALAR sub TIEHASH { goto \&TIESCALAR; } sub FIRSTKEY { return; # no keys } sub TIEARRAY { goto \&TIESCALAR; } sub FETCH {return} sub FETCHSIZE { return 0; # no array elements } sub TIEHANDLE { goto \&TIESCALAR; } package main; my $scalar = 42; my $scalar_ref = \$scalar; my $ref_ref = \$scalar_ref; my $regexp_ref = qr/./xms; ## no critic (Subroutines::ProhibitCallsToUndeclaredSubs) my $vstring = v1.2.3.4; ## use critic my $vstring_ref = \$vstring; our $GLOB_HANDLE_NAME; our $IO_HANDLE_NAME; our $AUTOVIV_HANDLE_NAME; our $FH_HANDLE_NAME; my $glob_ref = *GLOB_HANDLE_NAME{'GLOB'}; my $io_ref = *IO_HANDLE_NAME{'IO'}; my $fh_ref = do { no warnings qw(deprecated); *FH_HANDLE_NAME{'FILEHANDLE'}; }; ## no critic (InputOutput::RequireBriefOpen) open my $autoviv_ref, q{<}, '/dev/null'; ## use critic my $string = 'abc' x 40; my $lvalue_ref = \( pos $string ); ${$lvalue_ref} = 7; my %data = ( 'scalar' => $scalar_ref, 'ref' => $ref_ref, 'regexp' => $regexp_ref, 'vstring' => $vstring_ref, 'lvalue' => $lvalue_ref, 'glob' => $glob_ref, 'autoviv' => $autoviv_ref, ); my %star_deref = map { ( $_, 1 ) } qw(glob autoviv); REF: while ( my ( $name, $ref ) = each %data ) { print "$name: ", ( ref $ref ), q{,}, ( Scalar::Util::reftype $ref), q{: } or Carp::croak("Cannot print to STDOUT: $ERRNO"); my $return; if ( $star_deref{$name} ) { ## no critic (Miscellanea::ProhibitTies) $return = eval { tie *{$ref}, 'MyTiedFileHandle'; 1 }; ## use critic } else { ## no critic (Miscellanea::ProhibitTies) $return = eval { tie ${$ref}, 'MyTie'; 1 }; ## use critic } print $return ? "ok\n" : "tie failed: $EVAL_ERROR" or Carp::croak("Cannot print to STDOUT: $ERRNO"); my $underlying = q{}; if ( $star_deref{$name} ) { $underlying = tied *{$ref}; } else { $underlying = tied ${$ref}; } print Data::Dumper->Dump( [$underlying], ['underlying'] ) or Carp::croak("Cannot print to STDOUT: $ERRNO"); } ## end while ( my ( $name, $ref ) = each %data ) exit 0; Test-Weaken-3.022000/sandbox/ignore.pl0000644000175000017500000000035511735223065015130 0ustar gggg#!/usr/bin/perl -w use strict; use Test::Weaken; # uncomment this to run the ### lines use Smart::Comments; my $tw = Test::Weaken->new({ constructor => sub { return [] }, }); ### $tw $tw->test; ### $tw Test-Weaken-3.022000/sandbox/scalar-util-instance.pl0000644000175000017500000000066211757316471017700 0ustar gggguse strict; use warnings; use Test::Weaken; use Scalar::Util::Instance { for => 'Foo', as => 'is_a_Foo' }; # uncomment this to run the ### lines use Smart::Comments; my $tw = Test::Weaken::leaks ({ constructor => sub { return Scalar::Util::Instance->generate_for('Bar'); }, }); ### $tw my $coderef = Scalar::Util::Instance->generate_for('Bar'); ### $coderef Scalar::Util::weaken($coderef); ### $coderef exit 0; Test-Weaken-3.022000/sandbox/html-tree.pl0000644000175000017500000000115111771445654015553 0ustar gggg#!/usr/bin/perl -w use strict; use Test::Weaken; # new HTML::Element doesn't need delete, -noweak asks for old behaviour use HTML::TreeBuilder '-noweak'; # uncomment this to run the ### lines use Smart::Comments; my $tw = Test::Weaken::leaks ({ constructor => sub { ### constructor ... my $tree = HTML::TreeBuilder->new_from_content (' A Web Page Blah '); # ### $tree return $tree; }, destructor_method => 'delete', }); ### $tw Test-Weaken-3.022000/sandbox/reftypes.pl0000644000175000017500000001265511465421356015517 0ustar gggg#!perl # This is a sandbox for experiments with referencing and dereferencing. # It is not part of a test suite, not even an "author" test suite. use strict; use warnings; use Scalar::Util qw(reftype weaken); use Data::Dumper; use Carp; use English qw( -no_match_vars ); use Fatal qw(open); sub try_dumper { my $probe_ref = shift; my @warnings = (); local $SIG{__WARN__} = sub { push @warnings, $_[0]; }; printf {*STDERR} 'Dumper: %s', Data::Dumper::Dumper( ${$probe_ref} ) or Carp::croak("Cannot print to STDERR: $ERRNO"); for my $warning (@warnings) { print {*STDERR} "Dumper warning: $warning" or Carp::croak("Cannot print to STDERR: $ERRNO"); } return scalar @warnings; } my $array_ref = \@{ [qw(42)] }; my $hash_ref = { a => 1, b => 2 }; my $scalar_ref = \42; my $ref_ref = \$scalar_ref; my $regexp_ref = qr/./xms; ## no critic (Subroutines::ProhibitCallsToUndeclaredSubs) my $vstring_ref = \(v1.2.3.4); ## use critic my $code_ref = \&try_dumper; ## no critic (Miscellanea::ProhibitFormats,References::ProhibitDoubleSigils,Subroutines::ProhibitCallsToUndeclaredSubs) format fmt = @<<<<<<<<<<<<<<< $_ . ## use critic ## no critic (Subroutines::ProhibitCallsToUndeclaredSubs) my $format_ref = *fmt{FORMAT}; my $glob_ref = *STDOUT{GLOB}; my $io_ref = *STDOUT{IO}; my $fh_ref = do { no warnings qw(deprecated); *STDOUT{FILEHANDLE}; }; ## use critic ## no critic (InputOutput::RequireBriefOpen) open my $autoviv_ref, q{>&STDERR}; ## use critic my $string = 'abc' x 40; my $lvalue_ref = \( pos $string ); ${$lvalue_ref} = 7; my %data = ( 'scalar' => $scalar_ref, 'array' => $array_ref, 'hash' => $hash_ref, 'ref' => $ref_ref, 'code' => $code_ref, 'regexp' => $regexp_ref, 'vstring' => $vstring_ref, 'format' => $format_ref, 'glob' => $glob_ref, 'io' => $io_ref, 'fh' => $fh_ref, 'autoviv' => $autoviv_ref, 'lvalue' => $lvalue_ref, ); REF: while ( my ( $name, $ref ) = each %data ) { printf {*STDERR} "==== $name, %s, %s ====\n", ( ref $ref ), ( reftype $ref) or Carp::croak("Cannot print to STDERR: $ERRNO"); try_dumper( \$ref ); } REF: for my $data_name (qw(scalar vstring regexp ref )) { my $ref = $data{$data_name}; printf {*STDERR} "=== Deref test $data_name, %s, %s ===\n", ( ref $ref ), ( reftype $ref ) or Carp::croak("Cannot print to STDERR: $ERRNO"); my $old_probe = \$ref; try_dumper($old_probe); my $new_probe = \${ ${$old_probe} }; try_dumper($new_probe); } REF: for my $ref ($format_ref) { my $probe = \$ref; print {*STDERR} 'Trying to deref ', ( ref $probe ), q{ }, ( ref $ref ), "\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); try_dumper($probe); # How to dereference ? } REF: for my $ref ($lvalue_ref) { my $probe = \$ref; print {*STDERR} 'Trying to deref ', ( ref $probe ), q{ }, ( ref $ref ), "\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); try_dumper($probe); my $new_probe = \${ ${$probe} }; printf {*STDERR} "pos is %d\n", ${$lvalue_ref}; ${$lvalue_ref} = 11; printf {*STDERR} "pos is %d\n", ${$lvalue_ref}; } REF: for my $ref ($io_ref) { my $probe = \$ref; print {*STDERR} 'Trying to deref ', ( ref $probe ), q{ }, ( ref $ref ), "\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); try_dumper($probe); my $new_probe = \*{ ${$probe} }; print { ${$new_probe} } "Printing via IO ref\n" or Carp::croak("Cannot print via IO ref: $ERRNO"); } REF: for my $ref ($fh_ref) { my $probe = \$ref; print {*STDERR} 'Trying to deref ', ( ref $probe ), q{ }, ( ref $ref ), "\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); try_dumper($probe); my $new_probe = \*{ ${$probe} }; print { ${$new_probe} } "Printing via FH ref\n" or Carp::croak("Cannot print via FH ref: $ERRNO"); } REF: for my $ref ($glob_ref) { my $probe = \$ref; print 'Trying to deref ', ( ref $probe ), q{ }, ( ref $ref ), "\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); try_dumper($probe); my $new_probe = \*{ ${$probe} }; print { ${$new_probe} } "Printing via GLOB ref\n" or Carp::croak("Cannot print via GLOB ref: $ERRNO"); } REF: for my $data_name (qw( glob autoviv )) { my $ref = $data{$data_name}; printf {*STDERR} "=== Deref test $data_name, %s, %s ===\n", ( ref $ref ), ( reftype $ref ) or Carp::croak("Cannot print to STDERR: $ERRNO"); my $old_probe = \$ref; try_dumper($old_probe); my $new_probe = \*{ ${$old_probe} }; print { ${$new_probe} } "Printing via $data_name ref\n" or Carp::croak("Cannot print via $data_name ref: $ERRNO"); try_dumper($new_probe); } REF: while ( my ( $name, $ref ) = each %data ) { my $ref_value = ref $ref; my $reftype_value = reftype $ref; printf "==== scalar ref test of $name, ref=$ref_value, reftype=$reftype_value\n" or Carp::croak("Cannot print to STDERR: $ERRNO"); my $eval_result = eval { my $deref = ${$ref}; 1 }; if ( defined $eval_result ) { print "scalar deref of $reftype_value ok\n" or Carp::croak("Cannot print to STDOUT: $ERRNO"); } else { print "scalar deref of $reftype_value failed: $EVAL_ERROR" or Carp::croak("Cannot print to STDOUT: $ERRNO"); } } ## end while ( my ( $name, $ref ) = each %data ) Test-Weaken-3.022000/META.yml0000644000175000017500000000120012056244371013111 0ustar gggg--- #YAML:1.0 name: Test-Weaken version: 3.022000 abstract: Test that freed memory objects were, indeed, freed author: - Jeffrey Kegler license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: perl: 5.006 Scalar::Util: 1.18 Test::More: 0 no_index: directory: - t - inc - sandbox generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4