#!./perl
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
-if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h'
- && !-r '/usr/include/rpcsvc/dbm.h') {
- print "1..0\n";
- exit;
+ eval { require AnyDBM_File }; # not all places have dbm* functions
+ skip_all("No dbm functions") if $@;
}
-print "1..12\n";
-
-unlink <Op.dbmx.*>;
-unlink Op.dbmx; # in case we're running gdbm
-
-umask(0);
-print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n");
-
-$Dfile = "Op.dbmx.pag";
-if (! -e $Dfile) {
- $Dfile = "Op.dbmx";
- print "# Probably a gdbm database\n";
+plan tests => 4;
+
+# This is [20020104.007] "coredump on dbmclose"
+
+my $filename = tempfile();
+
+my $prog = <<'EOC';
+package Foo;
+$filename = '@@@@';
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ bless($self,$class);
+ my %LT;
+ dbmopen(%LT, $filename, 0666) ||
+ die "Can't open $filename because of $!\n";
+ $self->{'LT'} = \%LT;
+ return $self;
}
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
-while (($key,$value) = each(h)) {
- $i++;
-}
-print (!$i ? "ok 3\n" : "not ok 3\n");
-
-$h{'goner1'} = 'snork';
-
-$h{'abc'} = 'ABC';
-$h{'def'} = 'DEF';
-$h{'jkl','mno'} = "JKL\034MNO";
-$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
-$h{'a'} = 'A';
-$h{'b'} = 'B';
-$h{'c'} = 'C';
-$h{'d'} = 'D';
-$h{'e'} = 'E';
-$h{'f'} = 'F';
-$h{'g'} = 'G';
-$h{'h'} = 'H';
-$h{'i'} = 'I';
-
-$h{'goner2'} = 'snork';
-delete $h{'goner2'};
-
-dbmclose(h);
-print (dbmopen(h,'Op.dbmx',0640) ? "ok 4\n" : "not ok 4\n");
-
-$h{'j'} = 'J';
-$h{'k'} = 'K';
-$h{'l'} = 'L';
-$h{'m'} = 'M';
-$h{'n'} = 'N';
-$h{'o'} = 'O';
-$h{'p'} = 'P';
-$h{'q'} = 'Q';
-$h{'r'} = 'R';
-$h{'s'} = 'S';
-$h{'t'} = 'T';
-$h{'u'} = 'U';
-$h{'v'} = 'V';
-$h{'w'} = 'W';
-$h{'x'} = 'X';
-$h{'y'} = 'Y';
-$h{'z'} = 'Z';
-
-$h{'goner3'} = 'snork';
-
-delete $h{'goner1'};
-delete $h{'goner3'};
-
-@keys = keys(%h);
-@values = values(%h);
-
-if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
-
-while (($key,$value) = each(h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
- $key =~ y/a-z/A-Z/;
- $i++ if $key eq $value;
- }
+sub DESTROY {
+ my $self = shift;
+ dbmclose(%{$self->{'LT'}});
+ 1 while unlink $filename;
+ 1 while unlink glob "$filename.*";
+ print "ok\n";
}
-
-if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
-
-@keys = ('blurfl', keys(h), 'dyick');
-if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
-
-$h{'foo'} = '';
-$h{''} = 'bar';
-
-# check cache overflow and numeric keys and contents
-$ok = 1;
-for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
-for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
-print ($ok ? "ok 8\n" : "not ok 8\n");
-
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-print ($size > 0 ? "ok 9\n" : "not ok 9\n");
-
-@h{0..200} = 200..400;
-@foo = @h{0..200};
-print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
-
-print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
-print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
-
-unlink 'Op.dbmx.dir', $Dfile;
+package main;
+$test = Foo->new(); # must be package var
+EOC
+
+$prog =~ s/\@\@\@\@/$filename/;
+
+fresh_perl_is("require AnyDBM_File;\n$prog", 'ok', {}, 'explict require');
+fresh_perl_is($prog, 'ok', {}, 'implicit require');
+
+$prog = <<'EOC';
+@INC = ();
+dbmopen(%LT, $filename, 0666);
+1 while unlink $filename;
+1 while unlink glob "$filename.*";
+die "Failed to fail!";
+EOC
+
+fresh_perl_like($prog, qr/No dbm on this machine/, {},
+ 'implicit require fails');
+fresh_perl_like('delete $::{"AnyDBM_File::"}; ' . $prog,
+ qr/No dbm on this machine/, {},
+ 'implicit require and no stash fails');
https://perl5.git.perl.org / perl5.git / blobdiff