This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9e81f590edd912fc78ab235d62bf6cc7ea71b363
[perl5.git] / 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 => 5;
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', {}, 'explicit 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');
61
62 { # undef 3rd arg
63     local $^W = 1;
64     local $SIG{__WARN__} = sub { ++$w };
65     dbmopen(%truffe, 'pleaseletthisfilenotexist', undef);
66     is $w, 1, '1 warning from dbmopen with undef third arg';
67 }