On Tue, 11 Dec 2018 21:49:24 +0100
Charlene Wendling wrote:

> Hi ports, 
> 
> Here is an update for Archive::Zip, it also fixes CVE-2018-10860 [1] 
> (directory traversal).
> 

I'm joining a patch for 6.4-stable, that combines the fix and the
new  t/25_traversal.t test [1], and another fix for the latter [2].

The new test requires also new zip files from [1] that need to be in 
${WRKSRC}/t/data, and i'm not aware of any clean mechanism that could
allow the port to fetch them, so the test fails. When feeded manually, 
the test works: 


===>  Regression tests for p5-Archive-Zip-1.59p0
PERL_DL_NONLAZY=1 "/usr/bin/perl" "-MExtUtils::Command::MM"
"-MTest::Harness" "-e" "undef *Test::Harness::Switches; test_harness(0,
'blib/lib', 'blib/arch')" t/*.t 
[...]
t/25_traversal.t .............. ok
All tests successful.
Files=25, Tests=345,  7 wallclock secs ( 0.00 usr  0.07 sys +  0.00
cusr  0.44 csys =  0.51 CPU) Result: PASS

In case it's fine as-is anyway, the diff is attached. 

Charlène.

[1]
https://github.com/redhotpenguin/perl-Archive-Zip/commit/5c79b9faae0f1dd67cc8288964c72c12e03884f8#diff-896a798b3ecb12ed65a94e54ac0b70df
[2]
https://github.com/redhotpenguin/perl-Archive-Zip/commit/50b4003a444e1dc2aa52f802dd718cae10df7c0a


Index: devel/quirks/Makefile
===================================================================
RCS file: /cvs/ports/devel/quirks/Makefile,v
retrieving revision 1.623.2.1
diff -u -p -r1.623.2.1 Makefile
--- devel/quirks/Makefile       15 Nov 2018 22:01:51 -0000      1.623.2.1
+++ devel/quirks/Makefile       12 Dec 2018 01:25:03 -0000
@@ -5,7 +5,7 @@ CATEGORIES =    devel databases
 DISTFILES =
 
 # API.rev
-PKGNAME =      quirks-3.17
+PKGNAME =      quirks-3.18
 PKG_ARCH =     *
 MAINTAINER =   Marc Espie <[email protected]>
 
Index: devel/quirks/files/Quirks.pm
===================================================================
RCS file: /cvs/ports/devel/quirks/files/Quirks.pm,v
retrieving revision 1.637.2.1
diff -u -p -r1.637.2.1 Quirks.pm
--- devel/quirks/files/Quirks.pm        15 Nov 2018 22:01:51 -0000      
1.637.2.1
+++ devel/quirks/files/Quirks.pm        12 Dec 2018 01:25:03 -0000
@@ -1152,6 +1152,7 @@ sub tweak_search
 # list of
 #   cat/path => badspec
 my $cve = {
+       'archivers/p5-Archive-Zip' => 'p5-Archive-Zip-<1.59p0',
        'audio/flac' => 'flac-<1.3.0p1',
        'databases/mariadb,-main' => 'mariadb-client-<10.0.37',
        'databases/mariadb,-server' => 'mariadb-server-<10.0.37',
Index: archivers/p5-Archive-Zip/Makefile
===================================================================
RCS file: /cvs/ports/archivers/p5-Archive-Zip/Makefile,v
retrieving revision 1.31
diff -u -p -r1.31 Makefile
--- archivers/p5-Archive-Zip/Makefile   2 Nov 2016 22:28:52 -0000       1.31
+++ archivers/p5-Archive-Zip/Makefile   12 Dec 2018 01:25:03 -0000
@@ -6,15 +6,16 @@ MODULES =     cpan
 PKG_ARCH =     *
 
 DISTNAME =     Archive-Zip-1.59
+REVISION =     0
 
 CATEGORIES =   archivers
 
 # Perl
 PERMIT_PACKAGE_CDROM = Yes
 
-TEST_DEPENDS = archivers/zip \
-               devel/p5-Test-MockModule \
-               devel/p5-Test-Pod
+TEST_DEPENDS = archivers/unzip \
+               archivers/zip \
+               devel/p5-Test-MockModule
 
 pre-configure:
        find ${WRKSRC} -type f -name \*.orig -exec rm {} \;
Index: archivers/p5-Archive-Zip/patches/patch-MANIFEST
===================================================================
RCS file: archivers/p5-Archive-Zip/patches/patch-MANIFEST
diff -N archivers/p5-Archive-Zip/patches/patch-MANIFEST
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ archivers/p5-Archive-Zip/patches/patch-MANIFEST     12 Dec 2018 01:25:03 
-0000
@@ -0,0 +1,30 @@
+$OpenBSD$
+Fix for CVE-2018-10860 
+See 
https://github.com/redhotpenguin/perl-Archive-Zip/commit/5c79b9faae0f1dd67cc8288964c72c12e03884f8
+Index: MANIFEST
+--- MANIFEST.orig
++++ MANIFEST
+@@ -59,6 +59,7 @@ t/21_zip64.t
+ t/22_deflated_dir.t
+ t/23_closed_handle.t
+ t/24_unicode_win32.t
++t/25_traversal.t
+ t/badjpeg/expected.jpg
+ t/badjpeg/source.zip
+ t/common.pm
+@@ -68,6 +69,7 @@ t/data/crypcomp.zip
+ t/data/crypt.zip
+ t/data/def.zip
+ t/data/defstr.zip
++t/data/dotdot-from-unexistant-path.zip
+ t/data/empty.zip
+ t/data/emptydef.zip
+ t/data/emptydefstr.zip
+@@ -75,6 +77,7 @@ t/data/emptystore.zip
+ t/data/emptystorestr.zip
+ t/data/good_github11.zip
+ t/data/jar.zip
++t/data/link-dir.zip
+ t/data/linux.zip
+ t/data/mkzip.pl
+ t/data/perl.zip
Index: archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Archive_pm
===================================================================
RCS file: archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Archive_pm
diff -N archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Archive_pm
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Archive_pm   12 Dec 
2018 01:25:03 -0000
@@ -0,0 +1,72 @@
+$OpenBSD$
+Fix CVE-2018-10860
+see 
https://github.com/redhotpenguin/perl-Archive-Zip/commit/5c79b9faae0f1dd67cc8288964c72c12e03884f8
+
+Index: lib/Archive/Zip/Archive.pm
+--- lib/Archive/Zip/Archive.pm.orig
++++ lib/Archive/Zip/Archive.pm
+@@ -185,6 +185,8 @@ sub extractMember {
+         $dirName = File::Spec->catpath($volumeName, $dirName, '');
+     } else {
+         $name = $member->fileName();
++        if ((my $ret = _extractionNameIsSafe($name))
++            != AZ_OK) { return $ret; }
+         ($dirName = $name) =~ s{[^/]*$}{};
+         $dirName = Archive::Zip::_asLocalName($dirName);
+         $name    = Archive::Zip::_asLocalName($name);
+@@ -218,6 +220,8 @@ sub extractMemberWithoutPaths {
+     unless ($name) {
+         $name = $member->fileName();
+         $name =~ s{.*/}{};    # strip off directories, if any
++        if ((my $ret = _extractionNameIsSafe($name))
++            != AZ_OK) { return $ret; }
+         $name = Archive::Zip::_asLocalName($name);
+     }
+     my $rc = $member->extractToFileNamed($name, @_);
+@@ -827,6 +831,37 @@ sub addTreeMatching {
+     return $self->addTree($root, $dest, $matcher, $compressionLevel);
+ }
+ 
++# Check if one of the components of a path to the file or the file name
++# itself is an already existing symbolic link. If yes then return an
++# error. Continuing and writing to a file traversing a link posseses
++# a security threat, especially if the link was extracted from an
++# attacker-supplied archive. This would allow writing to an arbitrary
++# file. The same applies when using ".." to escape from a working
++# directory. <https://bugzilla.redhat.com/show_bug.cgi?id=1591449>
++sub _extractionNameIsSafe {
++    my $name = shift;
++    my ($volume, $directories) = File::Spec->splitpath($name, 1);
++    my @directories = File::Spec->splitdir($directories);
++    if (grep '..' eq $_, @directories) {
++        return _error(
++            "Could not extract $name safely: a parent directory is used");
++    }
++    my @path;
++    my $path;
++    for my $directory (@directories) {
++        push @path, $directory;
++        $path = File::Spec->catpath($volume, File::Spec->catdir(@path), '');
++        if (-l $path) {
++            return _error(
++                "Could not extract $name safely: $path is an existing 
symbolic link");
++        }
++        if (!-e $path) {
++            last;
++        }
++    }
++    return AZ_OK;
++}
++
+ # $zip->extractTree( $root, $dest [, $volume] );
+ #
+ # $root and $dest are Unix-style.
+@@ -861,6 +896,8 @@ sub extractTree {
+         $fileName =~ s{$pattern}{$dest};       # in Unix format
+                                                # convert to platform format:
+         $fileName = Archive::Zip::_asLocalName($fileName, $volume);
++        if ((my $ret = _extractionNameIsSafe($fileName))
++            != AZ_OK) { return $ret; }
+         my $status = $member->extractToFileNamed($fileName);
+         return $status if $status != AZ_OK;
+     }
Index: archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Member_pm
===================================================================
RCS file: 
/cvs/ports/archivers/p5-Archive-Zip/patches/Attic/patch-lib_Archive_Zip_Member_pm,v
retrieving revision 1.3
diff -u -p -r1.3 patch-lib_Archive_Zip_Member_pm
--- archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Member_pm    2 Nov 
2016 22:28:52 -0000       1.3
+++ archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_Member_pm    12 Dec 
2018 01:25:03 -0000
@@ -1,43 +1,27 @@
 $OpenBSD: patch-lib_Archive_Zip_Member_pm,v 1.3 2016/11/02 22:28:52 jasper Exp 
$
 
-http://rt.cpan.org/Public/Bug/Display.html?id=61930
-
---- lib/Archive/Zip/Member.pm.orig     Thu Aug 11 22:06:33 2016
-+++ lib/Archive/Zip/Member.pm  Wed Nov  2 20:27:03 2016
-@@ -304,7 +304,7 @@ sub _mapPermissionsToUnix {
-     if ($format == FA_AMIGA) {
-         $attribs = $attribs >> 17 & 7;                         # Amiga RWE 
bits
-         $mode    = $attribs << 6 | $attribs << 3 | $attribs;
--        return $mode;
-+        return sprintf("%d", $mode);
-     }
+Fix tests for CVE-2018-10860 fixes
+See 
https://github.com/redhotpenguin/perl-Archive-Zip/commit/50b4003a444e1dc2aa52f802dd718cae10df7c0a
+Index: lib/Archive/Zip/Member.pm
+--- lib/Archive/Zip/Member.pm.orig
++++ lib/Archive/Zip/Member.pm
+@@ -34,6 +34,10 @@ use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
+ use constant DEFAULT_FILE_PERMISSIONS      => 0100666;
+ use constant DIRECTORY_ATTRIB              => 040000;
+ use constant FILE_ATTRIB                   => 0100000;
++use constant OS_SUPPORTS_SYMLINK           => do {
++  local $@;
++  !!eval { symlink("",""); 1 };
++};
  
-     if ($format == FA_THEOS) {
-@@ -324,7 +324,10 @@ sub _mapPermissionsToUnix {
-         || $format == FA_QDOS
-         || $format == FA_TANDEM) {
-         $mode = $attribs >> 16;
--        return $mode if $mode != 0 or not $self->localExtraField;
-+        if( $mode != 0 or not $self->localExtraField) {
-+           $mode = sprintf("%d", $mode);
-+            return sprintf("%d", $mode);
-+        }
+ # Returns self if successful, else undef
+ # Assumes that fh is positioned at beginning of central directory file header.
+@@ -1090,7 +1094,7 @@ sub _writeData {
  
-         # warn("local extra field is: ", $self->localExtraField, "\n");
- 
-@@ -360,9 +363,13 @@ sub _mapPermissionsToUnix {
- 
-     # keep previous $mode setting when its "owner"
-     # part appears to be consistent with DOS attribute flags!
--    return $mode if ($mode & 0700) == (0400 | $attribs << 6);
-+    if( ( $mode & 0700 ) == ( 0400 | $attribs << 6 )) {
-+       $mode = sprintf("%d", $mode);
-+       return sprintf("%d", $mode);
-+    }
-     $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
--    return $mode;
-+    $mode = sprintf("%d", $mode);
-+    return sprintf("%d", $mode);
- }
- 
- sub unixFileAttributes {
+ # If symbolic link, just create one if the operating system is Linux, Unix, 
BSD or VMS
+ # TODO: Add checks for other operating systems
+-    if ($self->{'isSymbolicLink'} == 1 && $^O eq 'linux') {
++    if ($self->{'isSymbolicLink'} == 1 && OS_SUPPORTS_SYMLINK) {
+         my $chunkSize = $Archive::Zip::ChunkSize;
+         my ($outRef, $status) = $self->readChunk($chunkSize);
+         symlink $$outRef, $self->{'newName'};
Index: archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_pm
===================================================================
RCS file: archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_pm
diff -N archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_pm
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ archivers/p5-Archive-Zip/patches/patch-lib_Archive_Zip_pm   12 Dec 2018 
01:25:03 -0000
@@ -0,0 +1,34 @@
+$OpenBSD$
+Document behaviour changes since the fix for CVE-2018-10860
+Index: lib/Archive/Zip.pm
+--- lib/Archive/Zip.pm.orig
++++ lib/Archive/Zip.pm
+@@ -1145,6 +1145,9 @@ member is used as the name of the extracted file or
+ directory.
+ If you pass C<$extractedName>, it should be in the local file
+ system's format.
++If you do not pass C<$extractedName> and the internal filename traverses
++a parent directory or a symbolic link, the extraction will be aborted with
++C<AC_ERROR> for security reason.
+ All necessary directories will be created. Returns C<AZ_OK>
+ on success.
+ 
+@@ -1162,6 +1165,9 @@ extracted member (its paths will be deleted too). Othe
+ the internal filename of the member (minus paths) is used as
+ the name of the extracted file or directory. Returns C<AZ_OK>
+ on success.
++If you do not pass C<$extractedName> and the internal filename is equalled
++to a local symbolic link, the extraction will be aborted with C<AC_ERROR> for
++security reason.
+ 
+ =item addMember( $member )
+ 
+@@ -1609,6 +1615,8 @@ a/x to f:\d\e\x
+ 
+ a/b/c to f:\d\e\b\c and ignore ax/d/e and d/e
+ 
++If the path to the extracted file traverses a parent directory or a symbolic
++link, the extraction will be aborted with C<AC_ERROR> for security reason.
+ Returns an error code or AZ_OK if everything worked OK.
+ 
+ =back
Index: archivers/p5-Archive-Zip/patches/patch-t_10_chmod_t
===================================================================
RCS file: archivers/p5-Archive-Zip/patches/patch-t_10_chmod_t
diff -N archivers/p5-Archive-Zip/patches/patch-t_10_chmod_t
--- archivers/p5-Archive-Zip/patches/patch-t_10_chmod_t 20 Nov 2015 15:15:21 
-0000      1.2
+++ /dev/null   1 Jan 1970 00:00:00 -0000
@@ -1,12 +0,0 @@
-$OpenBSD: patch-t_10_chmod_t,v 1.2 2015/11/20 15:15:21 ajacoutot Exp $
-
-http://rt.cpan.org/Public/Bug/Display.html?id=61930
-
---- t/10_chmod.t.orig  Wed Jun 17 20:42:51 2015
-+++ t/10_chmod.t       Fri Nov 20 16:04:14 2015
-@@ -1,4 +1,4 @@
--#!/usr/bin/perl
-+#!/usr/bin/perl -T
- 
- use strict;
- 
Index: archivers/p5-Archive-Zip/patches/patch-t_25_traversal_t
===================================================================
RCS file: archivers/p5-Archive-Zip/patches/patch-t_25_traversal_t
diff -N archivers/p5-Archive-Zip/patches/patch-t_25_traversal_t
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ archivers/p5-Archive-Zip/patches/patch-t_25_traversal_t     12 Dec 2018 
01:25:03 -0000
@@ -0,0 +1,202 @@
+$OpenBSD$
+
+New traversal test for CVE-2018-10860
+See 
https://github.com/redhotpenguin/perl-Archive-Zip/commit/5c79b9faae0f1dd67cc8288964c72c12e03884f8#diff-896a798b3ecb12ed65a94e54ac0b70df
+
+Requires unshipped zip files to succeed that can be found at the 
+same URL
+
+Index: t/25_traversal.t
+--- t/25_traversal.t.orig
++++ t/25_traversal.t
+@@ -0,0 +1,190 @@
++use strict;
++use warnings;
++
++use Archive::Zip qw( :ERROR_CODES );
++use File::Spec;
++use File::Path;
++use lib 't';
++use common;
++
++use Test::More tests => 41;
++
++# These tests check for CVE-2018-10860 vulnerabilities.
++# If an archive contains a symlink and then a file that traverses that 
symlink,
++# extracting the archive tree could write into an abitrary file selected by
++# the symlink value.
++# Another issue is if an archive contains a file whose path component refers
++# to a parent direcotory. Then extracting that file could write into a file
++# out of current working directory subtree.
++# These tests check extracting of these files is refuses and that they are
++# indeed not created.
++
++# Suppress croaking errors, the tests produce some.
++Archive::Zip::setErrorHandler(sub {});
++my ($existed, $ret, $zip, $allowed_file, $forbidden_file);
++
++# Change working directory to a temporary directory because some tested
++# functions operarates there and we need prepared symlinks there.
++my @data_path = (File::Spec->splitdir(File::Spec->rel2abs('.')), 't', 'data');
++ok(chdir TESTDIR, "Working directory changed");
++
++# Case 1:
++#   link-dir -> /tmp
++#   link-dir/gotcha-linkdir
++# writes into /tmp/gotcha-linkdir file.
++SKIP: {
++    # Symlink tests make sense only if a file system supports them.
++    my $link = 'trylink';
++    $ret = eval { symlink('.', $link)};
++    skip 'Symbolic links are not supported', 12 if $@;
++    unlink $link;
++
++    # Extracting an archive tree must fail
++    $zip = Archive::Zip->new();
++    isa_ok($zip, 'Archive::Zip');
++    is($zip->read(File::Spec->catfile(@data_path, 'link-dir.zip')), AZ_OK,
++        'Archive read');
++    $existed = -e File::Spec->catfile('', 'tmp', 'gotcha-linkdir');
++    $ret = eval { $zip->extractTree() };
++    is($ret, AZ_ERROR, 'Tree extraction aborted');
++    SKIP: {
++        skip 'A canary file existed before the test', 1 if $existed;
++        ok(! -e File::Spec->catfile('link-dir', 'gotcha-linkdir'),
++            'A file was not created in a symlinked directory');
++    }
++    ok(unlink(File::Spec->catfile('link-dir')), 'link-dir removed');
++
++    # The same applies to extracting an archive member without an explicit
++    # local file name. It must abort.
++    $link = 'link-dir';
++    ok(symlink('.', $link), 'A symlink to a directory created');
++    $forbidden_file = File::Spec->catfile($link, 'gotcha-linkdir');
++    $existed = -e $forbidden_file;
++    $ret = eval { $zip->extractMember('link-dir/gotcha-linkdir') };
++    is($ret, AZ_ERROR, 'Member extraction without a local name aborted');
++    SKIP: {
++        skip 'A canary file existed before the test', 1 if $existed;
++        ok(! -e $forbidden_file,
++            'A file was not created in a symlinked directory');
++    }
++
++    # But allow extracting an archive member into a supplied file name
++    $allowed_file = File::Spec->catfile($link, 'file');
++    $ret = eval { $zip->extractMember('link-dir/gotcha-linkdir', 
$allowed_file) };
++    is($ret, AZ_OK, 'Member extraction passed');
++    ok(-e $allowed_file, 'File created');
++    ok(unlink($allowed_file), 'File removed');
++    ok(unlink($link), 'A symlink to a directory removed');
++}
++
++# Case 2:
++#   unexisting/../../../../../tmp/gotcha-dotdot-unexistingpath
++# writes into ../../../../tmp/gotcha-dotdot-unexistingpath, that is
++# /tmp/gotcha-dotdot-unexistingpath file if CWD is not deeper than
++# 4 directories.
++$zip = Archive::Zip->new();
++isa_ok($zip, 'Archive::Zip');
++is($zip->read(File::Spec->catfile(@data_path,
++            'dotdot-from-unexistant-path.zip')), AZ_OK, 'Archive read');
++$forbidden_file = File::Spec->catfile('..', '..', '..', '..', 'tmp',
++    'gotcha-dotdot-unexistingpath');
++$existed = -e $forbidden_file;
++$ret = eval { $zip->extractTree() };
++is($ret, AZ_ERROR, 'Tree extraction aborted');
++SKIP: {
++    skip 'A canary file existed before the test', 1 if $existed;
++    ok(! -e $forbidden_file, 'A file was not created in a parent directory');
++}
++
++# The same applies to extracting an archive member without an explicit local
++# file name. It must abort.
++$existed = -e $forbidden_file;
++$ret = eval { $zip->extractMember(
++        'unexisting/../../../../../tmp/gotcha-dotdot-unexistingpath',
++    ) };
++is($ret, AZ_ERROR, 'Member extraction without a local name aborted');
++SKIP: {
++    skip 'A canary file existed before the test', 1 if $existed;
++    ok(! -e $forbidden_file, 'A file was not created in a parent directory');
++}
++
++# But allow extracting an archive member into a supplied file name
++ok(mkdir('directory'), 'Directory created');
++$allowed_file = File::Spec->catfile('directory', '..', 'file');
++$ret = eval { $zip->extractMember(
++        'unexisting/../../../../../tmp/gotcha-dotdot-unexistingpath',
++        $allowed_file
++    ) };
++is($ret, AZ_OK, 'Member extraction passed');
++ok(-e $allowed_file, 'File created');
++ok(unlink($allowed_file), 'File removed');
++
++# Case 3:
++#   link-file -> /tmp/gotcha-samename
++#   link-file
++# writes into /tmp/gotcha-samename. It must abort. (Or replace the symlink in
++# more relaxed mode in the future.)
++$zip = Archive::Zip->new();
++isa_ok($zip, 'Archive::Zip');
++is($zip->read(File::Spec->catfile(@data_path, 'link-samename.zip')), AZ_OK,
++    'Archive read');
++$existed = -e File::Spec->catfile('', 'tmp', 'gotcha-samename');
++$ret = eval { $zip->extractTree() };
++is($ret, AZ_ERROR, 'Tree extraction aborted');
++SKIP: {
++    skip 'A canary file existed before the test', 1 if $existed;
++    ok(! -e File::Spec->catfile('', 'tmp', 'gotcha-samename'),
++        'A file was not created through a symlinked file');
++}
++ok(unlink(File::Spec->catfile('link-file')), 'link-file removed');
++
++# The same applies to extracting an archive member using extractMember()
++# without an explicit local file name. It must abort.
++my $link = 'link-file';
++my $target = 'target';
++ok(symlink($target, $link), 'A symlink to a file created');
++$forbidden_file = File::Spec->catfile($target);
++$existed = -e $forbidden_file;
++# Select a member by order due to same file names.
++my $member = ${[$zip->members]}[1];
++ok($member, 'A member to extract selected');
++$ret = eval { $zip->extractMember($member) };
++is($ret, AZ_ERROR,
++    'Member extraction using extractMember() without a local name aborted');
++SKIP: {
++    skip 'A canary file existed before the test', 1 if $existed;
++    ok(! -e $forbidden_file,
++        'A symlinked target file was not created');
++}
++
++# But allow extracting an archive member using extractMember() into a supplied
++# file name.
++$allowed_file = $target;
++$ret = eval { $zip->extractMember($member, $allowed_file) };
++is($ret, AZ_OK, 'Member extraction using extractMember() passed');
++ok(-e $allowed_file, 'File created');
++ok(unlink($allowed_file), 'File removed');
++
++# The same applies to extracting an archive member using
++# extractMemberWithoutPaths() without an explicit local file name.
++# It must abort.
++$existed = -e $forbidden_file;
++# Select a member by order due to same file names.
++$ret = eval { $zip->extractMemberWithoutPaths($member) };
++is($ret, AZ_ERROR,
++    'Member extraction using extractMemberWithoutPaths() without a local name 
aborted');
++SKIP: {
++    skip 'A canary file existed before the test', 1 if $existed;
++    ok(! -e $forbidden_file,
++        'A symlinked target file was not created');
++}
++
++# But allow extracting an archive member using extractMemberWithoutPaths()
++# into a supplied file name.
++$allowed_file = $target;
++$ret = eval { $zip->extractMemberWithoutPaths($member, $allowed_file) };
++is($ret, AZ_OK, 'Member extraction using extractMemberWithoutPaths() passed');
++ok(-e $allowed_file, 'File created');
++ok(unlink($allowed_file), 'File removed');
++ok(unlink($link), 'A symlink to a file removed');
++

Reply via email to