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