t/op/dbm.t

   1 #!./perl
   2
   3 BEGIN {
   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
  12 plan tests => 4;
  13
  14 # This is [20020104.007] "coredump on dbmclose"
  15
  16 my $filename = tempfile();
  17
  18 my $prog = <<'EOC';
  19 package Foo;
  20 $filename = '@@@@';
  21 sub 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 }
  32 sub 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 }
  39 package main;
  40 $test = Foo->new(); # must be package var
  41 EOC
  42
  43 $prog =~ s/\@\@\@\@/$filename/;
  44
  45 fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require');
  46 fresh_perl_is($prog, 'ok', {}, 'implicit require');
  47
  48 $prog = <<'EOC';
  49 @INC = ();
  50 dbmopen(%LT, $filename, 0666);
  51 1 while unlink $filename;
  52 1 while unlink glob "$filename.*";
  53 die "Failed to fail!";
  54 EOC
  55
  56 fresh_perl_like($prog, qr/No dbm on this machine/, {},
  57                 'implicit require fails');
  58 fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog,
  59                 qr/No dbm on this machine/, {},
  60                 'implicit require and no stash fails');