view release on metacpan or  search on metacpan

lib/Archive/Zip/Archive.pm  view on Meta::CPAN

    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.
# $volume is in local FS format.
#
sub extractTree {
    my $self = shift;

    my ($root, $dest, $volume);
    if (ref($_[0]) eq 'HASH') {
        $root   = $_[0]->{root};
        $dest   = $_[0]->{zipName};
        $volume = $_[0]->{volume};
    } else {
        ($root, $dest, $volume) = @_;
    }

    $root = '' unless defined($root);
    if (defined $dest) {
        if ($dest !~ m{/$}) {
            $dest .= '/';
        }
    } else {
        $dest = './';
    }

    my $pattern = "^\Q$root";
    my @members = $self->membersMatching($pattern);

    foreach my $member (@members) {
        my $fileName = $member->fileName();    # in Unix format
        $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;
    }
    return AZ_OK;
}

# $zip->updateMember( $memberOrName, $fileName );
# Returns (possibly updated) member, if any; undef on errors.

sub updateMember {
    my $self = shift;

    my ($oldMember, $fileName);
    if (ref($_[0]) eq 'HASH') {
        $oldMember = $_[0]->{memberOrZipName};
        $fileName  = $_[0]->{name};
    } else {
        ($oldMember, $fileName) = @_;
    }

    if (!defined($fileName)) {
        _error("updateMember(): missing fileName argument");
        return undef;
    }

    my @newStat = stat($fileName);
    if (!@newStat) {
        _ioError("Can't stat $fileName");
        return undef;
    }

    my $isDir = -d _;

    my $memberName;

    if (ref($oldMember)) {
        $memberName = $oldMember->fileName();
    } else {
        $oldMember = $self->memberNamed($memberName = $oldMember)
          || $self->memberNamed($memberName =
              _asZipDirName($oldMember, $isDir));
    }

    unless (defined($oldMember)
        && $oldMember->lastModTime() == $newStat[9]
        && $oldMember->isDirectory() == $isDir
        && ($isDir || ($oldMember->uncompressedSize() == $newStat[7]))) {

        # create the new member
        my $newMember =
            $isDir
          ? Archive::Zip::Member->newDirectoryNamed($fileName, $memberName)
          : Archive::Zip::Member->newFromFile($fileName, $memberName);

        unless (defined($newMember)) {
            _error("creation of member $fileName failed in updateMember()");
            return undef;
        }

        # replace old member or append new one
        if (defined($oldMember)) {
            $self->replaceMember($oldMember, $newMember);
        } else {
            $self->addMember($newMember);
        }

        return $newMember;
    }

    return $oldMember;
}

# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
#
# This takes the same arguments as addTree, but first checks to see
# whether the file or directory already exists in the zip file.
#
# If the fourth argument $mirror is true, then delete all my members
# if corresponding files were not found.

sub updateTree {
    my $self = shift;

    my ($root, $dest, $pred, $mirror, $compressionLevel);
    if (ref($_[0]) eq 'HASH') {
        $root             = $_[0]->{root};
        $dest             = $_[0]->{zipName};
        $pred             = $_[0]->{select};
        $mirror           = $_[0]->{mirror};
        $compressionLevel = $_[0]->{compressionLevel};
    } else {
        ($root, $dest, $pred, $mirror, $compressionLevel) = @_;
    }

    return _error("root arg missing in call to updateTree()")
      unless defined($root);
    $dest = '' unless defined($dest);
    $pred = sub { -r }
      unless defined($pred);

    $dest = _asZipDirName($dest, 1);
    my $rootZipName = _asZipDirName($root, 1);    # with trailing slash
    my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";

    my @files;
    my $startDir = _untaintDir(cwd());

    return _error('undef returned by _untaintDir on cwd ', cwd())
      unless $startDir;

    # This avoids chdir'ing in Find, in a way compatible with older
    # versions of File::Find.
    my $wanted = sub {
        local $main::_ = $File::Find::name;
        my $dir = _untaintDir($File::Find::dir);
        chdir($startDir);
        push(@files, $File::Find::name) if (&$pred);
        chdir($dir);
    };

    File::Find::find($wanted, $root);

    # Now @files has all the files that I could potentially be adding to
    # the zip. Only add the ones that are necessary.
    # For each file (updated or not), add its member name to @done.
    my %done;
    foreach my $fileName (@files) {
        my @newStat = stat($fileName);
        my $isDir   = -d _;

        # normalize, remove leading ./
        my $memberName = _asZipDirName($fileName, $isDir);
        if ($memberName eq $rootZipName) { $memberName = $dest }
        else                             { $memberName =~ s{$pattern}{$dest} }
        next if $memberName =~ m{^\.?/?$};    # skip current dir

        $done{$memberName} = 1;
        my $changedMember = $self->updateMember($memberName, $fileName);
        $changedMember->desiredCompressionLevel($compressionLevel);
        return _error("updateTree failed to update $fileName")
          unless ref($changedMember);