Commit | Line | Data |
f6b705ef |
1 | #!./perl -w |
77fd2717 |
2 | |
bb50757b |
3 | use warnings; |
4 | use strict; |
77fd2717 |
5 | use Config; |
6 | |
a0d0e21e |
7 | BEGIN { |
2adbc9b6 |
8 | if($ENV{PERL_CORE}) { |
77fd2717 |
9 | if ($Config{'extensions'} !~ /\bDB_File\b/ ) { |
46ca028d |
10 | print "1..0 # Skip: DB_File was not built\n"; |
77fd2717 |
11 | exit 0; |
12 | } |
a0d0e21e |
13 | } |
14 | } |
15 | |
16 | use DB_File; |
17 | use Fcntl; |
07200f1b |
18 | our ($dbh, $Dfile, $bad_ones, $FA); |
045291aa |
19 | |
20 | # full tied array support started in Perl 5.004_57 |
a9fd575d |
21 | # Double check to see if it is available. |
22 | |
23 | { |
24 | sub try::TIEARRAY { bless [], "try" } |
25 | sub try::FETCHSIZE { $FA = 1 } |
26 | $FA = 0 ; |
27 | my @a ; |
28 | tie @a, 'try' ; |
29 | my $a = @a ; |
30 | } |
31 | |
a0d0e21e |
32 | |
55d68b4a |
33 | sub ok |
34 | { |
35 | my $no = shift ; |
36 | my $result = shift ; |
a0d0e21e |
37 | |
55d68b4a |
38 | print "not " unless $result ; |
39 | print "ok $no\n" ; |
6250ba0a |
40 | |
41 | return $result ; |
42 | } |
43 | |
9b761c68 |
44 | { |
45 | package Redirect ; |
46 | use Symbol ; |
47 | |
48 | sub new |
49 | { |
50 | my $class = shift ; |
51 | my $filename = shift ; |
52 | my $fh = gensym ; |
53 | open ($fh, ">$filename") || die "Cannot open $filename: $!" ; |
54 | my $real_stdout = select($fh) ; |
55 | return bless [$fh, $real_stdout ] ; |
56 | |
57 | } |
58 | sub DESTROY |
59 | { |
60 | my $self = shift ; |
61 | close $self->[0] ; |
62 | select($self->[1]) ; |
63 | } |
64 | } |
65 | |
66 | sub docat |
67 | { |
68 | my $file = shift; |
69 | local $/ = undef; |
70 | open(CAT,$file) || die "Cannot open $file:$!"; |
71 | my $result = <CAT>; |
72 | close(CAT); |
77fd2717 |
73 | normalise($result) ; |
9b761c68 |
74 | return $result; |
75 | } |
76 | |
77 | sub docat_del |
78 | { |
79 | my $file = shift; |
77fd2717 |
80 | my $result = docat($file); |
9b761c68 |
81 | unlink $file ; |
82 | return $result; |
83 | } |
84 | |
efc79c7d |
85 | sub safeUntie |
86 | { |
87 | my $hashref = shift ; |
88 | my $no_inner = 1; |
89 | local $SIG{__WARN__} = sub {-- $no_inner } ; |
90 | untie @$hashref; |
91 | return $no_inner; |
92 | } |
93 | |
6250ba0a |
94 | sub bad_one |
95 | { |
3ebf0137 |
96 | unless ($bad_ones++) { |
97 | print STDERR <<EOM ; |
25268f15 |
98 | # |
3ebf0137 |
99 | # Some older versions of Berkeley DB version 1 will fail db-recno |
6d02d21f |
100 | # tests 61, 63, 64 and 65. |
3ebf0137 |
101 | EOM |
2f41957b |
102 | if ($^O eq 'darwin' |
103 | && $Config{db_version_major} == 1 |
104 | && $Config{db_version_minor} == 0 |
105 | && $Config{db_version_patch} == 0) { |
106 | print STDERR <<EOM ; |
3ebf0137 |
107 | # |
0b9ee88a |
108 | # For example Mac OS X 10.2 (or earlier) has such an old |
2f41957b |
109 | # version of Berkeley DB. |
3ebf0137 |
110 | EOM |
111 | } |
112 | |
113 | print STDERR <<EOM ; |
6250ba0a |
114 | # |
115 | # You can safely ignore the errors if you're never going to use the |
116 | # broken functionality (recno databases with a modified bval). |
117 | # Otherwise you'll have to upgrade your DB library. |
118 | # |
20896112 |
119 | # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the |
120 | # last versions that were released. Berkeley DB version 2 is continually |
121 | # being updated -- Check out http://www.sleepycat.com/ for more details. |
6250ba0a |
122 | # |
123 | EOM |
3ebf0137 |
124 | } |
55d68b4a |
125 | } |
126 | |
77fd2717 |
127 | sub normalise |
128 | { |
129 | return unless $^O eq 'cygwin' ; |
130 | foreach (@_) |
131 | { s#\r\n#\n#g } |
132 | } |
133 | |
134 | BEGIN |
135 | { |
136 | { |
137 | local $SIG{__DIE__} ; |
138 | eval { require Data::Dumper ; import Data::Dumper } ; |
139 | } |
140 | |
141 | if ($@) { |
142 | *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ; |
143 | } |
144 | } |
145 | |
efc79c7d |
146 | my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms |
9c095db2 |
147 | my $total_tests = 181 ; |
c6c92ad9 |
148 | $total_tests += $splice_tests if $FA ; |
149 | print "1..$total_tests\n"; |
55d68b4a |
150 | |
07200f1b |
151 | $Dfile = "recno.tmp"; |
55d68b4a |
152 | unlink $Dfile ; |
a0d0e21e |
153 | |
154 | umask(0); |
155 | |
156 | # Check the interface to RECNOINFO |
157 | |
07200f1b |
158 | $dbh = new DB_File::RECNOINFO ; |
3fe9a6f1 |
159 | ok(1, ! defined $dbh->{bval}) ; |
160 | ok(2, ! defined $dbh->{cachesize}) ; |
161 | ok(3, ! defined $dbh->{psize}) ; |
162 | ok(4, ! defined $dbh->{flags}) ; |
163 | ok(5, ! defined $dbh->{lorder}) ; |
164 | ok(6, ! defined $dbh->{reclen}) ; |
165 | ok(7, ! defined $dbh->{bfname}) ; |
a0d0e21e |
166 | |
167 | $dbh->{bval} = 3000 ; |
f6b705ef |
168 | ok(8, $dbh->{bval} == 3000 ); |
a0d0e21e |
169 | |
170 | $dbh->{cachesize} = 9000 ; |
f6b705ef |
171 | ok(9, $dbh->{cachesize} == 9000 ); |
a0d0e21e |
172 | |
173 | $dbh->{psize} = 400 ; |
f6b705ef |
174 | ok(10, $dbh->{psize} == 400 ); |
a0d0e21e |
175 | |
176 | $dbh->{flags} = 65 ; |
f6b705ef |
177 | ok(11, $dbh->{flags} == 65 ); |
a0d0e21e |
178 | |
179 | $dbh->{lorder} = 123 ; |
f6b705ef |
180 | ok(12, $dbh->{lorder} == 123 ); |
a0d0e21e |
181 | |
182 | $dbh->{reclen} = 1234 ; |
f6b705ef |
183 | ok(13, $dbh->{reclen} == 1234 ); |
a0d0e21e |
184 | |
185 | $dbh->{bfname} = 1234 ; |
f6b705ef |
186 | ok(14, $dbh->{bfname} == 1234 ); |
a0d0e21e |
187 | |
188 | |
189 | # Check that an invalid entry is caught both for store & fetch |
190 | eval '$dbh->{fred} = 1234' ; |
f6b705ef |
191 | ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); |
55d68b4a |
192 | eval 'my $q = $dbh->{fred}' ; |
f6b705ef |
193 | ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); |
a0d0e21e |
194 | |
195 | # Now check the interface to RECNOINFO |
196 | |
55d68b4a |
197 | my $X ; |
198 | my @h ; |
199 | ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; |
a0d0e21e |
200 | |
77fd2717 |
201 | my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; |
202 | |
d536870a |
203 | ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) |
77fd2717 |
204 | || $noMode{$^O} ); |
a0d0e21e |
205 | |
55d68b4a |
206 | #my $l = @h ; |
207 | my $l = $X->length ; |
045291aa |
208 | ok(19, ($FA ? @h == 0 : !$l) ); |
a0d0e21e |
209 | |
55d68b4a |
210 | my @data = qw( a b c d ever f g h i j k longername m n o p) ; |
a0d0e21e |
211 | |
212 | $h[0] = shift @data ; |
f6b705ef |
213 | ok(20, $h[0] eq 'a' ); |
a0d0e21e |
214 | |
55d68b4a |
215 | my $ i; |
a0d0e21e |
216 | foreach (@data) |
217 | { $h[++$i] = $_ } |
218 | |
219 | unshift (@data, 'a') ; |
220 | |
f6b705ef |
221 | ok(21, defined $h[1] ); |
222 | ok(22, ! defined $h[16] ); |
045291aa |
223 | ok(23, $FA ? @h == @data : $X->length == @data ); |
a0d0e21e |
224 | |
225 | |
226 | # Overwrite an entry & check fetch it |
227 | $h[3] = 'replaced' ; |
228 | $data[3] = 'replaced' ; |
f6b705ef |
229 | ok(24, $h[3] eq 'replaced' ); |
a0d0e21e |
230 | |
231 | #PUSH |
55d68b4a |
232 | my @push_data = qw(added to the end) ; |
045291aa |
233 | ($FA ? push(@h, @push_data) : $X->push(@push_data)) ; |
a0d0e21e |
234 | push (@data, @push_data) ; |
f6b705ef |
235 | ok(25, $h[++$i] eq 'added' ); |
236 | ok(26, $h[++$i] eq 'to' ); |
237 | ok(27, $h[++$i] eq 'the' ); |
238 | ok(28, $h[++$i] eq 'end' ); |
a0d0e21e |
239 | |
240 | # POP |
f6b705ef |
241 | my $popped = pop (@data) ; |
045291aa |
242 | my $value = ($FA ? pop @h : $X->pop) ; |
f6b705ef |
243 | ok(29, $value eq $popped) ; |
a0d0e21e |
244 | |
245 | # SHIFT |
045291aa |
246 | $value = ($FA ? shift @h : $X->shift) ; |
f6b705ef |
247 | my $shifted = shift @data ; |
248 | ok(30, $value eq $shifted ); |
a0d0e21e |
249 | |
250 | # UNSHIFT |
251 | |
252 | # empty list |
936edb8b |
253 | ($FA ? unshift @h,() : $X->unshift) ; |
045291aa |
254 | ok(31, ($FA ? @h == @data : $X->length == @data )); |
a0d0e21e |
255 | |
55d68b4a |
256 | my @new_data = qw(add this to the start of the array) ; |
045291aa |
257 | $FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; |
a0d0e21e |
258 | unshift (@data, @new_data) ; |
045291aa |
259 | ok(32, $FA ? @h == @data : $X->length == @data ); |
f6b705ef |
260 | ok(33, $h[0] eq "add") ; |
261 | ok(34, $h[1] eq "this") ; |
262 | ok(35, $h[2] eq "to") ; |
263 | ok(36, $h[3] eq "the") ; |
264 | ok(37, $h[4] eq "start") ; |
265 | ok(38, $h[5] eq "of") ; |
266 | ok(39, $h[6] eq "the") ; |
267 | ok(40, $h[7] eq "array") ; |
268 | ok(41, $h[8] eq $data[8]) ; |
a0d0e21e |
269 | |
c6c92ad9 |
270 | # Brief test for SPLICE - more thorough 'soak test' is later. |
271 | my @old; |
272 | if ($FA) { |
273 | @old = splice(@h, 1, 2, qw(bananas just before)); |
274 | } |
275 | else { |
276 | @old = $X->splice(1, 2, qw(bananas just before)); |
277 | } |
278 | ok(42, $h[0] eq "add") ; |
279 | ok(43, $h[1] eq "bananas") ; |
280 | ok(44, $h[2] eq "just") ; |
281 | ok(45, $h[3] eq "before") ; |
282 | ok(46, $h[4] eq "the") ; |
283 | ok(47, $h[5] eq "start") ; |
284 | ok(48, $h[6] eq "of") ; |
285 | ok(49, $h[7] eq "the") ; |
286 | ok(50, $h[8] eq "array") ; |
287 | ok(51, $h[9] eq $data[8]) ; |
288 | $FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old); |
a0d0e21e |
289 | |
290 | # Now both arrays should be identical |
291 | |
55d68b4a |
292 | my $ok = 1 ; |
293 | my $j = 0 ; |
a0d0e21e |
294 | foreach (@data) |
295 | { |
296 | $ok = 0, last if $_ ne $h[$j ++] ; |
297 | } |
c6c92ad9 |
298 | ok(52, $ok ); |
a0d0e21e |
299 | |
55d68b4a |
300 | # Neagtive subscripts |
301 | |
302 | # get the last element of the array |
c6c92ad9 |
303 | ok(53, $h[-1] eq $data[-1] ); |
304 | ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); |
55d68b4a |
305 | |
306 | # get the first element using a negative subscript |
045291aa |
307 | eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; |
c6c92ad9 |
308 | ok(55, $@ eq "" ); |
309 | ok(56, $h[0] eq "abcd" ); |
55d68b4a |
310 | |
311 | # now try to read before the start of the array |
045291aa |
312 | eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; |
c6c92ad9 |
313 | ok(57, $@ =~ '^Modification of non-creatable array value attempted' ); |
55d68b4a |
314 | |
a0d0e21e |
315 | # IMPORTANT - $X must be undefined before the untie otherwise the |
316 | # underlying DB close routine will not get called. |
317 | undef $X ; |
efc79c7d |
318 | ok(58, safeUntie \@h); |
a0d0e21e |
319 | |
320 | unlink $Dfile; |
321 | |
a6ed719b |
322 | |
36477c24 |
323 | { |
324 | # Check bval defaults to \n |
325 | |
326 | my @h = () ; |
327 | my $dbh = new DB_File::RECNOINFO ; |
efc79c7d |
328 | ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
36477c24 |
329 | $h[0] = "abc" ; |
330 | $h[1] = "def" ; |
331 | $h[3] = "ghi" ; |
efc79c7d |
332 | ok(60, safeUntie \@h); |
a6ed719b |
333 | my $x = docat($Dfile) ; |
36477c24 |
334 | unlink $Dfile; |
efc79c7d |
335 | ok(61, $x eq "abc\ndef\n\nghi\n") ; |
36477c24 |
336 | } |
337 | |
338 | { |
339 | # Change bval |
340 | |
341 | my @h = () ; |
342 | my $dbh = new DB_File::RECNOINFO ; |
343 | $dbh->{bval} = "-" ; |
efc79c7d |
344 | ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
36477c24 |
345 | $h[0] = "abc" ; |
346 | $h[1] = "def" ; |
347 | $h[3] = "ghi" ; |
efc79c7d |
348 | ok(63, safeUntie \@h); |
a6ed719b |
349 | my $x = docat($Dfile) ; |
36477c24 |
350 | unlink $Dfile; |
6250ba0a |
351 | my $ok = ($x eq "abc-def--ghi-") ; |
352 | bad_one() unless $ok ; |
efc79c7d |
353 | ok(64, $ok) ; |
36477c24 |
354 | } |
355 | |
356 | { |
357 | # Check R_FIXEDLEN with default bval (space) |
358 | |
359 | my @h = () ; |
360 | my $dbh = new DB_File::RECNOINFO ; |
361 | $dbh->{flags} = R_FIXEDLEN ; |
362 | $dbh->{reclen} = 5 ; |
efc79c7d |
363 | ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
36477c24 |
364 | $h[0] = "abc" ; |
365 | $h[1] = "def" ; |
366 | $h[3] = "ghi" ; |
efc79c7d |
367 | ok(66, safeUntie \@h); |
a6ed719b |
368 | my $x = docat($Dfile) ; |
36477c24 |
369 | unlink $Dfile; |
6250ba0a |
370 | my $ok = ($x eq "abc def ghi ") ; |
371 | bad_one() unless $ok ; |
efc79c7d |
372 | ok(67, $ok) ; |
36477c24 |
373 | } |
374 | |
375 | { |
376 | # Check R_FIXEDLEN with user-defined bval |
377 | |
378 | my @h = () ; |
379 | my $dbh = new DB_File::RECNOINFO ; |
380 | $dbh->{flags} = R_FIXEDLEN ; |
381 | $dbh->{bval} = "-" ; |
382 | $dbh->{reclen} = 5 ; |
efc79c7d |
383 | ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
36477c24 |
384 | $h[0] = "abc" ; |
385 | $h[1] = "def" ; |
386 | $h[3] = "ghi" ; |
efc79c7d |
387 | ok(69, safeUntie \@h); |
a6ed719b |
388 | my $x = docat($Dfile) ; |
36477c24 |
389 | unlink $Dfile; |
6250ba0a |
390 | my $ok = ($x eq "abc--def-------ghi--") ; |
391 | bad_one() unless $ok ; |
efc79c7d |
392 | ok(70, $ok) ; |
36477c24 |
393 | } |
394 | |
05475680 |
395 | { |
396 | # check that attempting to tie an associative array to a DB_RECNO will fail |
397 | |
398 | my $filename = "xyz" ; |
399 | my %x ; |
400 | eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; |
efc79c7d |
401 | ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; |
05475680 |
402 | unlink $filename ; |
403 | } |
404 | |
a6ed719b |
405 | { |
406 | # sub-class test |
407 | |
408 | package Another ; |
409 | |
3245f058 |
410 | use warnings ; |
a6ed719b |
411 | use strict ; |
412 | |
413 | open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; |
414 | print FILE <<'EOM' ; |
415 | |
416 | package SubDB ; |
417 | |
3245f058 |
418 | use warnings ; |
a6ed719b |
419 | use strict ; |
07200f1b |
420 | our (@ISA, @EXPORT); |
a6ed719b |
421 | |
422 | require Exporter ; |
423 | use DB_File; |
424 | @ISA=qw(DB_File); |
425 | @EXPORT = @DB_File::EXPORT ; |
426 | |
427 | sub STORE { |
428 | my $self = shift ; |
429 | my $key = shift ; |
430 | my $value = shift ; |
431 | $self->SUPER::STORE($key, $value * 2) ; |
432 | } |
433 | |
434 | sub FETCH { |
435 | my $self = shift ; |
436 | my $key = shift ; |
437 | $self->SUPER::FETCH($key) - 1 ; |
438 | } |
439 | |
440 | sub put { |
441 | my $self = shift ; |
442 | my $key = shift ; |
443 | my $value = shift ; |
444 | $self->SUPER::put($key, $value * 3) ; |
445 | } |
446 | |
447 | sub get { |
448 | my $self = shift ; |
449 | $self->SUPER::get($_[0], $_[1]) ; |
450 | $_[1] -= 2 ; |
451 | } |
452 | |
453 | sub A_new_method |
454 | { |
455 | my $self = shift ; |
456 | my $key = shift ; |
457 | my $value = $self->FETCH($key) ; |
458 | return "[[$value]]" ; |
459 | } |
460 | |
461 | 1 ; |
462 | EOM |
463 | |
05a54443 |
464 | close FILE or die "Could not close: $!"; |
a6ed719b |
465 | |
045291aa |
466 | BEGIN { push @INC, '.'; } |
a6ed719b |
467 | eval 'use SubDB ; '; |
efc79c7d |
468 | main::ok(72, $@ eq "") ; |
a6ed719b |
469 | my @h ; |
470 | my $X ; |
471 | eval ' |
472 | $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); |
473 | ' ; |
05a54443 |
474 | die "Could not tie: $!" unless $X; |
a6ed719b |
475 | |
efc79c7d |
476 | main::ok(73, $@ eq "") ; |
a6ed719b |
477 | |
478 | my $ret = eval '$h[3] = 3 ; return $h[3] ' ; |
efc79c7d |
479 | main::ok(74, $@ eq "") ; |
480 | main::ok(75, $ret == 5) ; |
a6ed719b |
481 | |
482 | my $value = 0; |
483 | $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; |
efc79c7d |
484 | main::ok(76, $@ eq "") ; |
485 | main::ok(77, $ret == 10) ; |
a6ed719b |
486 | |
487 | $ret = eval ' R_NEXT eq main::R_NEXT ' ; |
efc79c7d |
488 | main::ok(78, $@ eq "" ) ; |
489 | main::ok(79, $ret == 1) ; |
a6ed719b |
490 | |
491 | $ret = eval '$X->A_new_method(1) ' ; |
efc79c7d |
492 | main::ok(80, $@ eq "") ; |
493 | main::ok(81, $ret eq "[[11]]") ; |
a6ed719b |
494 | |
fac76ed7 |
495 | undef $X; |
efc79c7d |
496 | main::ok(82, main::safeUntie \@h); |
a6ed719b |
497 | unlink "SubDB.pm", "recno.tmp" ; |
498 | |
499 | } |
500 | |
045291aa |
501 | { |
502 | |
503 | # test $# |
504 | my $self ; |
505 | unlink $Dfile; |
efc79c7d |
506 | ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; |
045291aa |
507 | $h[0] = "abc" ; |
508 | $h[1] = "def" ; |
509 | $h[2] = "ghi" ; |
510 | $h[3] = "jkl" ; |
efc79c7d |
511 | ok(84, $FA ? $#h == 3 : $self->length() == 4) ; |
045291aa |
512 | undef $self ; |
efc79c7d |
513 | ok(85, safeUntie \@h); |
045291aa |
514 | my $x = docat($Dfile) ; |
efc79c7d |
515 | ok(86, $x eq "abc\ndef\nghi\njkl\n") ; |
045291aa |
516 | |
517 | # $# sets array to same length |
d6067fe3 |
518 | $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ; |
519 | ok(87, $self) |
520 | or warn "# $DB_File::Error\n"; |
045291aa |
521 | if ($FA) |
522 | { $#h = 3 } |
523 | else |
524 | { $self->STORESIZE(4) } |
efc79c7d |
525 | ok(88, $FA ? $#h == 3 : $self->length() == 4) ; |
045291aa |
526 | undef $self ; |
efc79c7d |
527 | ok(89, safeUntie \@h); |
045291aa |
528 | $x = docat($Dfile) ; |
efc79c7d |
529 | ok(90, $x eq "abc\ndef\nghi\njkl\n") ; |
045291aa |
530 | |
531 | # $# sets array to bigger |
efc79c7d |
532 | ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; |
045291aa |
533 | if ($FA) |
534 | { $#h = 6 } |
535 | else |
536 | { $self->STORESIZE(7) } |
efc79c7d |
537 | ok(92, $FA ? $#h == 6 : $self->length() == 7) ; |
045291aa |
538 | undef $self ; |
efc79c7d |
539 | ok(93, safeUntie \@h); |
045291aa |
540 | $x = docat($Dfile) ; |
efc79c7d |
541 | ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; |
045291aa |
542 | |
543 | # $# sets array smaller |
efc79c7d |
544 | ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; |
045291aa |
545 | if ($FA) |
546 | { $#h = 2 } |
547 | else |
548 | { $self->STORESIZE(3) } |
efc79c7d |
549 | ok(96, $FA ? $#h == 2 : $self->length() == 3) ; |
045291aa |
550 | undef $self ; |
efc79c7d |
551 | ok(97, safeUntie \@h); |
045291aa |
552 | $x = docat($Dfile) ; |
efc79c7d |
553 | ok(98, $x eq "abc\ndef\nghi\n") ; |
045291aa |
554 | |
555 | unlink $Dfile; |
556 | |
557 | |
558 | } |
559 | |
9fe6733a |
560 | { |
561 | # DBM Filter tests |
3245f058 |
562 | use warnings ; |
9fe6733a |
563 | use strict ; |
564 | my (@h, $db) ; |
565 | my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
566 | unlink $Dfile; |
567 | |
568 | sub checkOutput |
569 | { |
570 | my($fk, $sk, $fv, $sv) = @_ ; |
efc79c7d |
571 | |
572 | print "# Fetch Key : expected '$fk' got '$fetch_key'\n" |
573 | if $fetch_key ne $fk ; |
574 | print "# Fetch Value : expected '$fv' got '$fetch_value'\n" |
575 | if $fetch_value ne $fv ; |
576 | print "# Store Key : expected '$sk' got '$store_key'\n" |
577 | if $store_key ne $sk ; |
578 | print "# Store Value : expected '$sv' got '$store_value'\n" |
579 | if $store_value ne $sv ; |
580 | print "# \$_ : expected 'original' got '$_'\n" |
581 | if $_ ne 'original' ; |
582 | |
9fe6733a |
583 | return |
efc79c7d |
584 | $fetch_key eq $fk && $store_key eq $sk && |
9fe6733a |
585 | $fetch_value eq $fv && $store_value eq $sv && |
586 | $_ eq 'original' ; |
587 | } |
588 | |
efc79c7d |
589 | ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
9fe6733a |
590 | |
591 | $db->filter_fetch_key (sub { $fetch_key = $_ }) ; |
592 | $db->filter_store_key (sub { $store_key = $_ }) ; |
593 | $db->filter_fetch_value (sub { $fetch_value = $_}) ; |
594 | $db->filter_store_value (sub { $store_value = $_ }) ; |
595 | |
596 | $_ = "original" ; |
597 | |
598 | $h[0] = "joe" ; |
599 | # fk sk fv sv |
efc79c7d |
600 | ok(100, checkOutput( "", 0, "", "joe")) ; |
9fe6733a |
601 | |
602 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
603 | ok(101, $h[0] eq "joe"); |
9fe6733a |
604 | # fk sk fv sv |
efc79c7d |
605 | ok(102, checkOutput( "", 0, "joe", "")) ; |
9fe6733a |
606 | |
607 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
608 | ok(103, $db->FIRSTKEY() == 0) ; |
9fe6733a |
609 | # fk sk fv sv |
efc79c7d |
610 | ok(104, checkOutput( 0, "", "", "")) ; |
9fe6733a |
611 | |
612 | # replace the filters, but remember the previous set |
613 | my ($old_fk) = $db->filter_fetch_key |
614 | (sub { ++ $_ ; $fetch_key = $_ }) ; |
615 | my ($old_sk) = $db->filter_store_key |
616 | (sub { $_ *= 2 ; $store_key = $_ }) ; |
617 | my ($old_fv) = $db->filter_fetch_value |
618 | (sub { $_ = "[$_]"; $fetch_value = $_ }) ; |
619 | my ($old_sv) = $db->filter_store_value |
620 | (sub { s/o/x/g; $store_value = $_ }) ; |
621 | |
622 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
623 | $h[1] = "Joe" ; |
624 | # fk sk fv sv |
efc79c7d |
625 | ok(105, checkOutput( "", 2, "", "Jxe")) ; |
9fe6733a |
626 | |
627 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
628 | ok(106, $h[1] eq "[Jxe]"); |
9fe6733a |
629 | # fk sk fv sv |
efc79c7d |
630 | ok(107, checkOutput( "", 2, "[Jxe]", "")) ; |
9fe6733a |
631 | |
632 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
633 | ok(108, $db->FIRSTKEY() == 1) ; |
9fe6733a |
634 | # fk sk fv sv |
efc79c7d |
635 | ok(109, checkOutput( 1, "", "", "")) ; |
9fe6733a |
636 | |
637 | # put the original filters back |
638 | $db->filter_fetch_key ($old_fk); |
639 | $db->filter_store_key ($old_sk); |
640 | $db->filter_fetch_value ($old_fv); |
641 | $db->filter_store_value ($old_sv); |
642 | |
643 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
644 | $h[0] = "joe" ; |
efc79c7d |
645 | ok(110, checkOutput( "", 0, "", "joe")) ; |
9fe6733a |
646 | |
647 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
648 | ok(111, $h[0] eq "joe"); |
649 | ok(112, checkOutput( "", 0, "joe", "")) ; |
9fe6733a |
650 | |
651 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
652 | ok(113, $db->FIRSTKEY() == 0) ; |
653 | ok(114, checkOutput( 0, "", "", "")) ; |
9fe6733a |
654 | |
655 | # delete the filters |
656 | $db->filter_fetch_key (undef); |
657 | $db->filter_store_key (undef); |
658 | $db->filter_fetch_value (undef); |
659 | $db->filter_store_value (undef); |
660 | |
661 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
662 | $h[0] = "joe" ; |
efc79c7d |
663 | ok(115, checkOutput( "", "", "", "")) ; |
9fe6733a |
664 | |
665 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
666 | ok(116, $h[0] eq "joe"); |
667 | ok(117, checkOutput( "", "", "", "")) ; |
9fe6733a |
668 | |
669 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
efc79c7d |
670 | ok(118, $db->FIRSTKEY() == 0) ; |
671 | ok(119, checkOutput( "", "", "", "")) ; |
9fe6733a |
672 | |
673 | undef $db ; |
efc79c7d |
674 | ok(120, safeUntie \@h); |
9fe6733a |
675 | unlink $Dfile; |
676 | } |
677 | |
678 | { |
679 | # DBM Filter with a closure |
680 | |
3245f058 |
681 | use warnings ; |
9fe6733a |
682 | use strict ; |
683 | my (@h, $db) ; |
684 | |
685 | unlink $Dfile; |
efc79c7d |
686 | ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
9fe6733a |
687 | |
688 | my %result = () ; |
689 | |
690 | sub Closure |
691 | { |
692 | my ($name) = @_ ; |
693 | my $count = 0 ; |
694 | my @kept = () ; |
695 | |
696 | return sub { ++$count ; |
697 | push @kept, $_ ; |
698 | $result{$name} = "$name - $count: [@kept]" ; |
699 | } |
700 | } |
701 | |
702 | $db->filter_store_key(Closure("store key")) ; |
703 | $db->filter_store_value(Closure("store value")) ; |
704 | $db->filter_fetch_key(Closure("fetch key")) ; |
705 | $db->filter_fetch_value(Closure("fetch value")) ; |
706 | |
707 | $_ = "original" ; |
708 | |
709 | $h[0] = "joe" ; |
efc79c7d |
710 | ok(122, $result{"store key"} eq "store key - 1: [0]"); |
711 | ok(123, $result{"store value"} eq "store value - 1: [joe]"); |
712 | ok(124, ! defined $result{"fetch key"} ); |
c6c92ad9 |
713 | ok(125, ! defined $result{"fetch value"} ); |
714 | ok(126, $_ eq "original") ; |
715 | |
efc79c7d |
716 | ok(127, $db->FIRSTKEY() == 0 ) ; |
717 | ok(128, $result{"store key"} eq "store key - 1: [0]"); |
718 | ok(129, $result{"store value"} eq "store value - 1: [joe]"); |
c6c92ad9 |
719 | ok(130, $result{"fetch key"} eq "fetch key - 1: [0]"); |
efc79c7d |
720 | ok(131, ! defined $result{"fetch value"} ); |
c6c92ad9 |
721 | ok(132, $_ eq "original") ; |
9fe6733a |
722 | |
efc79c7d |
723 | $h[7] = "john" ; |
724 | ok(133, $result{"store key"} eq "store key - 2: [0 7]"); |
725 | ok(134, $result{"store value"} eq "store value - 2: [joe john]"); |
726 | ok(135, $result{"fetch key"} eq "fetch key - 1: [0]"); |
727 | ok(136, ! defined $result{"fetch value"} ); |
728 | ok(137, $_ eq "original") ; |
729 | |
730 | ok(138, $h[0] eq "joe"); |
731 | ok(139, $result{"store key"} eq "store key - 3: [0 7 0]"); |
732 | ok(140, $result{"store value"} eq "store value - 2: [joe john]"); |
733 | ok(141, $result{"fetch key"} eq "fetch key - 1: [0]"); |
734 | ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]"); |
735 | ok(143, $_ eq "original") ; |
736 | |
9fe6733a |
737 | undef $db ; |
efc79c7d |
738 | ok(144, safeUntie \@h); |
9fe6733a |
739 | unlink $Dfile; |
740 | } |
741 | |
742 | { |
743 | # DBM Filter recursion detection |
3245f058 |
744 | use warnings ; |
9fe6733a |
745 | use strict ; |
746 | my (@h, $db) ; |
747 | unlink $Dfile; |
748 | |
efc79c7d |
749 | ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
9fe6733a |
750 | |
751 | $db->filter_store_key (sub { $_ = $h[0] }) ; |
752 | |
753 | eval '$h[1] = 1234' ; |
efc79c7d |
754 | ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); |
9fe6733a |
755 | |
756 | undef $db ; |
efc79c7d |
757 | ok(147, safeUntie \@h); |
9fe6733a |
758 | unlink $Dfile; |
759 | } |
760 | |
9b761c68 |
761 | |
762 | { |
763 | # Examples from the POD |
764 | |
765 | my $file = "xyzt" ; |
766 | { |
767 | my $redirect = new Redirect $file ; |
768 | |
3245f058 |
769 | use warnings FATAL => qw(all); |
9b761c68 |
770 | use strict ; |
771 | use DB_File ; |
772 | |
773 | my $filename = "text" ; |
774 | unlink $filename ; |
775 | |
776 | my @h ; |
777 | my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO |
778 | or die "Cannot open file 'text': $!\n" ; |
779 | |
780 | # Add a few key/value pairs to the file |
781 | $h[0] = "orange" ; |
782 | $h[1] = "blue" ; |
783 | $h[2] = "yellow" ; |
784 | |
785 | $FA ? push @h, "green", "black" |
786 | : $x->push("green", "black") ; |
787 | |
788 | my $elements = $FA ? scalar @h : $x->length ; |
789 | print "The array contains $elements entries\n" ; |
790 | |
791 | my $last = $FA ? pop @h : $x->pop ; |
792 | print "popped $last\n" ; |
793 | |
794 | $FA ? unshift @h, "white" |
795 | : $x->unshift("white") ; |
796 | my $first = $FA ? shift @h : $x->shift ; |
797 | print "shifted $first\n" ; |
798 | |
799 | # Check for existence of a key |
800 | print "Element 1 Exists with value $h[1]\n" if $h[1] ; |
801 | |
802 | # use a negative index |
803 | print "The last element is $h[-1]\n" ; |
804 | print "The 2nd last element is $h[-2]\n" ; |
805 | |
806 | undef $x ; |
807 | untie @h ; |
808 | |
809 | unlink $filename ; |
810 | } |
811 | |
efc79c7d |
812 | ok(148, docat_del($file) eq <<'EOM') ; |
9b761c68 |
813 | The array contains 5 entries |
814 | popped black |
815 | shifted white |
816 | Element 1 Exists with value blue |
817 | The last element is green |
818 | The 2nd last element is yellow |
819 | EOM |
820 | |
821 | my $save_output = "xyzt" ; |
822 | { |
823 | my $redirect = new Redirect $save_output ; |
824 | |
3245f058 |
825 | use warnings FATAL => qw(all); |
9b761c68 |
826 | use strict ; |
07200f1b |
827 | our (@h, $H, $file, $i); |
9b761c68 |
828 | use DB_File ; |
829 | use Fcntl ; |
830 | |
831 | $file = "text" ; |
832 | |
833 | unlink $file ; |
834 | |
835 | $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO |
836 | or die "Cannot open file $file: $!\n" ; |
837 | |
838 | # first create a text file to play with |
839 | $h[0] = "zero" ; |
840 | $h[1] = "one" ; |
841 | $h[2] = "two" ; |
842 | $h[3] = "three" ; |
843 | $h[4] = "four" ; |
844 | |
845 | |
846 | # Print the records in order. |
847 | # |
848 | # The length method is needed here because evaluating a tied |
849 | # array in a scalar context does not return the number of |
850 | # elements in the array. |
851 | |
852 | print "\nORIGINAL\n" ; |
853 | foreach $i (0 .. $H->length - 1) { |
854 | print "$i: $h[$i]\n" ; |
855 | } |
856 | |
857 | # use the push & pop methods |
858 | $a = $H->pop ; |
859 | $H->push("last") ; |
860 | print "\nThe last record was [$a]\n" ; |
861 | |
862 | # and the shift & unshift methods |
863 | $a = $H->shift ; |
864 | $H->unshift("first") ; |
865 | print "The first record was [$a]\n" ; |
866 | |
867 | # Use the API to add a new record after record 2. |
868 | $i = 2 ; |
869 | $H->put($i, "Newbie", R_IAFTER) ; |
870 | |
871 | # and a new record before record 1. |
872 | $i = 1 ; |
873 | $H->put($i, "New One", R_IBEFORE) ; |
874 | |
875 | # delete record 3 |
876 | $H->del(3) ; |
877 | |
878 | # now print the records in reverse order |
879 | print "\nREVERSE\n" ; |
880 | for ($i = $H->length - 1 ; $i >= 0 ; -- $i) |
881 | { print "$i: $h[$i]\n" } |
882 | |
883 | # same again, but use the API functions instead |
884 | print "\nREVERSE again\n" ; |
885 | my ($s, $k, $v) = (0, 0, 0) ; |
886 | for ($s = $H->seq($k, $v, R_LAST) ; |
887 | $s == 0 ; |
888 | $s = $H->seq($k, $v, R_PREV)) |
889 | { print "$k: $v\n" } |
890 | |
891 | undef $H ; |
892 | untie @h ; |
893 | |
894 | unlink $file ; |
895 | } |
896 | |
efc79c7d |
897 | ok(149, docat_del($save_output) eq <<'EOM') ; |
9b761c68 |
898 | |
899 | ORIGINAL |
900 | 0: zero |
901 | 1: one |
902 | 2: two |
903 | 3: three |
904 | 4: four |
905 | |
906 | The last record was [four] |
907 | The first record was [zero] |
908 | |
909 | REVERSE |
910 | 5: last |
911 | 4: three |
912 | 3: Newbie |
913 | 2: one |
914 | 1: New One |
915 | 0: first |
916 | |
917 | REVERSE again |
918 | 5: last |
919 | 4: three |
920 | 3: Newbie |
921 | 2: one |
922 | 1: New One |
923 | 0: first |
924 | EOM |
925 | |
926 | } |
927 | |
cbc5248d |
928 | { |
929 | # Bug ID 20001013.009 |
930 | # |
931 | # test that $hash{KEY} = undef doesn't produce the warning |
932 | # Use of uninitialized value in null operation |
933 | use warnings ; |
934 | use strict ; |
935 | use DB_File ; |
936 | |
937 | unlink $Dfile; |
938 | my @h ; |
939 | my $a = ""; |
940 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
941 | |
3245f058 |
942 | tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO |
cbc5248d |
943 | or die "Can't open file: $!\n" ; |
944 | $h[0] = undef; |
efc79c7d |
945 | ok(150, $a eq "") ; |
946 | ok(151, safeUntie \@h); |
3245f058 |
947 | unlink $Dfile; |
948 | } |
949 | |
950 | { |
951 | # test that %hash = () doesn't produce the warning |
952 | # Argument "" isn't numeric in entersub |
953 | use warnings ; |
954 | use strict ; |
955 | use DB_File ; |
956 | my $a = ""; |
957 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
958 | |
959 | unlink $Dfile; |
960 | my @h ; |
961 | |
962 | tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO |
963 | or die "Can't open file: $!\n" ; |
964 | @h = (); ; |
efc79c7d |
965 | ok(152, $a eq "") ; |
966 | ok(153, safeUntie \@h); |
cbc5248d |
967 | unlink $Dfile; |
968 | } |
969 | |
efc79c7d |
970 | { |
971 | # Check that DBM Filter can cope with read-only $_ |
972 | |
973 | use warnings ; |
974 | use strict ; |
975 | my (@h, $db) ; |
976 | unlink $Dfile; |
977 | |
978 | ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
979 | |
980 | $db->filter_fetch_key (sub { }) ; |
981 | $db->filter_store_key (sub { }) ; |
982 | $db->filter_fetch_value (sub { }) ; |
983 | $db->filter_store_value (sub { }) ; |
984 | |
985 | $_ = "original" ; |
986 | |
987 | $h[0] = "joe" ; |
988 | ok(155, $h[0] eq "joe"); |
989 | |
f84167b3 |
990 | eval { my @r= grep { $h[$_] } (1, 2, 3) }; |
efc79c7d |
991 | ok (156, ! $@); |
992 | |
993 | |
994 | # delete the filters |
995 | $db->filter_fetch_key (undef); |
996 | $db->filter_store_key (undef); |
997 | $db->filter_fetch_value (undef); |
998 | $db->filter_store_value (undef); |
999 | |
1000 | $h[1] = "joe" ; |
1001 | |
1002 | ok(157, $h[1] eq "joe"); |
1003 | |
f84167b3 |
1004 | eval { my @r= grep { $h[$_] } (1, 2, 3) }; |
efc79c7d |
1005 | ok (158, ! $@); |
1006 | |
1007 | undef $db ; |
1008 | untie @h; |
1009 | unlink $Dfile; |
1010 | } |
1011 | |
5bbd4290 |
1012 | { |
1013 | # Check low-level API works with filter |
1014 | |
1015 | use warnings ; |
1016 | use strict ; |
1017 | my (@h, $db) ; |
1018 | my $Dfile = "xxy.db"; |
1019 | unlink $Dfile; |
1020 | |
1021 | ok(159, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
1022 | |
1023 | |
1024 | $db->filter_fetch_key (sub { ++ $_ } ); |
1025 | $db->filter_store_key (sub { -- $_ } ); |
1026 | $db->filter_fetch_value (sub { $_ = unpack("i", $_) } ); |
1027 | $db->filter_store_value (sub { $_ = pack("i", $_) } ); |
1028 | |
1029 | $_ = 'fred'; |
1030 | |
1031 | my $key = 22 ; |
1032 | my $value = 34 ; |
1033 | |
1034 | $db->put($key, $value) ; |
1035 | ok 160, $key == 22; |
1036 | ok 161, $value == 34 ; |
1037 | ok 162, $_ eq 'fred'; |
1038 | #print "k [$key][$value]\n" ; |
1039 | |
1040 | my $val ; |
1041 | $db->get($key, $val) ; |
1042 | ok 163, $key == 22; |
1043 | ok 164, $val == 34 ; |
1044 | ok 165, $_ eq 'fred'; |
1045 | |
1046 | $key = 51 ; |
1047 | $value = 454; |
1048 | $h[$key] = $value ; |
1049 | ok 166, $key == 51; |
1050 | ok 167, $value == 454 ; |
1051 | ok 168, $_ eq 'fred'; |
1052 | |
1053 | undef $db ; |
1054 | untie @h; |
1055 | unlink $Dfile; |
1056 | } |
1057 | |
9c095db2 |
1058 | |
1059 | { |
1060 | # Regression Test for bug 30237 |
1061 | # Check that substr can be used in the key to db_put |
1062 | # and that db_put does not trigger the warning |
1063 | # |
1064 | # Use of uninitialized value in subroutine entry |
1065 | |
1066 | |
1067 | use warnings ; |
1068 | use strict ; |
1069 | my (@h, $db) ; |
1070 | my $status ; |
1071 | my $Dfile = "xxy.db"; |
1072 | unlink $Dfile; |
1073 | |
1074 | ok(169, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO) ); |
1075 | |
1076 | my $warned = ''; |
1077 | local $SIG{__WARN__} = sub {$warned = $_[0]} ; |
1078 | |
1079 | # db-put with substr of key |
1080 | my %remember = () ; |
1081 | for my $ix ( 0 .. 2 ) |
1082 | { |
1083 | my $key = $ix . "data" ; |
1084 | my $value = "value$ix" ; |
1085 | $remember{substr($key,0, 1)} = $value ; |
1086 | $db->put(substr($key,0, 1), $value) ; |
1087 | } |
1088 | |
1089 | ok 170, $warned eq '' |
1090 | or print "# Caught warning [$warned]\n" ; |
1091 | |
1092 | # db-put with substr of value |
1093 | $warned = ''; |
1094 | for my $ix ( 3 .. 5 ) |
1095 | { |
1096 | my $key = $ix . "data" ; |
1097 | my $value = "value$ix" ; |
1098 | $remember{$ix} = $value ; |
1099 | $db->put($ix, substr($value,0)) ; |
1100 | } |
1101 | |
1102 | ok 171, $warned eq '' |
1103 | or print "# Caught warning [$warned]\n" ; |
1104 | |
1105 | # via the tied array is not a problem, but check anyway |
1106 | # substr of key |
1107 | $warned = ''; |
1108 | for my $ix ( 6 .. 8 ) |
1109 | { |
1110 | my $key = $ix . "data" ; |
1111 | my $value = "value$ix" ; |
1112 | $remember{substr($key,0,1)} = $value ; |
1113 | $h[substr($key,0,1)] = $value ; |
1114 | } |
1115 | |
1116 | ok 172, $warned eq '' |
1117 | or print "# Caught warning [$warned]\n" ; |
1118 | |
1119 | # via the tied array is not a problem, but check anyway |
1120 | # substr of value |
1121 | $warned = ''; |
1122 | for my $ix ( 9 .. 10 ) |
1123 | { |
1124 | my $key = $ix . "data" ; |
1125 | my $value = "value$ix" ; |
1126 | $remember{$ix} = $value ; |
1127 | $h[$ix] = substr($value,0) ; |
1128 | } |
1129 | |
1130 | ok 173, $warned eq '' |
1131 | or print "# Caught warning [$warned]\n" ; |
1132 | |
1133 | my %bad = () ; |
1134 | my $key = ''; |
1135 | for (my $status = $db->seq($key, $value, R_FIRST ) ; |
1136 | $status == 0 ; |
1137 | $status = $db->seq($key, $value, R_NEXT ) ) { |
1138 | |
1139 | #print "# key [$key] value [$value]\n" ; |
1140 | if (defined $remember{$key} && defined $value && |
1141 | $remember{$key} eq $value) { |
1142 | delete $remember{$key} ; |
1143 | } |
1144 | else { |
1145 | $bad{$key} = $value ; |
1146 | } |
1147 | } |
1148 | |
1149 | ok 174, keys %bad == 0 ; |
1150 | ok 175, keys %remember == 0 ; |
1151 | |
1152 | print "# missing -- $key $value\n" while ($key, $value) = each %remember; |
1153 | print "# bad -- $key $value\n" while ($key, $value) = each %bad; |
1154 | |
1155 | # Make sure this fix does not break code to handle an undef key |
1156 | my $value = 'fred'; |
1157 | $warned = ''; |
1158 | $status = $db->put(undef, $value) ; |
1159 | ok 176, $status == 0 |
1160 | or print "# put failed - status $status\n"; |
1161 | ok 177, $warned eq '' |
1162 | or print "# Caught warning [$warned]\n" ; |
1163 | $warned = ''; |
1164 | |
1165 | print "# db_ver $DB_File::db_ver\n"; |
1166 | $value = '' ; |
1167 | $status = $db->get(undef, $value) ; |
1168 | ok 178, $status == 0 |
1169 | or print "# get failed - status $status\n" ; |
1170 | ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ; |
1171 | ok 180, $value eq 'fred' or print "# got [$value]\n" ; |
1172 | ok 181, $warned eq '' |
1173 | or print "# Caught warning [$warned]\n" ; |
1174 | $warned = ''; |
1175 | |
1176 | undef $db ; |
1177 | untie @h; |
1178 | unlink $Dfile; |
1179 | } |
1180 | |
c6c92ad9 |
1181 | # Only test splice if this is a newish version of Perl |
1182 | exit unless $FA ; |
1183 | |
1184 | # Test SPLICE |
d85a743d |
1185 | |
1186 | { |
1187 | # check that the splice warnings are under the same lexical control |
1188 | # as their non-tied counterparts. |
1189 | |
1190 | use warnings; |
1191 | use strict; |
1192 | |
1193 | my $a = ''; |
1194 | my @a = (1); |
1195 | local $SIG{__WARN__} = sub {$a = $_[0]} ; |
1196 | |
1197 | unlink $Dfile; |
1198 | my @tied ; |
1199 | |
1200 | tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO |
1201 | or die "Can't open file: $!\n" ; |
1202 | |
1203 | # uninitialized offset |
1204 | use warnings; |
1205 | my $offset ; |
1206 | $a = ''; |
1207 | splice(@a, $offset); |
9c095db2 |
1208 | ok(182, $a =~ /^Use of uninitialized value /); |
d85a743d |
1209 | $a = ''; |
1210 | splice(@tied, $offset); |
9c095db2 |
1211 | ok(183, $a =~ /^Use of uninitialized value in splice/); |
d85a743d |
1212 | |
1213 | no warnings 'uninitialized'; |
1214 | $a = ''; |
1215 | splice(@a, $offset); |
9c095db2 |
1216 | ok(184, $a eq ''); |
d85a743d |
1217 | $a = ''; |
1218 | splice(@tied, $offset); |
9c095db2 |
1219 | ok(185, $a eq ''); |
d85a743d |
1220 | |
1221 | # uninitialized length |
1222 | use warnings; |
1223 | my $length ; |
1224 | $a = ''; |
1225 | splice(@a, 0, $length); |
9c095db2 |
1226 | ok(186, $a =~ /^Use of uninitialized value /); |
d85a743d |
1227 | $a = ''; |
1228 | splice(@tied, 0, $length); |
9c095db2 |
1229 | ok(187, $a =~ /^Use of uninitialized value in splice/); |
d85a743d |
1230 | |
1231 | no warnings 'uninitialized'; |
1232 | $a = ''; |
1233 | splice(@a, 0, $length); |
9c095db2 |
1234 | ok(188, $a eq ''); |
d85a743d |
1235 | $a = ''; |
1236 | splice(@tied, 0, $length); |
9c095db2 |
1237 | ok(189, $a eq ''); |
d85a743d |
1238 | |
1239 | # offset past end of array |
1240 | use warnings; |
1241 | $a = ''; |
1242 | splice(@a, 3); |
1243 | my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/); |
1244 | $a = ''; |
1245 | splice(@tied, 3); |
9c095db2 |
1246 | ok(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); |
d85a743d |
1247 | |
1248 | no warnings 'misc'; |
1249 | $a = ''; |
1250 | splice(@a, 3); |
9c095db2 |
1251 | ok(191, $a eq ''); |
d85a743d |
1252 | $a = ''; |
1253 | splice(@tied, 3); |
9c095db2 |
1254 | ok(192, $a eq ''); |
d85a743d |
1255 | |
9c095db2 |
1256 | ok(193, safeUntie \@tied); |
d85a743d |
1257 | unlink $Dfile; |
1258 | } |
1259 | |
c6c92ad9 |
1260 | # |
1261 | # These are a few regression tests: bundles of five arguments to pass |
1262 | # to test_splice(). The first four arguments correspond to those |
1263 | # given to splice(), and the last says which context to call it in |
1264 | # (scalar, list or void). |
1265 | # |
1266 | # The expected result is not needed because we get that by running |
1267 | # Perl's built-in splice(). |
1268 | # |
1269 | my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', |
1270 | 'rarely', 'paleness' ], |
1271 | -4, -2, |
1272 | [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], |
1273 | 'void' ], |
1274 | |
1275 | [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], |
1276 | |
1277 | [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], |
1278 | 0, -4, |
1279 | [ 'maids' ], |
1280 | 'void' ], |
1281 | |
1282 | [ [ 'visibility', 'pocketful', 'rectangles' ], |
1283 | -10, 0, |
1284 | [ 'garbages' ], |
1285 | 'void' ], |
1286 | |
1287 | [ [ 'sleeplessly' ], |
1288 | 8, -4, |
1289 | [ 'Margery', 'clearing', 'repercussion', 'clubs', |
1290 | 'arise' ], |
1291 | 'void' ], |
1292 | |
1293 | [ [ 'chastises', 'recalculates' ], |
1294 | 0, 0, |
1295 | [ 'momentariness', 'mediates', 'accents', 'toils', |
1296 | 'regaled' ], |
1297 | 'void' ], |
1298 | |
1299 | [ [ 'b', '' ], |
1300 | 9, 8, |
1301 | [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], |
1302 | 'scalar' ], |
1303 | |
1304 | [ [ 'b', '' ], |
1305 | undef, undef, |
1306 | [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], |
1307 | 'scalar' ], |
1308 | |
1309 | [ [ 'riheb' ], -8, undef, [], 'void' ], |
1310 | |
1311 | [ [ 'uft', 'qnxs', '' ], |
1312 | 6, -2, |
1313 | [ 'znp', 'mhnkh', 'bn' ], |
1314 | 'void' ], |
1315 | ); |
1316 | |
9c095db2 |
1317 | my $testnum = 194; |
c6c92ad9 |
1318 | my $failed = 0; |
2359510d |
1319 | my $tmp = "dbr$$"; |
c6c92ad9 |
1320 | foreach my $test (@tests) { |
1321 | my $err = test_splice(@$test); |
1322 | if (defined $err) { |
77fd2717 |
1323 | print STDERR "# failed: ", Dumper($test); |
1324 | print STDERR "# error: $err\n"; |
c6c92ad9 |
1325 | $failed = 1; |
1326 | ok($testnum++, 0); |
1327 | } |
1328 | else { ok($testnum++, 1) } |
1329 | } |
1330 | |
1331 | if ($failed) { |
1332 | # Not worth running the random ones |
77fd2717 |
1333 | print STDERR '# skipping ', $testnum++, "\n"; |
c6c92ad9 |
1334 | } |
1335 | else { |
1336 | # A thousand randomly-generated tests |
1337 | $failed = 0; |
1338 | srand(0); |
1339 | foreach (0 .. 1000 - 1) { |
1340 | my $test = rand_test(); |
1341 | my $err = test_splice(@$test); |
1342 | if (defined $err) { |
77fd2717 |
1343 | print STDERR "# failed: ", Dumper($test); |
1344 | print STDERR "# error: $err\n"; |
c6c92ad9 |
1345 | $failed = 1; |
77fd2717 |
1346 | print STDERR "# skipping any remaining random tests\n"; |
c6c92ad9 |
1347 | last; |
1348 | } |
1349 | } |
1350 | |
1351 | ok($testnum++, not $failed); |
1352 | } |
1353 | |
efc79c7d |
1354 | die "testnum ($testnum) != total_tests ($total_tests) + 1" |
1355 | if $testnum != $total_tests + 1; |
c6c92ad9 |
1356 | |
a0d0e21e |
1357 | exit ; |
c6c92ad9 |
1358 | |
1359 | # Subroutines for SPLICE testing |
1360 | |
1361 | # test_splice() |
1362 | # |
1363 | # Test the new splice() against Perl's built-in one. The first four |
1364 | # parameters are those passed to splice(), except that the lists must |
1365 | # be (explicitly) passed by reference, and are not actually modified. |
1366 | # (It's just a test!) The last argument specifies the context in |
1367 | # which to call the functions: 'list', 'scalar', or 'void'. |
1368 | # |
1369 | # Returns: |
1370 | # undef, if the two splices give the same results for the given |
1371 | # arguments and context; |
1372 | # |
1373 | # an error message showing the difference, otherwise. |
1374 | # |
1375 | # Reads global variable $tmp. |
1376 | # |
1377 | sub test_splice { |
1378 | die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5; |
1379 | my ($array, $offset, $length, $list, $context) = @_; |
1380 | my @array = @$array; |
1381 | my @list = @$list; |
1382 | |
a109f988 |
1383 | unlink $tmp; |
c6c92ad9 |
1384 | |
1385 | my @h; |
a109f988 |
1386 | my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO |
c6c92ad9 |
1387 | or die "cannot open $tmp: $!"; |
a109f988 |
1388 | |
1389 | my $i = 0; |
1390 | foreach ( @array ) { $h[$i++] = $_ } |
c6c92ad9 |
1391 | |
1392 | return "basic DB_File sanity check failed" |
1393 | if list_diff(\@array, \@h); |
1394 | |
1395 | # Output from splice(): |
1396 | # Returned value (munged a bit), error msg, warnings |
1397 | # |
1398 | my ($s_r, $s_error, @s_warnings); |
1399 | |
1400 | my $gather_warning = sub { push @s_warnings, $_[0] }; |
1401 | if ($context eq 'list') { |
1402 | my @r; |
1403 | eval { |
1404 | local $SIG{__WARN__} = $gather_warning; |
1405 | @r = splice @array, $offset, $length, @list; |
1406 | }; |
1407 | $s_error = $@; |
1408 | $s_r = \@r; |
1409 | } |
1410 | elsif ($context eq 'scalar') { |
1411 | my $r; |
1412 | eval { |
1413 | local $SIG{__WARN__} = $gather_warning; |
1414 | $r = splice @array, $offset, $length, @list; |
1415 | }; |
1416 | $s_error = $@; |
1417 | $s_r = [ $r ]; |
1418 | } |
1419 | elsif ($context eq 'void') { |
1420 | eval { |
1421 | local $SIG{__WARN__} = $gather_warning; |
1422 | splice @array, $offset, $length, @list; |
1423 | }; |
1424 | $s_error = $@; |
1425 | $s_r = []; |
1426 | } |
1427 | else { |
1428 | die "bad context $context"; |
1429 | } |
1430 | |
1431 | foreach ($s_error, @s_warnings) { |
1432 | chomp; |
1433 | s/ at \S+ line \d+\.$//; |
29489e7c |
1434 | # only built-in splice identifies name of uninit value |
1435 | s/(uninitialized value) \$\w+/$1/; |
c6c92ad9 |
1436 | } |
1437 | |
1438 | # Now do the same for DB_File's version of splice |
1439 | my ($ms_r, $ms_error, @ms_warnings); |
1440 | $gather_warning = sub { push @ms_warnings, $_[0] }; |
1441 | if ($context eq 'list') { |
1442 | my @r; |
1443 | eval { |
1444 | local $SIG{__WARN__} = $gather_warning; |
1445 | @r = splice @h, $offset, $length, @list; |
1446 | }; |
1447 | $ms_error = $@; |
1448 | $ms_r = \@r; |
1449 | } |
1450 | elsif ($context eq 'scalar') { |
1451 | my $r; |
1452 | eval { |
1453 | local $SIG{__WARN__} = $gather_warning; |
1454 | $r = splice @h, $offset, $length, @list; |
1455 | }; |
1456 | $ms_error = $@; |
1457 | $ms_r = [ $r ]; |
1458 | } |
1459 | elsif ($context eq 'void') { |
1460 | eval { |
1461 | local $SIG{__WARN__} = $gather_warning; |
1462 | splice @h, $offset, $length, @list; |
1463 | }; |
1464 | $ms_error = $@; |
1465 | $ms_r = []; |
1466 | } |
1467 | else { |
1468 | die "bad context $context"; |
1469 | } |
1470 | |
1471 | foreach ($ms_error, @ms_warnings) { |
1472 | chomp; |
4300f93b |
1473 | s/ at \S+(\s+\S+)*? line \d+\.?.*//s; |
c6c92ad9 |
1474 | } |
1475 | |
1476 | return "different errors: '$s_error' vs '$ms_error'" |
1477 | if $s_error ne $ms_error; |
1478 | return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r)) |
1479 | if list_diff($s_r, $ms_r); |
1480 | return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h)) |
1481 | if list_diff(\@array, \@h); |
1482 | |
1483 | if ((scalar @s_warnings) != (scalar @ms_warnings)) { |
1484 | return 'different number of warnings'; |
1485 | } |
1486 | |
1487 | while (@s_warnings) { |
1488 | my $sw = shift @s_warnings; |
1489 | my $msw = shift @ms_warnings; |
1490 | |
1491 | if (defined $sw and defined $msw) { |
1492 | $msw =~ s/ \(.+\)$//; |
1493 | $msw =~ s/ in splice$// if $] < 5.006; |
1494 | if ($sw ne $msw) { |
1495 | return "different warning: '$sw' vs '$msw'"; |
1496 | } |
1497 | } |
1498 | elsif (not defined $sw and not defined $msw) { |
1499 | # Okay. |
1500 | } |
1501 | else { |
1502 | return "one warning defined, another undef"; |
1503 | } |
1504 | } |
1505 | |
1506 | undef $H; |
1507 | untie @h; |
1508 | |
1509 | open(TEXT, $tmp) or die "cannot open $tmp: $!"; |
77fd2717 |
1510 | @h = <TEXT>; normalise @h; chomp @h; |
c6c92ad9 |
1511 | close TEXT or die "cannot close $tmp: $!"; |
1512 | return('list is different when re-read from disk: ' |
1513 | . Dumper(\@array) . ' vs ' . Dumper(\@h)) |
1514 | if list_diff(\@array, \@h); |
1515 | |
262eaca6 |
1516 | unlink $tmp; |
1517 | |
c6c92ad9 |
1518 | return undef; # success |
1519 | } |
1520 | |
1521 | |
1522 | # list_diff() |
1523 | # |
1524 | # Do two lists differ? |
1525 | # |
1526 | # Parameters: |
1527 | # reference to first list |
1528 | # reference to second list |
1529 | # |
1530 | # Returns true iff they differ. Only works for lists of (string or |
1531 | # undef). |
1532 | # |
1533 | # Surely there is a better way to do this? |
1534 | # |
1535 | sub list_diff { |
1536 | die 'usage: list_diff(ref to first list, ref to second list)' |
1537 | if @_ != 2; |
1538 | my ($a, $b) = @_; |
1539 | my @a = @$a; my @b = @$b; |
1540 | return 1 if (scalar @a) != (scalar @b); |
1541 | for (my $i = 0; $i < @a; $i++) { |
1542 | my ($ae, $be) = ($a[$i], $b[$i]); |
1543 | if (defined $ae and defined $be) { |
1544 | return 1 if $ae ne $be; |
1545 | } |
1546 | elsif (not defined $ae and not defined $be) { |
1547 | # Two undefined values are 'equal' |
1548 | } |
1549 | else { |
1550 | return 1; |
1551 | } |
1552 | } |
1553 | return 0; |
1554 | } |
1555 | |
1556 | |
1557 | # rand_test() |
1558 | # |
1559 | # Think up a random ARRAY, OFFSET, LENGTH, LIST, and context. |
1560 | # ARRAY or LIST might be empty, and OFFSET or LENGTH might be |
1561 | # undefined. Return a 'test' - a listref of these five things. |
1562 | # |
1563 | sub rand_test { |
1564 | die 'usage: rand_test()' if @_; |
1565 | my @contexts = qw<list scalar void>; |
1566 | my $context = $contexts[int(rand @contexts)]; |
1567 | return [ rand_list(), |
1568 | (rand() < 0.5) ? (int(rand(20)) - 10) : undef, |
1569 | (rand() < 0.5) ? (int(rand(20)) - 10) : undef, |
1570 | rand_list(), |
1571 | $context ]; |
1572 | } |
1573 | |
1574 | |
1575 | sub rand_list { |
1576 | die 'usage: rand_list()' if @_; |
1577 | my @r; |
1578 | |
1579 | while (rand() > 0.1 * (scalar @r + 1)) { |
1580 | push @r, rand_word(); |
1581 | } |
1582 | return \@r; |
1583 | } |
1584 | |
1585 | |
1586 | sub rand_word { |
1587 | die 'usage: rand_word()' if @_; |
1588 | my $r = ''; |
1589 | my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>; |
1590 | while (rand() > 0.1 * (length($r) + 1)) { |
1591 | $r .= $chars[int(rand(scalar @chars))]; |
1592 | } |
1593 | return $r; |
1594 | } |
efc79c7d |
1595 | |
1596 | |