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 $prog = <<'EOC';
  17 package Foo;
  18 sub new {
  19         my $proto = shift;
  20         my $class = ref($proto) || $proto;
  21         my $self  = {};
  22         bless($self,$class);
  23         my %LT;
  24         dbmopen(%LT, "dbmtest", 0666) ||
  25             die "Can't open dbmtest because of $!\n";
  26         $self->{'LT'} = \%LT;
  27         return $self;
  28 }
  29 sub DESTROY {
  30         my $self = shift;
  31         dbmclose(%{$self->{'LT'}});
  32         1 while unlink 'dbmtest';
  33         1 while unlink <dbmtest.*>;
  34         print "ok\n";
  35 }
  36 package main;
  37 $test = Foo->new(); # must be package var
  38 EOC
  39
  40 fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require');
  41 fresh_perl_is($prog, 'ok', {}, 'implicit require');
  42
  43 $prog = <<'EOC';
  44 @INC = ();
  45 dbmopen(%LT, "dbmtest", 0666);
  46 1 while unlink 'dbmtest';
  47 1 while unlink <dbmtest.*>;
  48 die "Failed to fail!";
  49 EOC
  50
  51 fresh_perl_like($prog, qr/No dbm on this machine/, {},
  52                 'implicit require fails');
  53 fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog,
  54                 qr/No dbm on this machine/, {},
  55                 'implicit require and no stash fails');