This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change from a hard coded temporary file name in lib/AnyDBM_File.t.
[perl5.git] / lib / AnyDBM_File.t
CommitLineData
bee1dbe2
LW
1#!./perl
2
a0d0e21e
LW
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
be3174d2 6 require Config; import Config;
be6bd645 7 require Test::More; import Test::More;
b3ce290b 8 plan(tests, 12);
a0d0e21e 9}
223eb2ff 10
a0d0e21e 11require AnyDBM_File;
a0d0e21e
LW
12use Fcntl;
13
bee1dbe2 14
592a6412
JH
15$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' ||
16 $^O eq 'NetWare' || $^O eq 'dos' ||
17 $^O eq 'os2' || $^O eq 'mint' ||
18 $^O eq 'cygwin');
8736538c 19
bdbb64c2
NC
20my $filename = "Any_dbmx$$";
21unlink <"$filename*">;
a0d0e21e 22
bee1dbe2 23umask(0);
223eb2ff 24
bdbb64c2 25ok( tie(%h,AnyDBM_File,"$filename", O_RDWR|O_CREAT, 0640), "Tie");
a0d0e21e 26
bdbb64c2 27$Dfile = "$filename.pag";
a0d0e21e 28if (! -e $Dfile) {
bdbb64c2 29 ($Dfile) = <$filename*>;
a0d0e21e 30}
223eb2ff
JS
31
32SKIP:
33{
34 skip( "different file permission semantics",1)
35 if ($Is_Dosish || $^O eq 'MacOS') ;
544a3566
CS
36 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
37 $blksize,$blocks) = stat($Dfile);
2825d001 38 ok(($mode & 0777) == ($^O eq 'vos' ? 0750 : 0640) , "File permissions");
544a3566 39}
223eb2ff 40
a0d0e21e 41while (($key,$value) = each(%h)) {
bee1dbe2
LW
42 $i++;
43}
223eb2ff
JS
44
45ok(!$i,"Hash created empty");
bee1dbe2
LW
46
47$h{'goner1'} = 'snork';
48
49$h{'abc'} = 'ABC';
50$h{'def'} = 'DEF';
51$h{'jkl','mno'} = "JKL\034MNO";
52$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
53$h{'a'} = 'A';
54$h{'b'} = 'B';
55$h{'c'} = 'C';
56$h{'d'} = 'D';
57$h{'e'} = 'E';
58$h{'f'} = 'F';
59$h{'g'} = 'G';
60$h{'h'} = 'H';
61$h{'i'} = 'I';
62
63$h{'goner2'} = 'snork';
64delete $h{'goner2'};
65
a0d0e21e 66untie(%h);
bdbb64c2 67ok(tie(%h,AnyDBM_File,"$filename", O_RDWR, 0640),"Re-tie hash");
bee1dbe2
LW
68
69$h{'j'} = 'J';
70$h{'k'} = 'K';
71$h{'l'} = 'L';
72$h{'m'} = 'M';
73$h{'n'} = 'N';
74$h{'o'} = 'O';
75$h{'p'} = 'P';
76$h{'q'} = 'Q';
77$h{'r'} = 'R';
78$h{'s'} = 'S';
79$h{'t'} = 'T';
80$h{'u'} = 'U';
81$h{'v'} = 'V';
82$h{'w'} = 'W';
83$h{'x'} = 'X';
84$h{'y'} = 'Y';
85$h{'z'} = 'Z';
86
87$h{'goner3'} = 'snork';
88
89delete $h{'goner1'};
90delete $h{'goner3'};
91
92@keys = keys(%h);
93@values = values(%h);
94
223eb2ff 95ok( ($#keys == 29 && $#values == 29),'$#keys == $#values');
bee1dbe2 96
c6aa4a32 97while (($key,$value) = each(%h)) {
2f52a358 98 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
bee1dbe2
LW
99 $key =~ y/a-z/A-Z/;
100 $i++ if $key eq $value;
101 }
102}
103
223eb2ff 104ok($i == 30,"keys and values match");
bee1dbe2 105
c6aa4a32 106@keys = ('blurfl', keys(%h), 'dyick');
223eb2ff 107ok($#keys == 31,"Correct number of keys");
bee1dbe2
LW
108
109$h{'foo'} = '';
110$h{''} = 'bar';
111
112# check cache overflow and numeric keys and contents
113$ok = 1;
114for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
115for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
223eb2ff 116ok($ok, "cache overflow and numeric keys and contents");
bee1dbe2
LW
117
118($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
a0d0e21e 119 $blksize,$blocks) = stat($Dfile);
223eb2ff 120ok($size > 0, "check file size");
bee1dbe2
LW
121
122@h{0..200} = 200..400;
123@foo = @h{0..200};
223eb2ff 124ok( join(':',200..400) eq join(':',@foo), "hash slice");
bee1dbe2 125
223eb2ff
JS
126ok($h{'foo'} eq '', "empty value");
127
128my $compact = '';
129
408a2300 130if ($AnyDBM_File::ISA[0] eq 'DB_File' && ($DB_File::db_ver >= 2.004010 && $DB_File::db_ver < 3.001)) {
f94c1b37
PM
131 ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ;
132 $major =~ s/^0+// ;
133 $minor =~ s/^0+// ;
134 $patch =~ s/^0+// ;
135 $compact = "$major.$minor.$patch" ;
206483f1
GS
136 #
137 # anydbm.t test 12 will fail when AnyDBM_File uses the combination of
138 # DB_File and Berkeley DB 2.4.10 (or greater).
139 # You are using DB_File $DB_File::VERSION and Berkeley DB $compact
140 #
141 # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys.
408a2300 142 # This feature returned with version 3.1
206483f1 143 #
223eb2ff
JS
144}
145
146SKIP:
147{
148 skip( "db v$compact, no null key support", 1) if $compact;
149 ok($h{''} eq 'bar','null key');
f94c1b37 150}
bee1dbe2 151
bbad3607 152untie %h;
223eb2ff 153
bf99883d 154if ($^O eq 'VMS') {
bdbb64c2 155 unlink "$filename.sdbm_dir", $Dfile;
bf99883d 156} else {
bdbb64c2 157 unlink "$filename.dir", $Dfile;
bf99883d 158}