Jakub Wilk is now a Perl author.
[perl.git] / t / op / dbm.t
1 #!./perl
2
3 BEGIN {
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
12 plan tests => 5;
13
14 # This is [20020104.007 (#8179)] "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     # 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 }