Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
79072805 | 3 | # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ |
a687059c | 4 | |
85e6fe83 | 5 | BEGIN { |
a0d0e21e | 6 | chdir 't' if -d 't'; |
20822f61 | 7 | @INC = '../lib'; |
85e6fe83 | 8 | require Config; import Config; |
bf99883d | 9 | if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ |
a0d0e21e | 10 | print "1..0\n"; |
85e6fe83 LW |
11 | exit 0; |
12 | } | |
13 | } | |
698828ad JH |
14 | |
15 | use strict; | |
16 | use warnings; | |
17 | ||
18 | sub ok | |
19 | { | |
20 | my $no = shift ; | |
21 | my $result = shift ; | |
22 | ||
23 | print "not " unless $result ; | |
24 | print "ok $no\n" ; | |
25 | } | |
26 | ||
8990e307 | 27 | require SDBM_File; |
a0d0e21e LW |
28 | #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT |
29 | use Fcntl; | |
a687059c | 30 | |
0bf2e707 | 31 | print "1..74\n"; |
a687059c | 32 | |
bf99883d | 33 | unlink <Op_dbmx.*>; |
79072805 | 34 | |
a687059c | 35 | umask(0); |
698828ad JH |
36 | my %h ; |
37 | ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); | |
79072805 | 38 | |
698828ad | 39 | my $Dfile = "Op_dbmx.pag"; |
79072805 | 40 | if (! -e $Dfile) { |
bf99883d | 41 | ($Dfile) = <Op_dbmx.*>; |
79072805 | 42 | } |
cd4b52c2 | 43 | if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin') { |
fac76ed7 | 44 | print "ok 2 # Skipped: different file permission semantics\n"; |
544a3566 CS |
45 | } |
46 | else { | |
698828ad | 47 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
544a3566 | 48 | $blksize,$blocks) = stat($Dfile); |
d9c1b26a | 49 | print (($mode & 0777) == ($^O eq 'vos' ? 0750 : 0640) ? "ok 2\n" : "not ok 2\n"); |
544a3566 | 50 | } |
698828ad JH |
51 | my $i = 0; |
52 | while (my ($key,$value) = each(%h)) { | |
a687059c LW |
53 | $i++; |
54 | } | |
55 | print (!$i ? "ok 3\n" : "not ok 3\n"); | |
56 | ||
57 | $h{'goner1'} = 'snork'; | |
58 | ||
59 | $h{'abc'} = 'ABC'; | |
60 | $h{'def'} = 'DEF'; | |
61 | $h{'jkl','mno'} = "JKL\034MNO"; | |
62 | $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); | |
63 | $h{'a'} = 'A'; | |
64 | $h{'b'} = 'B'; | |
65 | $h{'c'} = 'C'; | |
66 | $h{'d'} = 'D'; | |
67 | $h{'e'} = 'E'; | |
68 | $h{'f'} = 'F'; | |
69 | $h{'g'} = 'G'; | |
70 | $h{'h'} = 'H'; | |
71 | $h{'i'} = 'I'; | |
72 | ||
73 | $h{'goner2'} = 'snork'; | |
74 | delete $h{'goner2'}; | |
75 | ||
463ee0b2 | 76 | untie(%h); |
698828ad | 77 | print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); |
a687059c LW |
78 | |
79 | $h{'j'} = 'J'; | |
80 | $h{'k'} = 'K'; | |
81 | $h{'l'} = 'L'; | |
82 | $h{'m'} = 'M'; | |
83 | $h{'n'} = 'N'; | |
84 | $h{'o'} = 'O'; | |
85 | $h{'p'} = 'P'; | |
86 | $h{'q'} = 'Q'; | |
87 | $h{'r'} = 'R'; | |
88 | $h{'s'} = 'S'; | |
89 | $h{'t'} = 'T'; | |
90 | $h{'u'} = 'U'; | |
91 | $h{'v'} = 'V'; | |
92 | $h{'w'} = 'W'; | |
93 | $h{'x'} = 'X'; | |
94 | $h{'y'} = 'Y'; | |
95 | $h{'z'} = 'Z'; | |
96 | ||
97 | $h{'goner3'} = 'snork'; | |
98 | ||
99 | delete $h{'goner1'}; | |
100 | delete $h{'goner3'}; | |
101 | ||
698828ad JH |
102 | my @keys = keys(%h); |
103 | my @values = values(%h); | |
a687059c LW |
104 | |
105 | if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} | |
106 | ||
698828ad | 107 | while (my ($key,$value) = each(%h)) { |
2f52a358 | 108 | if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { |
a687059c LW |
109 | $key =~ y/a-z/A-Z/; |
110 | $i++ if $key eq $value; | |
111 | } | |
112 | } | |
113 | ||
114 | if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} | |
115 | ||
c6aa4a32 | 116 | @keys = ('blurfl', keys(%h), 'dyick'); |
a687059c LW |
117 | if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} |
118 | ||
fe14fcc3 LW |
119 | $h{'foo'} = ''; |
120 | $h{''} = 'bar'; | |
121 | ||
a687059c | 122 | # check cache overflow and numeric keys and contents |
698828ad | 123 | my $ok = 1; |
a687059c LW |
124 | for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } |
125 | for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } | |
126 | print ($ok ? "ok 8\n" : "not ok 8\n"); | |
127 | ||
698828ad | 128 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
79072805 | 129 | $blksize,$blocks) = stat($Dfile); |
a687059c LW |
130 | print ($size > 0 ? "ok 9\n" : "not ok 9\n"); |
131 | ||
0f85fab0 | 132 | @h{0..200} = 200..400; |
698828ad | 133 | my @foo = @h{0..200}; |
fe14fcc3 LW |
134 | print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; |
135 | ||
136 | print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); | |
137 | print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); | |
0f85fab0 | 138 | |
4e2a63a7 | 139 | |
4e2a63a7 PM |
140 | { |
141 | # sub-class test | |
142 | ||
143 | package Another ; | |
144 | ||
145 | use strict ; | |
698828ad | 146 | use warnings ; |
4e2a63a7 PM |
147 | |
148 | open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; | |
149 | print FILE <<'EOM' ; | |
150 | ||
151 | package SubDB ; | |
152 | ||
153 | use strict ; | |
698828ad | 154 | use warnings ; |
4e2a63a7 PM |
155 | use vars qw( @ISA @EXPORT) ; |
156 | ||
157 | require Exporter ; | |
158 | use SDBM_File; | |
159 | @ISA=qw(SDBM_File); | |
160 | @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ; | |
161 | ||
162 | sub STORE { | |
163 | my $self = shift ; | |
164 | my $key = shift ; | |
165 | my $value = shift ; | |
166 | $self->SUPER::STORE($key, $value * 2) ; | |
167 | } | |
168 | ||
169 | sub FETCH { | |
170 | my $self = shift ; | |
171 | my $key = shift ; | |
172 | $self->SUPER::FETCH($key) - 1 ; | |
173 | } | |
174 | ||
175 | sub A_new_method | |
176 | { | |
177 | my $self = shift ; | |
178 | my $key = shift ; | |
179 | my $value = $self->FETCH($key) ; | |
180 | return "[[$value]]" ; | |
181 | } | |
182 | ||
183 | 1 ; | |
184 | EOM | |
185 | ||
d1e4d418 | 186 | close FILE or die "Could not close: $!"; |
4e2a63a7 PM |
187 | |
188 | BEGIN { push @INC, '.'; } | |
189 | ||
190 | eval 'use SubDB ; use Fcntl ;'; | |
191 | main::ok(13, $@ eq "") ; | |
192 | my %h ; | |
193 | my $X ; | |
194 | eval ' | |
bf99883d | 195 | $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 ); |
4e2a63a7 PM |
196 | ' ; |
197 | ||
198 | main::ok(14, $@ eq "") ; | |
199 | ||
200 | my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; | |
201 | main::ok(15, $@ eq "") ; | |
202 | main::ok(16, $ret == 5) ; | |
203 | ||
204 | $ret = eval '$X->A_new_method("fred") ' ; | |
205 | main::ok(17, $@ eq "") ; | |
206 | main::ok(18, $ret eq "[[5]]") ; | |
207 | ||
fac76ed7 MB |
208 | undef $X; |
209 | untie(%h); | |
bf99883d | 210 | unlink "SubDB.pm", <dbhash_tmp.*> ; |
4e2a63a7 PM |
211 | |
212 | } | |
f4b9d880 RA |
213 | |
214 | ok(19, !exists $h{'goner1'}); | |
215 | ok(20, exists $h{'foo'}); | |
216 | ||
217 | untie %h; | |
9fe6733a PM |
218 | unlink <Op_dbmx*>, $Dfile; |
219 | ||
220 | { | |
221 | # DBM Filter tests | |
222 | use strict ; | |
698828ad | 223 | use warnings ; |
9fe6733a PM |
224 | my (%h, $db) ; |
225 | my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
226 | ||
227 | sub checkOutput | |
228 | { | |
229 | my($fk, $sk, $fv, $sv) = @_ ; | |
230 | return | |
231 | $fetch_key eq $fk && $store_key eq $sk && | |
232 | $fetch_value eq $fv && $store_value eq $sv && | |
233 | $_ eq 'original' ; | |
234 | } | |
235 | ||
236 | unlink <Op_dbmx*>; | |
237 | ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; | |
238 | ||
239 | $db->filter_fetch_key (sub { $fetch_key = $_ }) ; | |
240 | $db->filter_store_key (sub { $store_key = $_ }) ; | |
241 | $db->filter_fetch_value (sub { $fetch_value = $_}) ; | |
242 | $db->filter_store_value (sub { $store_value = $_ }) ; | |
243 | ||
244 | $_ = "original" ; | |
245 | ||
246 | $h{"fred"} = "joe" ; | |
247 | # fk sk fv sv | |
248 | ok(22, checkOutput( "", "fred", "", "joe")) ; | |
249 | ||
250 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
251 | ok(23, $h{"fred"} eq "joe"); | |
252 | # fk sk fv sv | |
253 | ok(24, checkOutput( "", "fred", "joe", "")) ; | |
254 | ||
255 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
256 | ok(25, $db->FIRSTKEY() eq "fred") ; | |
257 | # fk sk fv sv | |
258 | ok(26, checkOutput( "fred", "", "", "")) ; | |
259 | ||
260 | # replace the filters, but remember the previous set | |
261 | my ($old_fk) = $db->filter_fetch_key | |
262 | (sub { $_ = uc $_ ; $fetch_key = $_ }) ; | |
263 | my ($old_sk) = $db->filter_store_key | |
264 | (sub { $_ = lc $_ ; $store_key = $_ }) ; | |
265 | my ($old_fv) = $db->filter_fetch_value | |
266 | (sub { $_ = "[$_]"; $fetch_value = $_ }) ; | |
267 | my ($old_sv) = $db->filter_store_value | |
268 | (sub { s/o/x/g; $store_value = $_ }) ; | |
269 | ||
270 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
271 | $h{"Fred"} = "Joe" ; | |
272 | # fk sk fv sv | |
273 | ok(27, checkOutput( "", "fred", "", "Jxe")) ; | |
274 | ||
275 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
276 | ok(28, $h{"Fred"} eq "[Jxe]"); | |
277 | # fk sk fv sv | |
278 | ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; | |
279 | ||
280 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
281 | ok(30, $db->FIRSTKEY() eq "FRED") ; | |
282 | # fk sk fv sv | |
283 | ok(31, checkOutput( "FRED", "", "", "")) ; | |
284 | ||
285 | # put the original filters back | |
286 | $db->filter_fetch_key ($old_fk); | |
287 | $db->filter_store_key ($old_sk); | |
288 | $db->filter_fetch_value ($old_fv); | |
289 | $db->filter_store_value ($old_sv); | |
290 | ||
291 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
292 | $h{"fred"} = "joe" ; | |
293 | ok(32, checkOutput( "", "fred", "", "joe")) ; | |
294 | ||
295 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
296 | ok(33, $h{"fred"} eq "joe"); | |
297 | ok(34, checkOutput( "", "fred", "joe", "")) ; | |
298 | ||
299 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
300 | ok(35, $db->FIRSTKEY() eq "fred") ; | |
301 | ok(36, checkOutput( "fred", "", "", "")) ; | |
302 | ||
303 | # delete the filters | |
304 | $db->filter_fetch_key (undef); | |
305 | $db->filter_store_key (undef); | |
306 | $db->filter_fetch_value (undef); | |
307 | $db->filter_store_value (undef); | |
308 | ||
309 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
310 | $h{"fred"} = "joe" ; | |
311 | ok(37, checkOutput( "", "", "", "")) ; | |
312 | ||
313 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
314 | ok(38, $h{"fred"} eq "joe"); | |
315 | ok(39, checkOutput( "", "", "", "")) ; | |
316 | ||
317 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
318 | ok(40, $db->FIRSTKEY() eq "fred") ; | |
319 | ok(41, checkOutput( "", "", "", "")) ; | |
320 | ||
321 | undef $db ; | |
322 | untie %h; | |
323 | unlink <Op_dbmx*>; | |
324 | } | |
325 | ||
326 | { | |
327 | # DBM Filter with a closure | |
328 | ||
329 | use strict ; | |
698828ad | 330 | use warnings ; |
9fe6733a PM |
331 | my (%h, $db) ; |
332 | ||
333 | unlink <Op_dbmx*>; | |
334 | ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; | |
335 | ||
336 | my %result = () ; | |
337 | ||
338 | sub Closure | |
339 | { | |
340 | my ($name) = @_ ; | |
341 | my $count = 0 ; | |
342 | my @kept = () ; | |
343 | ||
344 | return sub { ++$count ; | |
345 | push @kept, $_ ; | |
346 | $result{$name} = "$name - $count: [@kept]" ; | |
347 | } | |
348 | } | |
349 | ||
350 | $db->filter_store_key(Closure("store key")) ; | |
351 | $db->filter_store_value(Closure("store value")) ; | |
352 | $db->filter_fetch_key(Closure("fetch key")) ; | |
353 | $db->filter_fetch_value(Closure("fetch value")) ; | |
354 | ||
355 | $_ = "original" ; | |
356 | ||
357 | $h{"fred"} = "joe" ; | |
358 | ok(43, $result{"store key"} eq "store key - 1: [fred]"); | |
359 | ok(44, $result{"store value"} eq "store value - 1: [joe]"); | |
360 | ok(45, !defined $result{"fetch key"} ); | |
361 | ok(46, !defined $result{"fetch value"} ); | |
362 | ok(47, $_ eq "original") ; | |
363 | ||
364 | ok(48, $db->FIRSTKEY() eq "fred") ; | |
365 | ok(49, $result{"store key"} eq "store key - 1: [fred]"); | |
366 | ok(50, $result{"store value"} eq "store value - 1: [joe]"); | |
367 | ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); | |
368 | ok(52, ! defined $result{"fetch value"} ); | |
369 | ok(53, $_ eq "original") ; | |
370 | ||
371 | $h{"jim"} = "john" ; | |
372 | ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); | |
373 | ok(55, $result{"store value"} eq "store value - 2: [joe john]"); | |
374 | ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); | |
698828ad | 375 | ok(57, ! defined $result{"fetch value"} ); |
9fe6733a PM |
376 | ok(58, $_ eq "original") ; |
377 | ||
378 | ok(59, $h{"fred"} eq "joe"); | |
379 | ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); | |
380 | ok(61, $result{"store value"} eq "store value - 2: [joe john]"); | |
381 | ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); | |
382 | ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); | |
383 | ok(64, $_ eq "original") ; | |
384 | ||
385 | undef $db ; | |
386 | untie %h; | |
387 | unlink <Op_dbmx*>; | |
388 | } | |
389 | ||
390 | { | |
391 | # DBM Filter recursion detection | |
392 | use strict ; | |
698828ad | 393 | use warnings ; |
9fe6733a PM |
394 | my (%h, $db) ; |
395 | unlink <Op_dbmx*>; | |
396 | ||
397 | ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; | |
398 | ||
399 | $db->filter_store_key (sub { $_ = $h{$_} }) ; | |
400 | ||
401 | eval '$h{1} = 1234' ; | |
402 | ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); | |
403 | ||
404 | undef $db ; | |
405 | untie %h; | |
406 | unlink <Op_dbmx*>; | |
f4b9d880 | 407 | } |
9fe6733a | 408 | |
cbc5248d PM |
409 | { |
410 | # Bug ID 20001013.009 | |
411 | # | |
412 | # test that $hash{KEY} = undef doesn't produce the warning | |
413 | # Use of uninitialized value in null operation | |
414 | use warnings ; | |
415 | use strict ; | |
416 | use SDBM_File ; | |
417 | ||
418 | unlink <Op_dbmx*>; | |
419 | my %h ; | |
420 | my $a = ""; | |
421 | local $SIG{__WARN__} = sub {$a = $_[0]} ; | |
422 | ||
423 | ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; | |
424 | $h{ABC} = undef; | |
425 | ok(68, $a eq "") ; | |
426 | ||
427 | untie %h; | |
428 | unlink <Op_dbmx*>; | |
429 | } | |
0bf2e707 PM |
430 | |
431 | { | |
432 | # When iterating over a tied hash using "each", the key passed to FETCH | |
433 | # will be recycled and passed to NEXTKEY. If a Source Filter modifies the | |
434 | # key in FETCH via a filter_fetch_key method we need to check that the | |
435 | # modified key doesn't get passed to NEXTKEY. | |
436 | # Also Test "keys" & "values" while we are at it. | |
437 | ||
438 | use warnings ; | |
439 | use strict ; | |
440 | use SDBM_File ; | |
441 | ||
442 | unlink <Op.dbmx*>; | |
443 | my $bad_key = 0 ; | |
444 | my %h = () ; | |
445 | ok(69, my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; | |
446 | $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; | |
447 | $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; | |
448 | ||
449 | $h{'Alpha_ABC'} = 2 ; | |
450 | $h{'Alpha_DEF'} = 5 ; | |
451 | ||
452 | ok(70, $h{'Alpha_ABC'} == 2); | |
453 | ok(71, $h{'Alpha_DEF'} == 5); | |
454 | ||
455 | my ($k, $v) = ("",""); | |
456 | while (($k, $v) = each %h) {} | |
457 | ok(72, $bad_key == 0); | |
458 | ||
459 | $bad_key = 0 ; | |
460 | foreach $k (keys %h) {} | |
461 | ok(73, $bad_key == 0); | |
462 | ||
463 | $bad_key = 0 ; | |
464 | foreach $v (values %h) {} | |
465 | ok(74, $bad_key == 0); | |
466 | ||
467 | undef $db ; | |
468 | untie %h ; | |
469 | unlink <Op.dbmx*>; | |
470 | } | |
471 | ||
472 | exit ; |