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