1#!./perl 2 3BEGIN { 4 chdir 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7 8 eval { require AnyDBM_File }; # not all places have dbm* functions 9 skip_all("No dbm functions") if $@; 10} 11 12plan tests => 4; 13 14# This is [20020104.007] "coredump on dbmclose" 15 16my $filename = tempfile(); 17 18my $prog = <<'EOC'; 19package Foo; 20$filename = '@@@@'; 21sub new { 22 my $proto = shift; 23 my $class = ref($proto) || $proto; 24 my $self = {}; 25 bless($self,$class); 26 my %LT; 27 dbmopen(%LT, $filename, 0666) || 28 die "Can't open $filename because of $!\n"; 29 $self->{'LT'} = \%LT; 30 return $self; 31} 32sub DESTROY { 33 my $self = shift; 34 dbmclose(%{$self->{'LT'}}); 35 1 while unlink $filename; 36 1 while unlink glob "$filename.*"; 37 print "ok\n"; 38} 39package main; 40$test = Foo->new(); # must be package var 41EOC 42 43$prog =~ s/\@\@\@\@/$filename/; 44 45fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require'); 46fresh_perl_is($prog, 'ok', {}, 'implicit require'); 47 48$prog = <<'EOC'; 49@INC = (); 50dbmopen(%LT, $filename, 0666); 511 while unlink $filename; 521 while unlink glob "$filename.*"; 53die "Failed to fail!"; 54EOC 55 56fresh_perl_like($prog, qr/No dbm on this machine/, {}, 57 'implicit require fails'); 58fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog, 59 qr/No dbm on this machine/, {}, 60 'implicit require and no stash fails'); 61