path: root/t/common.pm

use strict;

# Shared defs for test programs

# Paths. Must make case-insensitive.
use File::Temp qw(tempfile tempdir);
use File::Spec;
BEGIN { mkdir 'testdir' }
use constant TESTDIR => do {
    my $tmpdir = File::Spec->abs2rel(tempdir(DIR => 'testdir', CLEANUP => 1));
    $tmpdir =~ s!\\!/!g if $^O eq 'MSWin32';
    $tmpdir
};
use constant INPUTZIP =>
  (tempfile('testin-XXXXX', SUFFIX => '.zip', TMPDIR => 1, $^O eq 'MSWin32' ? () : (UNLINK => 1)))[1];
use constant OUTPUTZIP =>
  (tempfile('testout-XXXXX', SUFFIX => '.zip', TMPDIR => 1, $^O eq 'MSWin32' ? () : (UNLINK => 1)))[1];

# 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);

use Archive::Zip ();

# 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);

# 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');
        my $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 = 1;
    if (HAVEUNZIP) {
        my ($status, $zipout) = do { local $testZipDoesntWork = 0; 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");
        }
    }
}

sub passthrough
{
    my $fromFile = shift ;
    my $toFile = shift ;
    my $action = shift ;

    my $z = Archive::Zip->new; 
    $z->read($fromFile);
    if ($action)
    {
        for my $member($z->members())
        {
            &$action($member) ; 
        }
    }
    $z->writeToFileNamed($toFile);
}

sub readFile
{
    my $name = shift ;
    local $/;
    open F, "<$name"
        or die "Cannot open $name: $!\n";
    my $data = <F>;
    close F ;
    return $data;
}

1;