This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RT #116250: Fail the right number of tests on timeout
[perl5.git] / dist / Tie-File / t / 29_downcopy.t
1 #!/usr/bin/perl
2 #
3 # Unit tests of _downcopy function
4 #
5 # _downcopy($self, $data, $pos, $len)
6 # Write $data into a block of length $len at position $pos,
7 # moving everything in the block forwards to make room.
8 # Instead of writing the last length($data) bytes from the block
9 # (because there isn't room for them any longer) return them.
10 #
11 #
12
13 my $file = "tf$$.txt";
14
15 print "1..718\n";
16
17 my $N = 1;
18 use Tie::File;
19 print "ok $N\n"; $N++;
20
21 $: = Tie::File::_default_recsep();
22
23 my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);
24 print "ok $N\n"; $N++;
25
26 # (3-144) These were generated by 'gentests.pl' to cover all possible cases
27 # (I hope)
28 # Legend:
29 #         x: data is entirely contained within one block
30 #        x>: data runs from the middle to the end of the block
31 #        <x: data runs from the start to the middle of the block
32 #       <x>: data occupies precisely one block
33 #      x><x: data overlaps one block boundary
34 #     <x><x: data runs from the start of one block into the middle of the next
35 #     x><x>: data runs from the middle of one block to the end of the next
36 #    <x><x>: data occupies two blocks exactly
37 # <x><x><x>: data occupies three blocks exactly
38 #         0: data is null
39 #
40 # For each possible alignment of the old and new data, we investigate
41 # up to three situations: old data is shorter, old and new data are the
42 # same length, and new data is shorter.
43 #
44 # try($pos, $old, $new) means to run a test where the data starts at 
45 # position $pos, the old data has length $old,
46 # and the new data has length $new.
47 try( 9659,  6635,  6691);  # old=x        , new=x        ; old < new
48 try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
49 try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
50 try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
51 try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
52 try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
53 try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
54 try( 8394,     0,  5742);  # old=0        , new=x        ; old < new
55 try( 8192,  2819,  6738);  # old=<x       , new=<x       ; old < new
56 try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
57 try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
58 try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
59 try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
60 try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
61 try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
62 try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
63 try( 8192,     0,  6870);  # old=0        , new=<x       ; old < new
64 try( 8478,  6259,  7906);  # old=x        , new=x>       ; old < new
65 try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
66 try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
67 try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
68 try( 9759,     0,  6625);  # old=0        , new=x>       ; old < new
69 try( 8525,  2081,  8534);  # old=x        , new=x><x     ; old < new
70 try(15550,   834,  1428);  # old=x>       , new=x><x     ; old < new
71 try(14966,  1668,  3479);  # old=x><x     , new=x><x     ; old < new
72 try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
73 try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
74 try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
75 try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
76 try(12602,     0,  8354);  # old=0        , new=x><x     ; old < new
77 try( 8192,  2767,  8192);  # old=<x       , new=<x>      ; old < new
78 try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
79 try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
80 try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
81 try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
82 try( 8192,     0,  8192);  # old=0        , new=<x>      ; old < new
83 try( 8192,  6532, 10882);  # old=<x       , new=<x><x    ; old < new
84 try( 8192,  8192, 16044);  # old=<x>      , new=<x><x    ; old < new
85 try( 8192,  9555, 11020);  # old=<x><x    , new=<x><x    ; old < new
86 try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
87 try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
88 try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
89 try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
90 try( 8192,     0, 12488);  # old=0        , new=<x><x    ; old < new
91 try( 8222,  6385, 16354);  # old=x        , new=x><x>    ; old < new
92 try(13500,  2884, 11076);  # old=x>       , new=x><x>    ; old < new
93 try(14069,  4334, 10507);  # old=x><x     , new=x><x>    ; old < new
94 try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
95 try(10469,     0, 14107);  # old=0        , new=x><x>    ; old < new
96 try( 8192,  4181, 16384);  # old=<x       , new=<x><x>   ; old < new
97 try( 8192,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
98 try( 8192, 12087, 16384);  # old=<x><x    , new=<x><x>   ; old < new
99 try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
100 try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
101 try( 8192,     0, 16384);  # old=0        , new=<x><x>   ; old < new
102 try( 8192,  4968, 24576);  # old=<x       , new=<x><x><x>; old < new
103 try( 8192,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
104 try( 8192, 14163, 24576);  # old=<x><x    , new=<x><x><x>; old < new
105 try( 8192, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
106 try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
107 try( 8192,     0, 24576);  # old=0        , new=<x><x><x>; old < new
108 try( 8771,   776,     0);  # old=x        , new=0        ; old > new
109 try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
110 try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
111 try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
112 try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
113 try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
114 try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
115 try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
116 try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
117 try(10489,     0,     0);  # old=0        , new=0        ; old = new
118
119 # (142-223)
120 # These tests all take place at the start of the file
121 try(    0,   771,  1593);  # old=<x       , new=<x       ; old < new
122 try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
123 try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
124 try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
125 try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
126 try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
127 try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
128 try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
129 try(    0,     0,  1317);  # old=0        , new=<x       ; old < new
130 try(    0,  5609,  8192);  # old=<x       , new=<x>      ; old < new
131 try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
132 try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
133 try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
134 try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
135 try(    0,     0,  8192);  # old=0        , new=<x>      ; old < new
136 try(    0,  6265,  9991);  # old=<x       , new=<x><x    ; old < new
137 try(    0,  8192, 16119);  # old=<x>      , new=<x><x    ; old < new
138 try(    0, 10218, 11888);  # old=<x><x    , new=<x><x    ; old < new
139 try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
140 try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
141 try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
142 try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
143 try(    0,     0, 10881);  # old=0        , new=<x><x    ; old < new
144 try(    0,  6448, 16384);  # old=<x       , new=<x><x>   ; old < new
145 try(    0,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
146 try(    0, 15082, 16384);  # old=<x><x    , new=<x><x>   ; old < new
147 try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
148 try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
149 try(    0,     0, 16384);  # old=0        , new=<x><x>   ; old < new
150 try(    0,  2421, 24576);  # old=<x       , new=<x><x><x>; old < new
151 try(    0,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
152 try(    0, 11655, 24576);  # old=<x><x    , new=<x><x><x>; old < new
153 try(    0, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
154 try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
155 try(    0,     0, 24576);  # old=0        , new=<x><x><x>; old < new
156 try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
157 try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
158 try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
159 try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
160 try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
161 try(    0,     0,     0);  # old=0        , new=0        ; old = new
162
163 # (224-277)
164 # These tests all take place at the end of the file
165 $FLEN = 40960;  # Force the file to be exactly 40960 bytes long
166 try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
167 try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
168 try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
169 try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
170 try(40960,     0,  2779);  # old=0        , new=<x       ; old < new
171 try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
172 try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
173 try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
174 try(40960,     0,  8192);  # old=0        , new=<x>      ; old < new
175 try(32768,  8192, 10724);  # old=<x>      , new=<x><x    ; old < new
176 try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
177 try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
178 try(40960,     0, 11752);  # old=0        , new=<x><x    ; old < new
179 try(32768,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
180 try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
181 try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
182 try(40960,     0, 16384);  # old=0        , new=<x><x>   ; old < new
183 try(32768,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
184 try(24576, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
185 try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
186 try(40960,     0, 24576);  # old=0        , new=<x><x><x>; old < new
187 try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
188 try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
189 try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
190 try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
191 try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
192 try(40960,     0,     0);  # old=0        , new=0        ; old = new
193
194 # (278-357)
195 # These tests all take place at the end of the file
196 $FLEN = 42000;  # Force the file to be exactly 42000 bytes long
197 try(41275,   725,  4059);  # old=x        , new=x        ; old < new
198 try(41683,   317,   317);  # old=x        , new=x        ; old = new
199 try(41225,   775,   405);  # old=x        , new=x        ; old > new
200 try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
201 try(42000,     0,  2434);  # old=0        , new=x        ; old < new
202 try(40960,  1040,  1608);  # old=<x       , new=<x       ; old < new
203 try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
204 try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
205 try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
206 try(42000,     0,  6637);  # old=0        , new=<x       ; old < new
207 try(41022,   978,  8130);  # old=x        , new=x>       ; old < new
208 try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
209 try(42000,     0,  7152);  # old=0        , new=x>       ; old < new
210 try(41613,   387, 10601);  # old=x        , new=x><x     ; old < new
211 try(38460,  3540,  3938);  # old=x><x     , new=x><x     ; old < new
212 try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
213 try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
214 try(42000,     0,  9189);  # old=0        , new=x><x     ; old < new
215 try(40960,  1040,  8192);  # old=<x       , new=<x>      ; old < new
216 try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
217 try(42000,     0,  8192);  # old=0        , new=<x>      ; old < new
218 try(40960,  1040, 11778);  # old=<x       , new=<x><x    ; old < new
219 try(32768,  9232, 13792);  # old=<x><x    , new=<x><x    ; old < new
220 try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
221 try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
222 try(42000,     0,  8578);  # old=0        , new=<x><x    ; old < new
223 try(41531,   469, 15813);  # old=x        , new=x><x>    ; old < new
224 try(39618,  2382,  9534);  # old=x><x     , new=x><x>    ; old < new
225 try(42000,     0, 15344);  # old=0        , new=x><x>    ; old < new
226 try(40960,  1040, 16384);  # old=<x       , new=<x><x>   ; old < new
227 try(32768,  9232, 16384);  # old=<x><x    , new=<x><x>   ; old < new
228 try(42000,     0, 16384);  # old=0        , new=<x><x>   ; old < new
229 try(40960,  1040, 24576);  # old=<x       , new=<x><x><x>; old < new
230 try(32768,  9232, 24576);  # old=<x><x    , new=<x><x><x>; old < new
231 try(42000,     0, 24576);  # old=0        , new=<x><x><x>; old < new
232 try(41500,   500,     0);  # old=x        , new=0        ; old > new
233 try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
234 try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
235 try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
236 try(42000,     0,     0);  # old=0        , new=0        ; old = new
237
238 sub try {
239   my ($pos, $len, $newlen) = @_;
240   open F, "> $file" or die "Couldn't open file $file: $!";
241   binmode F;
242
243   # The record has exactly 17 characters.  This will help ensure that
244   # even if _downcoopy screws up, the data doesn't coincidentally
245   # look good because the remainder accidentally lines up.
246   my $d = substr("0123456789abcdef$:", -17);
247   my $recs = defined($FLEN) ?
248     int($FLEN/length($d))+1 : # enough to make up at least $FLEN
249     int(8192*5/length($d))+1; # at least 5 blocks' worth
250   my $oldfile = $d x $recs;
251   my $flen = defined($FLEN) ? $FLEN : $recs * 17;
252   substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
253   print F $oldfile;
254   close F;
255
256   die "wrong length!" unless -s $file == $flen;
257
258   my $newdata = "-" x $newlen;
259   my $expected = $oldfile;
260   my $old = defined $len ? substr($expected, $pos, $len) 
261                          : substr($expected, $pos);
262   $old = "$newdata$old";
263   my $x_retval;
264   if (defined $len) {
265     substr($expected, $pos, $len, substr($old, 0, $len, ""));
266     $x_retval = $old;
267   } else {
268     substr($expected, $pos) = $old;
269     $x_retval = "";
270   }
271
272   my $o = tie my @lines, 'Tie::File', $file or die $!;
273   local $SIG{ALRM} = sub { die "Alarm clock" };
274   my $a_retval = eval { alarm(5) unless $^P; $o->_downcopy($newdata, $pos, $len) };
275   my $err = $@;
276   undef $o; untie @lines; alarm(0);
277   if ($err) {
278     if ($err =~ /^Alarm clock/) {
279       print "# Timeout\n";
280       print "not ok $N\n"; $N++;
281       print "not ok $N\n"; $N++;
282       if (defined $len) {
283         # Fail the tests in the recursive call as well
284         print "not ok $N\n"; $N++;
285         print "not ok $N\n"; $N++;
286       }
287       return;
288     } else {
289       $@ = $err;
290       die;
291     }
292   }
293
294   open F, "< $file" or die "Couldn't open file $file: $!";
295   binmode F;
296   my $actual;
297   { local $/;
298     $actual = <F>;
299   }
300   close F;
301
302   my ($alen, $xlen) = (length $actual, length $expected);
303   unless ($alen == $xlen) {
304     my @ARGS = @_;
305     for (@ARGS) { $_ = "UNDEF" unless defined }
306     print "# try(@ARGS) expected file length $xlen, actual $alen!\n";
307   }
308   print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
309   $N++;
310   print $a_retval eq $x_retval ? "ok $N\n" : "not ok $N\n";
311   $N++;
312
313   if (defined $len) {
314     try($pos, undef, $newlen);
315   }
316 }
317
318
319
320 use POSIX 'SEEK_SET';
321 sub check_contents {
322   my @c = @_;
323   my $x = join $:, @c, '';
324   local *FH = $o->{fh};
325   seek FH, 0, SEEK_SET;
326 #  my $open = open FH, "< $file";
327   my $a;
328   { local $/; $a = <FH> }
329   $a = "" unless defined $a;
330   if ($a eq $x) {
331     print "ok $N\n";
332   } else {
333     ctrlfix($a, $x);
334     print "not ok $N\n# expected <$x>, got <$a>\n";
335   }
336   $N++;
337
338   # now check FETCH:
339   my $good = 1;
340   my $msg;
341   for (0.. $#c) {
342     my $aa = $a[$_];
343     unless ($aa eq "$c[$_]$:") {
344       $msg = "expected <$c[$_]$:>, got <$aa>";
345       ctrlfix($msg);
346       $good = 0;
347     }
348   }
349   print $good ? "ok $N\n" : "not ok $N # $msg\n";
350   $N++;
351
352   print $o->_check_integrity($file, $ENV{INTEGRITY}) 
353       ? "ok $N\n" : "not ok $N\n";
354   $N++;
355 }
356
357 sub ctrlfix {
358   for (@_) {
359     s/\n/\\n/g;
360     s/\r/\\r/g;
361   }
362 }
363
364 END {
365   undef $o;
366   untie @a;
367   1 while unlink $file;
368 }