1package common; 2 3# See https://github.com/redhotpenguin/perl-Archive-Zip/blob/master/t/README.md 4# for a short documentation on the Archive::Zip test infrastructure. 5 6use strict; 7use warnings; 8 9use Carp qw(croak longmess); 10use Config; 11use File::Spec; 12use File::Spec::Unix; 13use File::Temp qw(tempfile tempdir); 14use Test::More; 15 16use Archive::Zip qw(:ERROR_CODES); 17 18use Exporter qw(import); 19 20@common::EXPORT = qw(TESTDIR INPUTZIP OUTPUTZIP 21 TESTSTRING TESTSTRINGLENGTH TESTSTRINGCRC 22 PATH_REL PATH_ABS PATH_ZIPFILE PATH_ZIPDIR PATH_ZIPABS 23 passThrough readFile execProc execPerl dataPath testPath 24 azbinis azok azis 25 azopen azuztok azwok); 26 27### Constants 28 29# Flag whether we run in an automated test environment 30use constant _IN_AUTOTEST_ENVIRONMENT => 31 exists($ENV{'AUTOMATED_TESTING'}) || 32 exists($ENV{'NONINTERACTIVE_TESTING'}) || 33 exists($ENV{'PERL_CPAN_REPORTER_CONFIG'}); 34 35use constant TESTDIR => do { 36 -d 'testdir' or mkdir 'testdir' or die $!; 37 tempdir(DIR => 'testdir', CLEANUP => 1, EXLOCK => 0); 38}; 39 40use constant INPUTZIP => 41 (tempfile('testin-XXXXX', SUFFIX => '.zip', TMPDIR => 1, $^O eq 'MSWin32' ? () : (UNLINK => 1)))[1]; 42 43use constant OUTPUTZIP => 44 (tempfile('testout-XXXXX', SUFFIX => '.zip', TMPDIR => 1, $^O eq 'MSWin32' ? () : (UNLINK => 1)))[1]; 45 46# 300-character test string. CRC-32 should be ac373f32. 47use constant TESTSTRING => join("\n", 1 .. 102) . "\n"; 48use constant TESTSTRINGLENGTH => length(TESTSTRING); 49use constant TESTSTRINGCRC => Archive::Zip::computeCRC32(TESTSTRING); 50 51# Path types used by functions dataPath and testPath 52use constant PATH_REL => \ "PATH_REL"; 53use constant PATH_ABS => \ "PATH_ABS"; 54use constant PATH_ZIPFILE => \ "PATH_ZIPFILE"; 55use constant PATH_ZIPDIR => \ "PATH_ZIPDIR"; 56use constant PATH_ZIPABS => \ "PATH_ZIPABS"; 57 58### Auxilliary Functions 59 60sub passThrough 61{ 62 my $fromFile = shift; 63 my $toFile = shift; 64 my $action = shift; 65 66 my $zip = Archive::Zip->new(); 67 $zip->read($fromFile) == AZ_OK or 68 croak "Cannot read archive from \"$fromFile\""; 69 if ($action) 70 { 71 for my $member($zip->members()) 72 { 73 &$action($member) ; 74 } 75 } 76 $zip->writeToFileNamed($toFile) == AZ_OK or 77 croak "Cannot write archive to \"$toFile\""; 78} 79 80sub readFile 81{ 82 my $file = shift; 83 open(F, "<$file") or 84 croak "Cannot open file \"$file\" ($!)"; 85 binmode(F); 86 local $/; 87 my $data = <F>; 88 defined($data) or 89 croak "Cannot read file \"$file\" ($!)"; 90 close(F); 91 return $data; 92} 93 94sub execProc 95{ 96 # "2>&1" DOES run portably at least on DOSish and on MACish 97 # operating systems 98 return (scalar(`$_[0] 2>&1`), $?); 99} 100 101sub execPerl 102{ 103 my $libs = join('" -I"', @INC); 104 my $perl = $Config{'perlpath'}; 105 return execProc("\"$perl\" \"-I$libs\" -w \"" . join('" "', @_) . "\""); 106} 107 108my ($cwdVol, $cwdPath) = File::Spec->splitpath(File::Spec->rel2abs('.'), 1); 109my @cwdDirs = File::Spec->splitdir($cwdPath); 110 111my @dataDirs = ('t', 'data'); 112 113sub dataPath 114{ 115 my $dataFile = shift; 116 my $pathType = @_ ? shift : PATH_REL; 117 # avoid another dependency on File::Basename 118 (undef, undef, $dataFile) = File::Spec->splitpath($dataFile); 119 $dataFile .= ".zip" unless $dataFile =~ /\.[a-z0-9]+$/i; 120 if ($pathType == PATH_REL) { 121 return File::Spec->catfile(@dataDirs, $dataFile); 122 } 123 elsif ($pathType == PATH_ABS) { 124 return File::Spec->catpath($cwdVol, File::Spec->catdir(@cwdDirs, @dataDirs), $dataFile); 125 } 126 elsif ($pathType == PATH_ZIPFILE) { 127 return File::Spec::Unix->catfile(@dataDirs, $dataFile); 128 } 129 elsif ($pathType == PATH_ZIPDIR) { 130 return File::Spec::Unix->catfile(@dataDirs, $dataFile) . "/"; 131 } 132 else { 133 return File::Spec::Unix->catfile(@cwdDirs, @dataDirs, $dataFile); 134 } 135} 136 137my @testDirs = File::Spec->splitdir(TESTDIR); 138 139# This function uses File::Spec->catfile and File::Spec->catpath 140# to assemble paths. Both methods expect the last item in a path 141# to be a file, which is not necessarily always the case for this 142# function. Since the current approach works fine and any other 143# approach would be too complex to implement, let's keep things 144# as is. 145sub testPath 146{ 147 my @pathItems = @_; 148 my $pathType = ref($pathItems[-1]) ? pop(@pathItems) : PATH_REL; 149 if ($pathType == PATH_REL) { 150 return File::Spec->catfile(@testDirs, @pathItems); 151 } 152 elsif ($pathType == PATH_ABS) { 153 # go to some contortions to have a non-empty "file" to 154 # present to File::Spec->catpath 155 if (@pathItems) { 156 my $file = pop(@pathItems); 157 return File::Spec->catpath($cwdVol, File::Spec->catdir(@cwdDirs, @testDirs, @pathItems), $file); 158 } 159 else { 160 my $file = pop(@testDirs); 161 return File::Spec->catpath($cwdVol, File::Spec->catdir(@cwdDirs, @testDirs), $file); 162 } 163 } 164 elsif ($pathType == PATH_ZIPFILE) { 165 return File::Spec::Unix->catfile(@testDirs, @pathItems); 166 } 167 elsif ($pathType == PATH_ZIPDIR) { 168 return File::Spec::Unix->catfile(@testDirs, @pathItems) . "/"; 169 } 170 else { 171 return File::Spec::Unix->catfile(@cwdDirs, @testDirs, @pathItems); 172 } 173} 174 175### Initialization 176 177# Test whether "unzip -t" is available, which we consider to be 178# the case if we successfully can run "unzip -t" on 179# "t/data/simple.zip". Keep this intentionally simple and let 180# the operating system do all the path search stuff. 181# 182# The test file "t/data/simple.zip" has been generated from 183# "t/data/store.zip" with the following alterations: All "version 184# made by" and "version needed to extract" fields have been set 185# to "0x00a0", which should guarantee maximum compatibility 186# according to APPNOTE.TXT. 187my $uztCommand = 'unzip -t'; 188my $uztOutErr = ""; 189my $uztExitVal = undef; 190my $uztWorks = eval { 191 my $simplezip = dataPath("simple.zip"); 192 ($uztOutErr, $uztExitVal) = execProc("$uztCommand $simplezip"); 193 return $uztExitVal == 0; 194}; 195if (! defined($uztWorks)) { 196 $uztWorks = 0; 197 $uztOutErr .= "Caught exception $@"; 198} 199elsif (! $uztWorks) { 200 $uztOutErr .= "Exit value $uztExitVal\n"; 201} 202 203# Check whether we can write through a (non-seekable) pipe 204my $pipeCommand = '| "' . $Config{'perlpath'} . '" -pe "BEGIN{binmode(STDIN);binmode(STDOUT)}" >'; 205my $pipeError = ""; 206my $pipeWorks = eval { 207 my $testString = pack('C256', 0 .. 255); 208 my $fh = FileHandle->new("$pipeCommand " . OUTPUTZIP) or die $!; 209 binmode($fh) or die $!; 210 $fh->write($testString, length($testString)) or die $!; 211 $fh->close() or die $!; 212 (-f OUTPUTZIP) or die $!; 213 (-s OUTPUTZIP) == length($testString) or die "length mismatch"; 214 readFile(OUTPUTZIP) eq $testString or die "data mismatch"; 215 return 1; 216} or $pipeError = $@; 217 218### Test Functions 219 220# Diags or notes, depending on whether we run in an automated 221# test environment or not. 222sub _don 223{ 224 if (_IN_AUTOTEST_ENVIRONMENT) { 225 diag(@_); 226 } 227 else { 228 note(@_); 229 } 230} 231 232sub azbinis 233{ 234 my ($got, $expected, $name) = @_; 235 local $Test::Builder::Level = $Test::Builder::Level + 1; 236 my $ok = is($got, $expected, $name); 237 if (!$ok) { 238 my $len; 239 if (length($got) > length($expected)) { 240 $len = length($expected); 241 diag("got is longer than expected"); 242 } elsif (length($got) < length($expected)) { 243 $len = length($got); 244 diag("expected is longer than got"); 245 } else { 246 $len = length($got); 247 } 248 249 BYTE_LOOP: 250 for my $byte_idx (0 .. ($len - 1)) { 251 my $got_byte = substr($got, $byte_idx, 1); 252 my $expected_byte = substr($expected, $byte_idx, 1); 253 if ($got_byte ne $expected_byte) { 254 diag(sprintf("byte %i differs: got == 0x%.2x, expected == 0x%.2x", 255 $byte_idx, ord($got_byte), ord($expected_byte))); 256 last BYTE_LOOP; 257 } 258 } 259 } 260} 261 262my @errors = (); 263my $trace = undef; 264 265$Archive::Zip::ErrorHandler = sub { 266 push(@errors, @_); 267 $trace = longmess(); 268}; 269 270sub azok 271{ 272 my $status = shift; 273 my $name = @_ ? shift : undef; 274 275 local $Test::Builder::Level = $Test::Builder::Level + 1; 276 277 return azis($status, AZ_OK, $name); 278} 279 280sub azis 281{ 282 my $status = shift; 283 my $xpst = (@_ && $_[0] =~ /^\d+$/) ? shift : undef; 284 my $emre = (@_ && ref($_[0]) eq "Regexp") ? shift : undef; 285 my $name = @_ ? shift : undef; 286 287 local $Test::Builder::Level = $Test::Builder::Level + 1; 288 289 my $errors = join("\n", map { defined($_) ? $_ : "" } @errors); 290 291 my $ok = ok(# ensure sane status 292 (defined($status)) && 293 # ensure sane expected status 294 (defined($xpst) || defined($emre)) && 295 # ensure sane errors 296 ($status != AZ_OK || @errors == 0) && 297 ($status == AZ_OK || @errors != 0) && 298 # finally, test specified conditions 299 (! defined($xpst) || $status == $xpst) && 300 (! defined($emre) || $errors =~ /$emre/), $name); 301 302 303 if (! $ok) { 304 $status = "undefined" unless defined($status); 305 diag(" got status: $status"); 306 diag(" expected: $xpst") if defined($xpst); 307 if (@errors) { 308 $errors =~ s/^\s+//; 309 $errors =~ s/\s+$//; 310 $errors =~ s/\n/\n /g; 311 diag(" got errors: $errors"); 312 } 313 else { 314 diag(" got errors: none"); 315 } 316 diag(" expected: $emre") if defined($emre); 317 diag($trace) if defined($trace); 318 } 319 elsif ($status != AZ_OK) { 320 # do not use "diag" or "_don" here, as it messes up test 321 # output beyond any readability 322 note("Got (expected) status != AZ_OK"); 323 note(" got status: $status"); 324 note(" expected: $xpst") if defined($xpst); 325 if (@errors) { 326 $errors =~ s/^\s+//; 327 $errors =~ s/\s+$//; 328 $errors =~ s/\n/\n /g; 329 note(" got errors: $errors"); 330 } 331 else { 332 note(" got errors: none"); 333 } 334 note(" expected: $emre") if defined($emre); 335 note($trace) if defined($trace); 336 } 337 338 @errors = (); 339 $trace = undef; 340 341 return $ok; 342} 343 344sub azopen 345{ 346 my $file = @_ ? shift : OUTPUTZIP; 347 348 if ($pipeWorks) { 349 if (-f $file && ! unlink($file)) { 350 return undef; 351 } 352 return FileHandle->new("$pipeCommand $file"); 353 } 354 else { 355 return FileHandle->new("> $file"); 356 } 357} 358 359my %rzipCache = (); 360 361sub azuztok 362{ 363 my $file = @_ & 1 ? shift : undef; 364 my %params = @_; 365 $file = exists($params{'file'}) ? $params{'file'} : 366 defined($file) ? $file : OUTPUTZIP; 367 my $refzip = $params{'refzip'}; 368 my $xppats = $params{'xppats'}; 369 my $name = $params{'name'}; 370 371 local $Test::Builder::Level = $Test::Builder::Level + 1; 372 373 if (! $uztWorks) { 374 SKIP: { 375 skip("\"unzip -t\" not available", 1) 376 } 377 return 1; 378 } 379 380 my $rOutErr; 381 my $rExitVal; 382 if (defined($refzip)) { 383 # normalize reference zip file name to its base name 384 (undef, undef, $refzip) = File::Spec->splitpath($refzip); 385 $refzip .= ".zip" unless $refzip =~ /\.zip$/i; 386 387 if (! exists($rzipCache{$refzip})) { 388 my $rFile = dataPath($refzip); 389 ($rOutErr, $rExitVal) = execProc("$uztCommand $rFile"); 390 $rzipCache{$refzip} = [$rOutErr, $rExitVal]; 391 if ($rExitVal != 0) { 392 _don("Non-zero exit value on reference"); 393 _don("\"unzip -t\" returned non-zero exit value $rExitVal on file \"$rFile\""); 394 _don("(which might be entirely OK on your operating system) and resulted in the"); 395 _don("following output:"); 396 _don($rOutErr); 397 } 398 } 399 else { 400 ($rOutErr, $rExitVal) = @{$rzipCache{$refzip}}; 401 } 402 } 403 404 my ($outErr, $exitVal) = execProc("$uztCommand $file"); 405 if (defined($refzip)) { 406 my $ok = ok($exitVal == $rExitVal, $name); 407 if (! $ok) { 408 diag("Got result:"); 409 diag($outErr . "Exit value $exitVal\n"); 410 diag("Expected (more or less) result:"); 411 diag($rOutErr . "Exit value $rExitVal\n"); 412 } 413 elsif ($exitVal) { 414 _don("Non-zero exit value"); 415 _don("\"unzip -t\" returned non-zero exit value $exitVal on file \"$file\""); 416 _don("(which might be entirely OK on your operating system) and resulted in the"); 417 _don("following output:"); 418 _don($outErr); 419 } 420 return $ok; 421 } 422 elsif (defined($xppats)) { 423 my $ok = 0; 424 for my $xppat (@$xppats) { 425 my ($xpExitVal, $outErrRE, $osName) = @$xppat; 426 if ((! defined($xpExitVal) || $exitVal == $xpExitVal) && 427 (! defined($outErrRE) || $outErr =~ /$outErrRE/) && 428 (! defined($osName) || $osName eq $^O)) { 429 $ok = 1; 430 last; 431 } 432 } 433 $ok = ok($ok, $name); 434 if (! $ok) { 435 diag("Got result:"); 436 diag($outErr . "Exit value $exitVal\n"); 437 } 438 elsif ($exitVal) { 439 _don("Non-zero exit value"); 440 _don("\"unzip -t\" returned non-zero exit value $exitVal on file \"$file\""); 441 _don("(which might be entirely OK on your operating system) and resulted in the"); 442 _don("following output:"); 443 _don($outErr); 444 } 445 return $ok; 446 } 447 else { 448 my $ok = ok($exitVal == 0, $name); 449 if (! $ok) { 450 diag("Got result:"); 451 diag($outErr . "Exit value $exitVal\n"); 452 } 453 return $ok; 454 } 455} 456 457sub azwok 458{ 459 my $zip = shift; 460 my %params = @_; 461 my $file = exists($params{'file'}) ? $params{'file'} : OUTPUTZIP; 462 my $name = $params{'name'} ? $params{'name'} : "write and test zip file"; 463 464 local $Test::Builder::Level = $Test::Builder::Level + 1; 465 466 my $ok; 467 468 my $fh; 469 $ok = 1; 470 $ok &&= ok($fh = azopen($file), "$name - open piped handle"); 471 $ok &&= azok($zip->writeToFileHandle($fh), "$name - write piped"); 472 $ok &&= ok($fh->close(), "$name - close piped handle"); 473 if ($ok) { 474 azuztok($file, %params, 'name' => "$name - test write piped"); 475 } 476 else { 477 SKIP: { 478 skip("$name - previous piped write failed", 1); 479 } 480 } 481 482 $ok = 1; 483 $ok &&= azok($zip->writeToFileNamed($file), "$name - write plain"); 484 if ($ok) { 485 azuztok($file, %params, 'name' => "$name - test write plain"); 486 } 487 else { 488 SKIP: { 489 skip("$name - previous plain write failed", 1); 490 } 491 } 492} 493 494### One-Time Diagnostic Functions 495 496# These functions write diagnostic information that does not 497# differ per test prorgram execution and should be called only 498# once, hence, in 01_init.t. 499 500# Write version information on "unzip", if available. 501sub azuzdiag 502{ 503 my ($outErr, $exitVal) = execProc('unzip'); 504 _don("Calling \"unzip\" resulted in:"); 505 _don($outErr . "Exit value $exitVal\n"); 506} 507 508# Write some diagnostics if "unzip -t" is not available. 509sub azuztdiag 510{ 511 unless ($uztWorks) { 512 diag("Skipping tests on zip files with \"$uztCommand\"."); 513 _don("Calling \"$uztCommand\" failed:"); 514 _don($uztOutErr); 515 _don("Some features are not tested."); 516 } 517} 518 519# Write some diagnostics if writing through pipes is not 520# available. 521sub azwpdiag 522{ 523 unless ($pipeWorks) { 524 diag("Skipping write tests through pipes."); 525 _don("Writing through pipe failed:"); 526 _don($pipeError); 527 _don("Some features are not tested."); 528 } 529} 530 5311; 532