Commit | Line | Data |
---|---|---|
f7326ddc NC |
1 | #!perl |
2 | BEGIN { | |
3 | } | |
4 | ||
5 | use strict; | |
6 | use warnings; | |
7 | ||
8 | use Test::More; | |
9 | use Config; | |
10 | ||
11 | our $DBM_Class; | |
12 | ||
13 | my ($create, $write); | |
14 | BEGIN { | |
15 | plan(skip_all => "$DBM_Class was not built") | |
16 | unless $Config{extensions} =~ /\b$DBM_Class\b/; | |
17 | plan(skip_all => "$DBM_Class not compatible with C++") | |
18 | if $DBM_Class eq 'ODBM_File' && $Config{d_cplusplus}; | |
19 | ||
20 | use_ok($DBM_Class); | |
21 | ||
22 | if ($::Create_and_Write) { | |
23 | ($create, $write) = eval $::Create_and_Write; | |
24 | isnt($create, undef, "(eval q{$::Create_and_Write})[0]"); | |
25 | isnt($write, undef, "(eval q{$::Create_and_Write})[1]"); | |
26 | } else { | |
27 | #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT | |
28 | use_ok('Fcntl'); | |
29 | $create = O_RDWR()|O_CREAT(); | |
30 | $write = O_RDWR(); | |
31 | } | |
32 | } | |
33 | ||
34 | unlink <Op_dbmx.*>; | |
35 | ||
36 | umask(0); | |
37 | my %h; | |
38 | isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class); | |
39 | ||
40 | my $Dfile = "Op_dbmx.pag"; | |
41 | if (! -e $Dfile) { | |
42 | ($Dfile) = <Op_dbmx*>; | |
43 | } | |
44 | SKIP: { | |
45 | skip "different file permission semantics on $^O", 1 | |
f6dacdca | 46 | if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || $^O eq 'vos'; |
f7326ddc NC |
47 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, |
48 | $blksize,$blocks) = stat($Dfile); | |
49 | is($mode & 0777, 0640); | |
50 | } | |
51 | my $i = 0; | |
52 | while (my ($key,$value) = each(%h)) { | |
53 | $i++; | |
54 | } | |
55 | is($i, 0); | |
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 | ||
76 | untie(%h); | |
77 | isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $write, 0640), $DBM_Class); | |
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 | ||
102 | my @keys = keys(%h); | |
103 | my @values = values(%h); | |
104 | ||
105 | is($#keys, 29); | |
106 | is($#values, 29); | |
107 | ||
108 | while (my ($key, $value) = each(%h)) { | |
109 | if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { | |
110 | $key =~ y/a-z/A-Z/; | |
111 | $i++ if $key eq $value; | |
112 | } | |
113 | } | |
114 | ||
115 | is($i, 30); | |
116 | ||
117 | @keys = ('blurfl', keys(%h), 'dyick'); | |
118 | is($#keys, 31); | |
119 | ||
120 | $h{'foo'} = ''; | |
121 | $h{''} = 'bar'; | |
122 | ||
123 | my $ok = 1; | |
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 | is($ok, 1, 'check cache overflow and numeric keys and contents'); | |
127 | ||
128 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, | |
129 | $blksize,$blocks) = stat($Dfile); | |
130 | cmp_ok($size, '>', 0); | |
131 | ||
132 | @h{0..200} = 200..400; | |
133 | my @foo = @h{0..200}; | |
134 | is(join(':',200..400), join(':',@foo)); | |
135 | ||
136 | is($h{'foo'}, ''); | |
137 | is($h{''}, 'bar'); | |
138 | ||
139 | if($DBM_Class eq 'SDBM_File') { | |
140 | is(exists $h{goner1}, ''); | |
141 | is(exists $h{foo}, 1); | |
142 | } | |
143 | ||
144 | untie %h; | |
145 | unlink <Op_dbmx*>, $Dfile; | |
146 | ||
147 | { | |
148 | # sub-class test | |
149 | ||
150 | package Another; | |
151 | ||
152 | open my $file, '>', 'SubDB.pm' or die "Cannot open SubDB.pm: $!\n"; | |
153 | printf $file <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class; | |
154 | ||
155 | package SubDB; | |
156 | ||
157 | use strict; | |
158 | use warnings; | |
159 | use vars qw(@ISA @EXPORT); | |
160 | ||
161 | require Exporter; | |
162 | use %s; | |
163 | @ISA=qw(%s); | |
164 | @EXPORT = @%s::EXPORT; | |
165 | ||
166 | sub STORE { | |
167 | my $self = shift; | |
168 | my $key = shift; | |
169 | my $value = shift; | |
170 | $self->SUPER::STORE($key, $value * 2); | |
171 | } | |
172 | ||
173 | sub FETCH { | |
174 | my $self = shift; | |
175 | my $key = shift; | |
176 | $self->SUPER::FETCH($key) - 1; | |
177 | } | |
178 | ||
179 | sub A_new_method | |
180 | { | |
181 | my $self = shift; | |
182 | my $key = shift; | |
183 | my $value = $self->FETCH($key); | |
184 | return "[[$value]]"; | |
185 | } | |
186 | ||
187 | 1; | |
188 | EOM | |
189 | ||
190 | close $file or die "Could not close: $!"; | |
191 | ||
192 | BEGIN { push @INC, '.'; } | |
193 | unlink <dbhash_tmp*>; | |
194 | ||
195 | main::use_ok('SubDB'); | |
196 | my %h; | |
197 | my $X; | |
198 | eval ' | |
199 | $X = tie(%h, "SubDB", "dbhash_tmp", $create, 0640 ); | |
200 | '; | |
201 | ||
202 | main::is($@, ""); | |
203 | ||
204 | my $ret = eval '$h{"fred"} = 3; return $h{"fred"} '; | |
205 | main::is($@, ""); | |
206 | main::is($ret, 5); | |
207 | ||
208 | $ret = eval '$X->A_new_method("fred") '; | |
209 | main::is($@, ""); | |
210 | main::is($ret, "[[5]]"); | |
211 | ||
212 | if ($DBM_Class eq 'GDBM_File') { | |
213 | $ret = eval 'GDBM_WRCREAT eq main::GDBM_WRCREAT'; | |
214 | main::is($@, ""); | |
215 | main::is($ret, 1); | |
216 | } | |
217 | ||
218 | undef $X; | |
219 | untie(%h); | |
daf3e43a | 220 | unlink "SubDB.pm", <dbhash_tmp*>; |
f7326ddc NC |
221 | |
222 | } | |
223 | ||
224 | untie %h; | |
225 | unlink <Op_dbmx*>, $Dfile; | |
226 | ||
227 | { | |
228 | # DBM Filter tests | |
229 | my (%h, $db); | |
230 | my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
231 | ||
232 | sub checkOutput | |
233 | { | |
234 | my($fk, $sk, $fv, $sv) = @_; | |
38294c45 NC |
235 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
236 | is($fetch_key, $fk); | |
237 | is($store_key, $sk); | |
238 | is($fetch_value, $fv); | |
239 | is($store_value, $sv); | |
240 | is($_, 'original'); | |
f7326ddc NC |
241 | } |
242 | ||
243 | unlink <Op_dbmx*>; | |
244 | $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; | |
245 | isa_ok($db, $DBM_Class); | |
246 | ||
247 | $db->filter_fetch_key (sub { $fetch_key = $_ }); | |
248 | $db->filter_store_key (sub { $store_key = $_ }); | |
249 | $db->filter_fetch_value (sub { $fetch_value = $_}); | |
250 | $db->filter_store_value (sub { $store_value = $_ }); | |
251 | ||
252 | $_ = "original"; | |
253 | ||
254 | $h{"fred"} = "joe"; | |
255 | # fk sk fv sv | |
38294c45 | 256 | checkOutput("", "fred", "", "joe"); |
f7326ddc NC |
257 | |
258 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
259 | is($h{"fred"}, "joe"); | |
260 | # fk sk fv sv | |
38294c45 | 261 | checkOutput("", "fred", "joe", ""); |
f7326ddc NC |
262 | |
263 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
264 | is($db->FIRSTKEY(), "fred"); | |
265 | # fk sk fv sv | |
38294c45 | 266 | checkOutput("fred", "", "", ""); |
f7326ddc NC |
267 | |
268 | # replace the filters, but remember the previous set | |
269 | my ($old_fk) = $db->filter_fetch_key | |
270 | (sub { $_ = uc $_; $fetch_key = $_ }); | |
271 | my ($old_sk) = $db->filter_store_key | |
272 | (sub { $_ = lc $_; $store_key = $_ }); | |
273 | my ($old_fv) = $db->filter_fetch_value | |
274 | (sub { $_ = "[$_]"; $fetch_value = $_ }); | |
275 | my ($old_sv) = $db->filter_store_value | |
276 | (sub { s/o/x/g; $store_value = $_ }); | |
277 | ||
278 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
279 | $h{"Fred"} = "Joe"; | |
280 | # fk sk fv sv | |
38294c45 | 281 | checkOutput("", "fred", "", "Jxe"); |
f7326ddc NC |
282 | |
283 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
284 | is($h{"Fred"}, "[Jxe]"); | |
285 | # fk sk fv sv | |
38294c45 | 286 | checkOutput("", "fred", "[Jxe]", ""); |
f7326ddc NC |
287 | |
288 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
289 | is($db->FIRSTKEY(), "FRED"); | |
290 | # fk sk fv sv | |
38294c45 | 291 | checkOutput("FRED", "", "", ""); |
f7326ddc NC |
292 | |
293 | # put the original filters back | |
294 | $db->filter_fetch_key ($old_fk); | |
295 | $db->filter_store_key ($old_sk); | |
296 | $db->filter_fetch_value ($old_fv); | |
297 | $db->filter_store_value ($old_sv); | |
298 | ||
299 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
300 | $h{"fred"} = "joe"; | |
38294c45 | 301 | checkOutput("", "fred", "", "joe"); |
f7326ddc NC |
302 | |
303 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
304 | is($h{"fred"}, "joe"); | |
38294c45 | 305 | checkOutput("", "fred", "joe", ""); |
f7326ddc NC |
306 | |
307 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
308 | is($db->FIRSTKEY(), "fred"); | |
38294c45 | 309 | checkOutput("fred", "", "", ""); |
f7326ddc NC |
310 | |
311 | # delete the filters | |
312 | $db->filter_fetch_key (undef); | |
313 | $db->filter_store_key (undef); | |
314 | $db->filter_fetch_value (undef); | |
315 | $db->filter_store_value (undef); | |
316 | ||
317 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
318 | $h{"fred"} = "joe"; | |
38294c45 | 319 | checkOutput("", "", "", ""); |
f7326ddc NC |
320 | |
321 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
322 | is($h{"fred"}, "joe"); | |
38294c45 | 323 | checkOutput("", "", "", ""); |
f7326ddc NC |
324 | |
325 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4; | |
326 | is($db->FIRSTKEY(), "fred"); | |
38294c45 | 327 | checkOutput("", "", "", ""); |
f7326ddc NC |
328 | |
329 | undef $db; | |
330 | untie %h; | |
331 | unlink <Op_dbmx*>; | |
332 | } | |
333 | ||
334 | { | |
335 | # DBM Filter with a closure | |
336 | ||
337 | my (%h, $db); | |
338 | ||
339 | unlink <Op_dbmx*>; | |
340 | $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; | |
341 | isa_ok($db, $DBM_Class); | |
342 | ||
343 | my %result = (); | |
344 | ||
345 | sub Closure | |
346 | { | |
347 | my ($name) = @_; | |
348 | my $count = 0; | |
349 | my @kept = (); | |
350 | ||
351 | return sub { ++$count; | |
352 | push @kept, $_; | |
353 | $result{$name} = "$name - $count: [@kept]"; | |
354 | } | |
355 | } | |
356 | ||
357 | $db->filter_store_key(Closure("store key")); | |
358 | $db->filter_store_value(Closure("store value")); | |
359 | $db->filter_fetch_key(Closure("fetch key")); | |
360 | $db->filter_fetch_value(Closure("fetch value")); | |
361 | ||
362 | $_ = "original"; | |
363 | ||
364 | $h{"fred"} = "joe"; | |
365 | is($result{"store key"}, "store key - 1: [fred]"); | |
366 | is($result{"store value"}, "store value - 1: [joe]"); | |
367 | is($result{"fetch key"}, undef); | |
368 | is($result{"fetch value"}, undef); | |
369 | is($_, "original"); | |
370 | ||
371 | is($db->FIRSTKEY(), "fred"); | |
372 | is($result{"store key"}, "store key - 1: [fred]"); | |
373 | is($result{"store value"}, "store value - 1: [joe]"); | |
374 | is($result{"fetch key"}, "fetch key - 1: [fred]"); | |
375 | is($result{"fetch value"}, undef); | |
376 | is($_, "original"); | |
377 | ||
378 | $h{"jim"} = "john"; | |
379 | is($result{"store key"}, "store key - 2: [fred jim]"); | |
380 | is($result{"store value"}, "store value - 2: [joe john]"); | |
381 | is($result{"fetch key"}, "fetch key - 1: [fred]"); | |
382 | is($result{"fetch value"}, undef); | |
383 | is($_, "original"); | |
384 | ||
385 | is($h{"fred"}, "joe"); | |
386 | is($result{"store key"}, "store key - 3: [fred jim fred]"); | |
387 | is($result{"store value"}, "store value - 2: [joe john]"); | |
388 | is($result{"fetch key"}, "fetch key - 1: [fred]"); | |
389 | is($result{"fetch value"}, "fetch value - 1: [joe]"); | |
390 | is($_, "original"); | |
391 | ||
392 | undef $db; | |
393 | untie %h; | |
394 | unlink <Op_dbmx*>; | |
395 | } | |
396 | ||
397 | { | |
398 | # DBM Filter recursion detection | |
399 | my (%h, $db); | |
400 | unlink <Op_dbmx*>; | |
401 | ||
402 | $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; | |
403 | isa_ok($db, $DBM_Class); | |
404 | ||
405 | $db->filter_store_key (sub { $_ = $h{$_} }); | |
406 | ||
407 | eval '$h{1} = 1234'; | |
408 | like($@, qr/^recursion detected in filter_store_key at/); | |
409 | ||
410 | undef $db; | |
411 | untie %h; | |
412 | unlink <Op_dbmx*>; | |
413 | } | |
414 | ||
415 | { | |
416 | # Bug ID 20001013.009 | |
417 | # | |
418 | # test that $hash{KEY} = undef doesn't produce the warning | |
419 | # Use of uninitialized value in null operation | |
420 | ||
421 | unlink <Op_dbmx*>; | |
422 | my %h; | |
423 | my $a = ""; | |
424 | local $SIG{__WARN__} = sub {$a = $_[0]}; | |
425 | ||
426 | isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class); | |
427 | $h{ABC} = undef; | |
428 | is($a, ""); | |
429 | untie %h; | |
430 | unlink <Op_dbmx*>; | |
431 | } | |
432 | ||
433 | { | |
434 | # When iterating over a tied hash using "each", the key passed to FETCH | |
435 | # will be recycled and passed to NEXTKEY. If a Source Filter modifies the | |
436 | # key in FETCH via a filter_fetch_key method we need to check that the | |
437 | # modified key doesn't get passed to NEXTKEY. | |
438 | # Also Test "keys" & "values" while we are at it. | |
439 | ||
440 | unlink <Op_dbmx*>; | |
441 | my $bad_key = 0; | |
442 | my %h = (); | |
443 | my $db = tie %h, $DBM_Class, 'Op_dbmx', $create, 0640; | |
444 | isa_ok($db, $DBM_Class); | |
445 | $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}); | |
446 | $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/; $_ =~ s/^Alpha_/Beta_/}); | |
447 | ||
448 | $h{'Alpha_ABC'} = 2; | |
449 | $h{'Alpha_DEF'} = 5; | |
450 | ||
451 | is($h{'Alpha_ABC'}, 2); | |
452 | is($h{'Alpha_DEF'}, 5); | |
453 | ||
454 | my ($k, $v) = ("", ""); | |
455 | while (($k, $v) = each %h) {} | |
456 | is($bad_key, 0); | |
457 | ||
458 | $bad_key = 0; | |
459 | foreach $k (keys %h) {} | |
460 | is($bad_key, 0); | |
461 | ||
462 | $bad_key = 0; | |
463 | foreach $v (values %h) {} | |
464 | is($bad_key, 0); | |
465 | ||
466 | undef $db; | |
467 | untie %h; | |
468 | unlink <Op_dbmx*>; | |
469 | } | |
470 | ||
471 | { | |
472 | # Check that DBM Filter can cope with read-only $_ | |
473 | ||
474 | my %h; | |
475 | unlink <Op1_dbmx*>; | |
476 | ||
477 | my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640; | |
478 | isa_ok($db, $DBM_Class); | |
479 | ||
480 | $db->filter_fetch_key (sub { }); | |
481 | $db->filter_store_key (sub { }); | |
482 | $db->filter_fetch_value (sub { }); | |
483 | $db->filter_store_value (sub { }); | |
484 | ||
485 | $_ = "original"; | |
486 | ||
487 | $h{"fred"} = "joe"; | |
488 | is($h{"fred"}, "joe"); | |
489 | ||
490 | is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]); | |
491 | is($@, ''); | |
492 | ||
493 | ||
494 | # delete the filters | |
495 | $db->filter_fetch_key (undef); | |
496 | $db->filter_store_key (undef); | |
497 | $db->filter_fetch_value (undef); | |
498 | $db->filter_store_value (undef); | |
499 | ||
500 | $h{"fred"} = "joe"; | |
501 | ||
502 | is($h{"fred"}, "joe"); | |
503 | ||
504 | is($db->FIRSTKEY(), "fred"); | |
505 | ||
506 | is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]); | |
507 | is($@, ''); | |
508 | ||
509 | undef $db; | |
510 | untie %h; | |
511 | unlink <Op1_dbmx*>; | |
512 | } | |
513 | ||
514 | done_testing(); | |
515 | 1; |