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