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