summaryrefslogtreecommitdiff
path: root/t/common.pm
diff options
context:
space:
mode:
Diffstat (limited to 't/common.pm')
-rw-r--r--t/common.pm257
1 files changed, 257 insertions, 0 deletions
diff --git a/t/common.pm b/t/common.pm
new file mode 100644
index 0000000..cff8f78
--- /dev/null
+++ b/t/common.pm
@@ -0,0 +1,257 @@
+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;
View Lorry Controller Status