Archive-Zip

 view release on metacpan or  search on metacpan

t/04_readmember.t  view on Meta::CPAN

isa_ok($zip, 'Archive::Zip');
@data = ('Line 1', 'Line 2', '', 'Line 3', 'Line 4');

$zip->addString(join("\n", @data), 'string.txt');
$zip->writeToFileNamed(FILENAME);

$member = $zip->memberNamed('string.txt');
$fh     = $member->readFileHandle();
ok($fh);

my ($line, $not_ok, $ret, $buffer);
while (defined($line = $fh->getline())) {
    $not_ok = 1 if ($line ne $data[$fh->input_line_number() - 1]);
}
SKIP: {
    if ($^O eq 'MSWin32') {
        skip("Ignoring failing test on Win32", 1);
    }
    ok(!$not_ok);
}

my $member_read = Archive::Zip::MemberRead->new($zip, 'string.txt');
$line = $member_read->getline({'preserve_line_ending' => 1});
is($line, "Line 1\n", 'Preserve line ending');
$line = $member_read->getline({'preserve_line_ending' => 0});
is($line, "Line 2", 'Do not preserve line ending');

$fh->rewind();
$ret = $fh->read($buffer, length($data[0]));

t/25_traversal.t  view on Meta::CPAN

# These tests check extracting of these files is refused and that they are
# indeed not created.

my ($existed, $ret, $zip, $allowed_file, $forbidden_file);

# Change working directory to a temporary directory because some tested
# functions operate there and we need prepared symlinks there.
ok(chdir testPath(), "Working directory changed");

# Symlink tests make sense only if a file system supports them.
my $symlinks_not_supported;
{
    my $link = testPath('trylink');
    $symlinks_not_supported = !eval { symlink('.', $link) };
    unlink($link);
}

# Case 1:
#   link-dir -> /tmp
#   link-dir/gotcha-linkdir
# should not write into /tmp/gotcha-linkdir file.
SKIP: {
    skip 'Symbolic links are not supported', 12 if $symlinks_not_supported;

    # Extracting an archive tree must fail
    $zip = Archive::Zip->new();
    isa_ok($zip, 'Archive::Zip');
    azok($zip->read(dataPath('link-dir.zip', PATH_ABS)), 'Archive read');
    $existed = -e File::Spec->catfile('', 'tmp', 'gotcha-linkdir');
    $ret = eval { $zip->extractTree() };
    azis($ret, AZ_ERROR,
         qr/Could not extract .* safely: .* is an existing symbolic link/,
         'Tree extraction aborted');

t/25_traversal.t  view on Meta::CPAN

azok($ret, 'Member extraction passed');
ok(-e $allowed_file, 'File created');
ok(unlink($allowed_file), 'File removed');

# Case 3:
#   link-file -> /tmp/gotcha-samename
#   link-file
# should not write into /tmp/gotcha-samename. It must abort. (Or replace
# the symlink in more relaxed mode in the future.)
SKIP: {
    skip 'Symbolic links are not supported', 18 if $symlinks_not_supported;

    # Extracting an archive tree must fail
    $zip = Archive::Zip->new();
    isa_ok($zip, 'Archive::Zip');
    azok($zip->read(dataPath('link-samename.zip', PATH_ABS)), 'Archive read');
    $existed = -e File::Spec->catfile('', 'tmp', 'gotcha-samename');
    $ret = eval { $zip->extractTree() };
    azis($ret, AZ_ERROR,
         qr/Could not extract .* safely: .* is an existing symbolic link/,
         'Tree extraction aborted');

t/27_symlinks.t  view on Meta::CPAN

use lib 't';
use common;

# Test symbolic link extraction

my $ZIP_FILE = dataPath('symlink.zip');
my $SYM_LINK = testPath('some', 'dir', 'symlink');

# Symlink tests make sense only if a file system supports them.
my $symlinks_not_supported;
{
    my $link = testPath('trylink');
    $symlinks_not_supported = !eval { symlink('.', $link) };
    unlink($link);
}

if ($symlinks_not_supported) {
    plan(skip_all => 'Symlinks not supported.');
} else {
    plan(tests => 16);
}

my $zip = Archive::Zip->new();
isa_ok($zip, 'Archive::Zip');
azok($zip->read($ZIP_FILE), 'Archive read');
my $symlink = $zip->memberNamed('foo/bar/symlink');
isa_ok($symlink, 'Archive::Zip::Member', 'Member found');