1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7 8 eval { require AnyDBM_File }; # not all places have dbm* functions 9 skip_all("No dbm functions") if $@; 10} 11 12plan tests => 5; 13 14# This is [20020104.007 (#8179)] "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', {}, 'explicit 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 62{ # undef 3rd arg 63 local $^W = 1; 64 local $SIG{__WARN__} = sub { ++$w }; 65 # Files may get created as a side effect of dbmopen, so ensure cleanup. 66 my $leaf = 'pleaseletthisfilenotexist'; 67 dbmopen(%truffe, $leaf, undef); 68 is $w, 1, '1 warning from dbmopen with undef third arg'; 69 unlink $leaf 70 if -e $leaf; 71 1 while unlink glob "$leaf.*"; 72} 73