# Shared defs for test programs
# Paths. Must make case-insensitive.
use constant TESTDIR => 'testdir';
use constant INPUTZIP => 'testin.zip';
use constant OUTPUTZIP => 'testout.zip';
# Do we have the 'zip' and 'unzip' programs?
# Embed a copy of the module, rather than adding a dependency
BEGIN {
package File::Which;
use File::Spec;
my $Is_VMS = ($^O eq 'VMS');
my $Is_MacOS = ($^O eq 'MacOS');
my $Is_DOSish = (($^O eq 'MSWin32') or
($^O eq 'dos') or
($^O eq 'os2'));
# For Win32 systems, stores the extensions used for
# executable files
# For others, the empty string is used
# because 'perl' . '' eq 'perl' => easier
my @path_ext = ('');
if ($Is_DOSish) {
if ($ENV{PATHEXT} and $Is_DOSish) { # WinNT. PATHEXT might be set on Cygwin, but not used.
push @path_ext, split ';', $ENV{PATHEXT};
}
else {
push @path_ext, qw(.com .exe .bat); # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
}
}
elsif ($Is_VMS) {
push @path_ext, qw(.exe .com);
}
sub which {
my ($exec) = @_;
return undef unless $exec;
my $all = wantarray;
my @results = ();
# check for aliases first
if ($Is_VMS) {
my $symbol = `SHOW SYMBOL $exec`;
chomp($symbol);
if (!$?) {
return $symbol unless $all;
push @results, $symbol;
}
}
if ($Is_MacOS) {
my @aliases = split /\,/, $ENV{Aliases};
foreach my $alias (@aliases) {
# This has not been tested!!
# PPT which says MPW-Perl cannot resolve `Alias $alias`,
# let's just hope it's fixed
if (lc($alias) eq lc($exec)) {
chomp(my $file = `Alias $alias`);
last unless $file; # if it failed, just go on the normal way
return $file unless $all;
push @results, $file;
# we can stop this loop as if it finds more aliases matching,
# it'll just be the same result anyway
last;
}
}
}
my @path = File::Spec->path();
unshift @path, File::Spec->curdir if $Is_DOSish or $Is_VMS or $Is_MacOS;
for my $base (map { File::Spec->catfile($_, $exec) } @path) {
for my $ext (@path_ext) {
my $file = $base.$ext;
# print STDERR "$file\n";
if ((-x $file or # executable, normal case
($Is_MacOS || # MacOS doesn't mark as executable so we check -e
($Is_DOSish and grep { $file =~ /$_$/i } @path_ext[1..$#path_ext])
# DOSish systems don't pass -x on non-exe/bat/com files.
# so we check -e. However, we don't want to pass -e on files
# that aren't in PATHEXT, like README.
and -e _)
) and !-d _)
{ # and finally, we don't want dirs to pass (as they are -x)
# print STDERR "-x: ", -x $file, " -e: ", -e _, " -d: ", -d _, "\n";
return $file unless $all;
push @results, $file; # Make list to return later
}
}
}
if($all) {
return @results;
} else {
return undef;
}
}
}
use constant HAVEZIP => !! File::Which::which('zip');
use constant HAVEUNZIP => !! File::Which::which('unzip');
use constant ZIP => 'zip ';
use constant ZIPTEST => 'unzip -t ';
# 300-character test string
use constant TESTSTRING => join ( "\n", 1 .. 102 ) . "\n";
use constant TESTSTRINGLENGTH => length(TESTSTRING);
# CRC-32 should be ac373f32
use constant TESTSTRINGCRC => Archive::Zip::computeCRC32(TESTSTRING);
# This is so that it will work on other systems.
use constant CAT => $^X . ' -pe "BEGIN{binmode(STDIN);binmode(STDOUT)}"';
use constant CATPIPE => '| ' . CAT . ' >';
use vars qw($zipWorks $testZipDoesntWork $catWorks);
local ( $zipWorks, $testZipDoesntWork, $catWorks );
# Run ZIPTEST to test a zip file.
sub testZip {
my $zipName = shift || OUTPUTZIP;
if ( $testZipDoesntWork ) {
return wantarray ? ( 0, '' ) : 0;
}
my $cmd = ZIPTEST . $zipName . ( $^O eq 'MSWin32' ? '' : ' 2>&1' );
my $zipout = `$cmd`;
return wantarray ? ( $?, $zipout ) : $?;
}
# Return the crc-32 of the given file (0 if empty or error)
sub fileCRC {
my $fileName = shift;
local $/ = undef;
my $fh = IO::File->new( $fileName, "r" );
binmode($fh);
return 0 if not defined($fh);
my $contents = <$fh>;
return Archive::Zip::computeCRC32($contents);
}
#--------- check to see if cat works
sub testCat {
my $fh = IO::File->new( CATPIPE . OUTPUTZIP );
binmode($fh);
my $testString = pack( 'C256', 0 .. 255 );
my $testCrc = Archive::Zip::computeCRC32($testString);
$fh->write( $testString, length($testString) ) or return 0;
$fh->close();
( -f OUTPUTZIP ) or return 0;
my @stat = stat(OUTPUTZIP);
$stat[7] == length($testString) or return 0;
fileCRC(OUTPUTZIP) == $testCrc or return 0;
unlink(OUTPUTZIP);
return 1;
}
BEGIN {
$catWorks = testCat();
unless ( $catWorks ) {
warn( 'warning: ', CAT, " doesn't seem to work, may skip some tests" );
}
}
#--------- check to see if zip works (and make INPUTZIP)
BEGIN {
unlink(INPUTZIP);
# Do we have zip installed?
if ( HAVEZIP ) {
my $cmd = ZIP . INPUTZIP . ' *' . ( $^O eq 'MSWin32' ? '' : ' 2>&1' );
$zipout = `$cmd`;
$zipWorks = not $?;
unless ( $zipWorks ) {
warn( 'warning: ', ZIP, " doesn't seem to work, may skip some tests" );
}
}
}
#--------- check to see if unzip -t works
BEGIN {
$testZipDoesntWork = 0;
if ( HAVEUNZIP ) {
my ( $status, $zipout ) = testZip(INPUTZIP);
$testZipDoesntWork = $status;
# Again, on Win32 no big surprise if this doesn't work
if ( $testZipDoesntWork ) {
warn( 'warning: ', ZIPTEST, " doesn't seem to work, may skip some tests" );
}
}
}
1;