This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate change #12559 from maintperl;
[perl5.git] / ext / SDBM_File / sdbm.t
CommitLineData
a687059c
LW
1#!./perl
2
79072805 3# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
a687059c 4
85e6fe83 5BEGIN {
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
15use strict;
16use warnings;
17
18sub ok
19{
20 my $no = shift ;
21 my $result = shift ;
22
23 print "not " unless $result ;
24 print "ok $no\n" ;
25}
26
8990e307 27require SDBM_File;
a0d0e21e
LW
28#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
29use Fcntl;
a687059c 30
cbc5248d 31print "1..68\n";
a687059c 32
bf99883d 33unlink <Op_dbmx.*>;
79072805 34
a687059c 35umask(0);
698828ad
JH
36my %h ;
37ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640);
79072805 38
698828ad 39my $Dfile = "Op_dbmx.pag";
79072805 40if (! -e $Dfile) {
bf99883d 41 ($Dfile) = <Op_dbmx.*>;
79072805 42}
cd4b52c2 43if ($^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}
46else {
698828ad 47 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
544a3566
CS
48 $blksize,$blocks) = stat($Dfile);
49 print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
50}
698828ad
JH
51my $i = 0;
52while (my ($key,$value) = each(%h)) {
a687059c
LW
53 $i++;
54}
55print (!$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';
74delete $h{'goner2'};
75
463ee0b2 76untie(%h);
698828ad 77print (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
99delete $h{'goner1'};
100delete $h{'goner3'};
101
698828ad
JH
102my @keys = keys(%h);
103my @values = values(%h);
a687059c
LW
104
105if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
106
698828ad 107while (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
114if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
115
c6aa4a32 116@keys = ('blurfl', keys(%h), 'dyick');
a687059c
LW
117if ($#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 123my $ok = 1;
a687059c
LW
124for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
125for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
126print ($ok ? "ok 8\n" : "not ok 8\n");
127
698828ad 128my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
79072805 129 $blksize,$blocks) = stat($Dfile);
a687059c
LW
130print ($size > 0 ? "ok 9\n" : "not ok 9\n");
131
0f85fab0 132@h{0..200} = 200..400;
698828ad 133my @foo = @h{0..200};
fe14fcc3
LW
134print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
135
136print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
137print ($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 ;
184EOM
185
186 close FILE ;
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
214ok(19, !exists $h{'goner1'});
215ok(20, exists $h{'foo'});
216
217untie %h;
9fe6733a
PM
218unlink <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}