package Archive::Zip;
require 5.003_96;
use strict;
use Carp();
use IO::File();
use IO::Seekable();
use Compress::Zlib();
use File::Spec 0.8 ();
use vars
qw( @ISA @EXPORT_OK %EXPORT_TAGS $VERSION $ChunkSize $ErrorHandler $TempSequence);
$ChunkSize = 32768;
$ErrorHandler = \&Carp::carp;
BEGIN
{
require Exporter;
$VERSION = "1.10";
@ISA = qw( Exporter );
my @ConstantNames = qw( FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK
GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK
COMPRESSION_STORED COMPRESSION_DEFLATED COMPRESSION_LEVEL_NONE
COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST
COMPRESSION_LEVEL_BEST_COMPRESSION IFA_TEXT_FILE_MASK IFA_TEXT_FILE
IFA_BINARY_FILE );
my @MiscConstantNames = qw( FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST
FA_OS2_HPFS FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_TOPS20
FA_WINDOWS_NTFS FA_QDOS FA_ACORN FA_VFAT FA_MVS FA_BEOS FA_TANDEM
FA_THEOS GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK
DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM
DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST
COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3
COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED
COMPRESSION_DEFLATED_ENHANCED
COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED );
my @ErrorCodeNames = qw( AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR
AZ_IO_ERROR );
my @PKZipConstantNames = qw( SIGNATURE_FORMAT SIGNATURE_LENGTH
LOCAL_FILE_HEADER_SIGNATURE LOCAL_FILE_HEADER_FORMAT
LOCAL_FILE_HEADER_LENGTH DATA_DESCRIPTOR_FORMAT DATA_DESCRIPTOR_LENGTH
CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
CENTRAL_DIRECTORY_FILE_HEADER_FORMAT CENTRAL_DIRECTORY_FILE_HEADER_LENGTH
END_OF_CENTRAL_DIRECTORY_SIGNATURE
END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING END_OF_CENTRAL_DIRECTORY_FORMAT
END_OF_CENTRAL_DIRECTORY_LENGTH );
my @UtilityMethodNames = qw( _error _printError _ioError _formatError
_subclassResponsibility _binmode _isSeekable _newFileHandle _readSignature
_asZipDirName);
@EXPORT_OK = ('computeCRC32');
%EXPORT_TAGS = (
'CONSTANTS' => \@ConstantNames,
'MISC_CONSTANTS' => \@MiscConstantNames,
'ERROR_CODES' => \@ErrorCodeNames,
'PKZIP_CONSTANTS' => \@PKZipConstantNames,
'UTILITY_METHODS' => \@UtilityMethodNames
);
Exporter::export_ok_tags(
'CONSTANTS', 'ERROR_CODES',
'PKZIP_CONSTANTS', 'UTILITY_METHODS',
'MISC_CONSTANTS'
);
}
use constant AZ_OK => 0;
use constant AZ_STREAM_END => 1;
use constant AZ_ERROR => 2;
use constant AZ_FORMAT_ERROR => 3;
use constant AZ_IO_ERROR => 4;
use constant FA_MSDOS => 0;
use constant FA_AMIGA => 1;
use constant FA_VAX_VMS => 2;
use constant FA_UNIX => 3;
use constant FA_VM_CMS => 4;
use constant FA_ATARI_ST => 5;
use constant FA_OS2_HPFS => 6;
use constant FA_MACINTOSH => 7;
use constant FA_Z_SYSTEM => 8;
use constant FA_CPM => 9;
use constant FA_TOPS20 => 10;
use constant FA_WINDOWS_NTFS => 11;
use constant FA_QDOS => 12;
use constant FA_ACORN => 13;
use constant FA_VFAT => 14;
use constant FA_MVS => 15;
use constant FA_BEOS => 16;
use constant FA_TANDEM => 17;
use constant FA_THEOS => 18;
use constant GPBF_ENCRYPTED_MASK => 1 << 0;
use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1;
use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3;
use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1;
use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1;
use constant DEFLATING_COMPRESSION_FAST => 2 << 1;
use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1;
use constant COMPRESSION_STORED => 0; use constant COMPRESSION_DEFLATED => 8;
use constant COMPRESSION_LEVEL_NONE => 0;
use constant COMPRESSION_LEVEL_DEFAULT => -1;
use constant COMPRESSION_LEVEL_FASTEST => 1;
use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9;
use constant IFA_TEXT_FILE_MASK => 1;
use constant IFA_TEXT_FILE => 1; use constant IFA_BINARY_FILE => 0;
use constant SIGNATURE_FORMAT => "V";
use constant SIGNATURE_LENGTH => 4;
use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50;
use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2";
use constant LOCAL_FILE_HEADER_LENGTH => 26;
use constant DATA_DESCRIPTOR_FORMAT => "V3";
use constant DATA_DESCRIPTOR_LENGTH => 12;
use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50;
use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2";
use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42;
use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50;
use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING =>
pack( "V", END_OF_CENTRAL_DIRECTORY_SIGNATURE );
use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v";
use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18;
use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1;
use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2;
use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5;
use constant COMPRESSION_SHRUNK => 1; use constant COMPRESSION_REDUCED_1 => 2; use constant COMPRESSION_REDUCED_2 => 3; use constant COMPRESSION_REDUCED_3 => 4; use constant COMPRESSION_REDUCED_4 => 5; use constant COMPRESSION_IMPLODED => 6; use constant COMPRESSION_TOKENIZED => 7; use constant COMPRESSION_DEFLATED_ENHANCED => 9; use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10;
use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive';
use constant ZIPMEMBERCLASS => 'Archive::Zip::Member';
sub new {
my $class = shift;
return $class->ZIPARCHIVECLASS->new(@_);
}
sub computeCRC32 {
my $data = shift;
$data = shift if ref($data); my $crc = shift;
return Compress::Zlib::crc32( $data, $crc );
}
sub setChunkSize {
my $chunkSize = shift;
$chunkSize = shift if ref($chunkSize); my $oldChunkSize = $Archive::Zip::ChunkSize;
$Archive::Zip::ChunkSize = $chunkSize if ($chunkSize);
return $oldChunkSize;
}
sub chunkSize {
return $Archive::Zip::ChunkSize;
}
sub setErrorHandler (&) {
my $errorHandler = shift;
$errorHandler = \&Carp::carp unless defined($errorHandler);
my $oldErrorHandler = $Archive::Zip::ErrorHandler;
$Archive::Zip::ErrorHandler = $errorHandler;
return $oldErrorHandler;
}
sub _printError {
my $string = join ( ' ', @_, "\n" );
my $oldCarpLevel = $Carp::CarpLevel;
$Carp::CarpLevel += 2;
&{$ErrorHandler} ($string);
$Carp::CarpLevel = $oldCarpLevel;
}
sub _formatError {
shift if ref( $_[0] );
_printError( 'format error:', @_ );
return AZ_FORMAT_ERROR;
}
sub _ioError {
shift if ref( $_[0] );
_printError( 'IO error:', @_, ':', $! );
return AZ_IO_ERROR;
}
sub _error {
shift if ref( $_[0] );
_printError( 'error:', @_ );
return AZ_ERROR;
}
sub _subclassResponsibility {
Carp::croak("subclass Responsibility\n");
}
sub _binmode {
my $fh = shift;
return UNIVERSAL::can( $fh, 'binmode' ) ? $fh->binmode() : binmode($fh);
}
sub _isSeekable {
my $fh = shift;
if ( UNIVERSAL::isa( $fh, 'IO::Scalar' ) )
{
return 0;
}
elsif ( UNIVERSAL::isa( $fh, 'IO::String' ) )
{
return 1;
}
elsif ( UNIVERSAL::can( $fh, 'stat' ) )
{
return -f $fh;
}
return UNIVERSAL::can( $fh, 'seek' );
}
sub _newFileHandle {
my $fd = shift;
my $status = 1;
my $handle;
if ( ref($fd) )
{
if ( UNIVERSAL::isa( $fd, 'IO::Scalar' )
or UNIVERSAL::isa( $fd, 'IO::String' ) )
{
$handle = $fd;
}
elsif ( UNIVERSAL::isa( $fd, 'IO::Handle' )
or UNIVERSAL::isa( $fd, 'GLOB' ) )
{
$handle = IO::File->new();
$status = $handle->fdopen( $fd, @_ );
}
else
{
$handle = $fd;
}
}
else
{
$handle = IO::File->new();
$status = $handle->open( $fd, @_ );
}
return ( $status, $handle );
}
sub _readSignature {
my $fh = shift;
my $fileName = shift;
my $expectedSignature = shift;
my $signatureData;
my $bytesRead = $fh->read( $signatureData, SIGNATURE_LENGTH );
return _ioError("reading header signature")
if $bytesRead != SIGNATURE_LENGTH;
my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
my $status = AZ_OK;
if ( ( defined($expectedSignature) && $signature != $expectedSignature )
|| ( !defined($expectedSignature)
&& $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
&& $signature != LOCAL_FILE_HEADER_SIGNATURE
&& $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE ) )
{
my $errmsg = sprintf( "bad signature: 0x%08x", $signature );
if ( _isSeekable($fh) )
{
$errmsg .=
sprintf( " at offset %d", $fh->tell() - SIGNATURE_LENGTH );
}
$status = _formatError("$errmsg in file $fileName");
}
return ( $status, $signature );
}
BEGIN { $Archive::Zip::TempSequence = 0 }
sub tempFileName {
my $temp_dir = shift;
$temp_dir = ( -d '/tmp' ? '/tmp' : $ENV{TMPDIR} || $ENV{TEMP} || '.' )
unless defined($temp_dir);
unless ( -d $temp_dir )
{
mkdir( $temp_dir, 0777 )
or die "Can't create temp directory $temp_dir\: $!\n";
}
my $base_name =
sprintf( "%d-%d.%d", $$, time(), $Archive::Zip::TempSequence++ );
return File::Spec->canonpath(
File::Spec->catpath( '', $temp_dir, $base_name ) );
}
sub tempFile {
my $full_name = tempFileName(@_);
my $fh = IO::File->new( $full_name, '+>' );
return defined($fh) ? ( $fh, $full_name ) : ();
}
sub _asZipDirName {
my $name = shift;
my $forceDir = shift;
my $volReturn = shift;
my ( $volume, $directories, $file ) =
File::Spec->splitpath( File::Spec->canonpath($name), $forceDir );
$$volReturn = $volume if ( ref($volReturn) );
my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories);
if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } push ( @dirs, $file || '' );
return wantarray ? @dirs : join ( '/', @dirs );
}
sub _asLocalName {
my $name = shift; my $volume = shift;
$volume = '' unless defined($volume);
my @paths = split ( /\//, $name );
my $filename = pop (@paths);
$filename = '' unless defined($filename);
my $localDirs = File::Spec->catdir(@paths);
my $localName = File::Spec->catpath( $volume, $localDirs, $filename );
$localName = File::Spec->rel2abs($localName) unless $volume;
return $localName;
}
package Archive::Zip::Archive;
use File::Path;
use File::Find();
use File::Spec();
use File::Copy();
use File::Basename;
use Cwd;
use vars qw( @ISA );
@ISA = qw( Archive::Zip );
BEGIN
{
use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
:UTILITY_METHODS );
}
sub new {
my $class = shift;
my $self = bless( {
'diskNumber' => 0,
'diskNumberWithStartOfCentralDirectory' => 0,
'numberOfCentralDirectoriesOnThisDisk' => 0, 'numberOfCentralDirectories' => 0, 'centralDirectorySize' => 0, 'centralDirectoryOffsetWRTStartingDiskNumber' => 0, 'writeEOCDOffset' => 0,
'writeCentralDirectoryOffset' => 0,
'zipfileComment' => '',
'eocdOffset' => 0,
'fileName' => ''
},
$class
);
$self->{'members'} = [];
if (@_)
{
my $status = $self->read(@_);
return $status == AZ_OK ? $self : undef;
}
return $self;
}
sub members {
@{ shift->{'members'} };
}
sub numberOfMembers {
scalar( shift->members() );
}
sub memberNames {
my $self = shift;
return map { $_->fileName() } $self->members();
}
sub memberNamed {
my ( $self, $fileName ) = @_;
foreach my $member ( $self->members() )
{
return $member if $member->fileName() eq $fileName;
}
return undef;
}
sub membersMatching {
my ( $self, $pattern ) = @_;
return grep { $_->fileName() =~ /$pattern/ } $self->members();
}
sub diskNumber {
shift->{'diskNumber'};
}
sub diskNumberWithStartOfCentralDirectory {
shift->{'diskNumberWithStartOfCentralDirectory'};
}
sub numberOfCentralDirectoriesOnThisDisk {
shift->{'numberOfCentralDirectoriesOnThisDisk'};
}
sub numberOfCentralDirectories {
shift->{'numberOfCentralDirectories'};
}
sub centralDirectorySize {
shift->{'centralDirectorySize'};
}
sub centralDirectoryOffsetWRTStartingDiskNumber {
shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
}
sub zipfileComment {
my $self = shift;
my $comment = $self->{'zipfileComment'};
if (@_)
{
$self->{'zipfileComment'} = shift;
}
return $comment;
}
sub eocdOffset {
shift->{'eocdOffset'};
}
sub fileName {
shift->{'fileName'};
}
sub removeMember {
my ( $self, $member ) = @_;
$member = $self->memberNamed($member) unless ref($member);
return undef unless $member;
my @newMembers = grep { $_ != $member } $self->members();
$self->{'members'} = \@newMembers;
return $member;
}
sub replaceMember {
my ( $self, $oldMember, $newMember ) = @_;
$oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
return undef unless $oldMember;
return undef unless $newMember;
my @newMembers =
map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
$self->{'members'} = \@newMembers;
return $oldMember;
}
sub extractMember {
my $self = shift;
my $member = shift;
$member = $self->memberNamed($member) unless ref($member);
return _error('member not found') unless $member;
my $name = shift; my ( $volumeName, $dirName, $fileName );
if ( defined($name) )
{
( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
$dirName = File::Spec->catpath( $volumeName, $dirName, '' );
}
else
{
$name = $member->fileName();
( $dirName = $name ) =~ s{[^/]*$}{};
$dirName = Archive::Zip::_asLocalName($dirName);
$name = Archive::Zip::_asLocalName($name);
}
if ( $dirName && !-d $dirName )
{
mkpath($dirName);
return _ioError("can't create dir $dirName") if ( !-d $dirName );
}
return $member->extractToFileNamed( $name, @_ );
}
sub extractMemberWithoutPaths {
my $self = shift;
my $member = shift;
$member = $self->memberNamed($member) unless ref($member);
return _error('member not found') unless $member;
return AZ_OK if $member->isDirectory();
my $name = shift;
unless ($name)
{
$name = $member->fileName();
$name =~ s{.*/}{}; $name = Archive::Zip::_asLocalName($name);
}
return $member->extractToFileNamed( $name, @_ );
}
sub addMember {
my ( $self, $newMember ) = @_;
push ( @{ $self->{'members'} }, $newMember ) if $newMember;
return $newMember;
}
sub addFile {
my $self = shift;
my $fileName = shift;
my $newName = shift;
my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
$self->addMember($newMember) if defined($newMember);
return $newMember;
}
sub addString {
my $self = shift;
my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
return $self->addMember($newMember);
}
sub addDirectory {
my ( $self, $name, $newName ) = @_;
my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
$self->addMember($newMember);
return $newMember;
}
sub addFileOrDirectory
{
my ( $self, $name, $newName ) = @_;
if ( -f $name )
{
( $newName =~ s{/$}{} ) if $newName;
return $self->addFile( $name, $newName );
}
elsif ( -d $name )
{
( $newName =~ s{[^/]$}{&/} ) if $newName;
return $self->addDirectory( $name, $newName );
}
else
{
return _error("$name is neither a file nor a directory");
}
}
sub contents {
my ( $self, $member, $newContents ) = @_;
$member = $self->memberNamed($member) unless ref($member);
return undef unless $member;
return $member->contents($newContents);
}
sub writeToFileNamed {
my $self = shift;
my $fileName = shift; foreach my $member ( $self->members() )
{
if ( $member->_usesFileNamed($fileName) )
{
return _error( "$fileName is needed by member "
. $member->fileName()
. "; consider using overwrite() or overwriteAs() instead." );
}
}
my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
return _ioError("Can't open $fileName for write") unless $status;
my $retval = $self->writeToFileHandle( $fh, 1 );
$fh->close();
return $retval;
}
sub writeToFileHandle {
my $self = shift;
my $fh = shift;
my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
_binmode($fh);
my $offset = $fhIsSeekable ? $fh->tell() : 0;
$offset = 0 if $offset < 0;
foreach my $member ( $self->members() )
{
my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
$member->endRead();
return $retval if $retval != AZ_OK;
$offset += $member->_localHeaderSize() + $member->_writeOffset();
$offset += $member->hasDataDescriptor() ? DATA_DESCRIPTOR_LENGTH: 0;
$self->{'writeCentralDirectoryOffset'} = $offset;
}
return $self->writeCentralDirectory($fh);
}
sub overwrite {
my $self = shift;
return $self->overwriteAs( $self->{'fileName'} );
}
sub overwriteAs {
my $self = shift;
my $zipName = shift;
return _error("no filename in overwriteAs()") unless defined($zipName);
my ( $fh, $tempName ) = Archive::Zip::tempFile();
return _error( "Can't open temp file", $! ) unless $fh;
( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
my $status;
if ( ( $status = $self->writeToFileHandle($fh) ) == AZ_OK )
{
my $err;
$fh->close();
if ( -f $zipName && !rename( $zipName, $backupName ) )
{
$err = $!;
unlink($tempName);
return _error( "Can't rename $zipName as $backupName", $err );
}
unless ( File::Copy::move( $tempName, $zipName ) )
{
$err = $!;
rename( $backupName, $zipName );
unlink($tempName);
return _error( "Can't move $tempName to $zipName", $err );
}
if ( -f $backupName && !unlink($backupName) )
{
$err = $!;
return _error( "Can't unlink $backupName", $err );
}
return AZ_OK;
}
else
{
$fh->close();
unlink($tempName);
_printError("Can't write to $tempName");
return $status;
}
}
sub _writeCentralDirectoryOffset {
shift->{'writeCentralDirectoryOffset'};
}
sub _writeEOCDOffset {
shift->{'writeEOCDOffset'};
}
sub _writeEndOfCentralDirectory {
my ( $self, $fh ) = @_;
$fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
or return _ioError('writing EOCD Signature');
my $zipfileCommentLength = length( $self->zipfileComment() );
my $header = pack(
END_OF_CENTRAL_DIRECTORY_FORMAT,
0, 0, $self->numberOfMembers(), $self->numberOfMembers(), $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
$self->_writeCentralDirectoryOffset(),
$zipfileCommentLength
);
$fh->print($header)
or return _ioError('writing EOCD header');
if ($zipfileCommentLength)
{
$fh->print( $self->zipfileComment() )
or return _ioError('writing zipfile comment');
}
return AZ_OK;
}
sub writeCentralDirectory {
my ( $self, $fh, $offset ) = @_;
if ( defined($offset) )
{
$self->{'writeCentralDirectoryOffset'} = $offset;
$fh->seek( $offset, IO::Seekable::SEEK_SET )
or return _ioError('seeking to write central directory');
}
else
{
$offset = $self->_writeCentralDirectoryOffset();
}
foreach my $member ( $self->members() )
{
my $status = $member->_writeCentralDirectoryFileHeader($fh);
return $status if $status != AZ_OK;
$offset += $member->_centralDirectoryHeaderSize();
$self->{'writeEOCDOffset'} = $offset;
}
return $self->_writeEndOfCentralDirectory($fh);
}
sub read {
my $self = shift;
my $fileName = shift;
return _error('No filename given') unless $fileName;
my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
return _ioError("opening $fileName for read") unless $status;
$status = $self->readFromFileHandle( $fh, $fileName );
return $status if $status != AZ_OK;
$fh->close();
$self->{'fileName'} = $fileName;
return AZ_OK;
}
sub readFromFileHandle {
my $self = shift;
my $fh = shift;
my $fileName = shift;
$fileName = $fh unless defined($fileName);
return _error('No filehandle given') unless $fh;
return _ioError('filehandle not open') unless $fh->opened();
$fh->seek( 0, 0 ); _binmode($fh);
my $status = $self->_findEndOfCentralDirectory($fh);
return $status if $status != AZ_OK;
my $eocdPosition = $fh->tell();
$status = $self->_readEndOfCentralDirectory($fh);
return $status if $status != AZ_OK;
$fh->seek( $eocdPosition - $self->centralDirectorySize(),
IO::Seekable::SEEK_SET )
or return _ioError("Can't seek $fileName");
$self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() - $self->centralDirectoryOffsetWRTStartingDiskNumber();
for ( ; ; )
{
my $newMember =
$self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
$self->eocdOffset() );
my $signature;
( $status, $signature ) = _readSignature( $fh, $fileName );
return $status if $status != AZ_OK;
last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
$status = $newMember->_readCentralDirectoryFileHeader();
return $status if $status != AZ_OK;
$status = $newMember->endRead();
return $status if $status != AZ_OK;
$newMember->_becomeDirectoryIfNecessary();
push ( @{ $self->{'members'} }, $newMember );
}
$self->{'fileName'} = "$fh";
return AZ_OK;
}
sub _readEndOfCentralDirectory {
my $self = shift;
my $fh = shift;
$fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
or return _ioError("Can't seek past EOCD signature");
my $header = '';
my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH )
{
return _ioError("reading end of central directory");
}
my $zipfileCommentLength;
( $self->{'diskNumber'},
$self->{'diskNumberWithStartOfCentralDirectory'},
$self->{'numberOfCentralDirectoriesOnThisDisk'},
$self->{'numberOfCentralDirectories'},
$self->{'centralDirectorySize'},
$self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
$zipfileCommentLength )
= unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
if ($zipfileCommentLength)
{
my $zipfileComment = '';
$bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
if ( $bytesRead != $zipfileCommentLength )
{
return _ioError("reading zipfile comment");
}
$self->{'zipfileComment'} = $zipfileComment;
}
return AZ_OK;
}
sub _findEndOfCentralDirectory {
my $self = shift;
my $fh = shift;
my $data = '';
$fh->seek( 0, IO::Seekable::SEEK_END )
or return _ioError("seeking to end");
my $fileLength = $fh->tell();
if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 )
{
return _formatError("file is too short");
}
my $seekOffset = 0;
my $pos = -1;
for ( ; ; )
{
$seekOffset += 512;
$seekOffset = $fileLength if ( $seekOffset > $fileLength );
$fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
or return _ioError("seek failed");
my $bytesRead = $fh->read( $data, $seekOffset );
if ( $bytesRead != $seekOffset )
{
return _ioError("read failed");
}
$pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
last
if ( $pos >= 0
or $seekOffset == $fileLength
or $seekOffset >= $Archive::Zip::ChunkSize );
}
if ( $pos >= 0 )
{
$fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
or return _ioError("seeking to EOCD");
return AZ_OK;
}
else
{
return _formatError("can't find EOCD signature");
}
}
sub addTree {
my $self = shift;
my $root = shift or return _error("root arg missing in call to addTree()");
my $dest = shift;
$dest = '' unless defined($dest);
my $pred = shift || sub { -r };
my @files;
my $startDir = cwd();
my $wanted = sub {
local $main::_ = $File::Find::name;
my $dir = $File::Find::dir;
chdir($startDir);
push ( @files, $File::Find::name ) if (&$pred);
chdir($dir);
};
File::Find::find( $wanted, $root );
my $rootZipName = _asZipDirName( $root, 1 ); my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
$dest = _asZipDirName( $dest, 1 );
foreach my $fileName (@files)
{
my $isDir = -d $fileName;
my $archiveName = _asZipDirName( $fileName, $isDir );
if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
else { $archiveName =~ s{$pattern}{$dest} }
next if $archiveName =~ m{^\.?/?$}; my $member =
$isDir
? $self->addDirectory( $fileName, $archiveName )
: $self->addFile( $fileName, $archiveName );
return _error("add $fileName failed in addTree()") if !$member;
}
return AZ_OK;
}
sub addTreeMatching {
my $self = shift;
my $root = shift
or return _error("root arg missing in call to addTreeMatching()");
my $dest = shift;
$dest = '' unless defined($dest);
my $pattern = shift
or return _error("pattern missing in call to addTreeMatching()");
my $pred = shift;
my $matcher =
$pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
return $self->addTree( $root, $dest, $matcher );
}
sub extractTree {
my $self = shift;
my $root = shift; $root = '' unless defined($root);
my $dest = shift; $dest = './' unless defined($dest);
my $volume = shift; my $pattern = "^\Q$root";
my @members = $self->membersMatching($pattern);
foreach my $member (@members)
{
my $fileName = $member->fileName(); $fileName =~ s{$pattern}{$dest}; $fileName = Archive::Zip::_asLocalName( $fileName, $volume );
my $status = $member->extractToFileNamed($fileName);
return $status if $status != AZ_OK;
}
return AZ_OK;
}
sub updateMember {
my $self = shift;
my $oldMember = shift;
my $fileName = shift;
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] ) ) )
{
my $newMember = $isDir
? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
: $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
unless ( defined($newMember) )
{
_error("creation of member $fileName failed in updateMember()");
return undef;
}
if ( defined($oldMember) )
{
$self->replaceMember( $oldMember, $newMember );
}
else { $self->addMember($newMember); }
return $newMember;
}
return $oldMember;
}
sub updateTree {
my $self = shift;
my $root = shift
or return _error("root arg missing in call to updateTree()");
my $dest = shift;
$dest = '' unless defined($dest);
$dest = _asZipDirName( $dest, 1 );
my $pred = shift || sub { -r };
my $mirror = shift;
my $rootZipName = _asZipDirName( $root, 1 ); my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
my $startDir = cwd();
my @files;
my $wanted = sub {
local $main::_ = $File::Find::name;
my $dir = $File::Find::dir;
chdir($startDir);
push ( @files, $File::Find::name ) if (&$pred);
chdir($dir);
};
File::Find::find( $wanted, $root );
my %done;
foreach my $fileName (@files)
{
my @newStat = stat($fileName);
my $isDir = -d _;
my $memberName = _asZipDirName( $fileName, $isDir );
if ( $memberName eq $rootZipName ) { $memberName = $dest }
else { $memberName =~ s{$pattern}{$dest} }
next if $memberName =~ m{^\.?/?$};
$done{$memberName} = 1;
my $changedMember = $self->updateMember( $memberName, $fileName );
return _error("updateTree failed to update $fileName")
unless ref($changedMember);
}
if ($mirror)
{
foreach my $member ( $self->members() )
{
$self->removeMember($member)
unless $done{ $member->fileName() };
}
}
return AZ_OK;
}
package Archive::Zip::Member;
use vars qw( @ISA );
@ISA = qw ( Archive::Zip );
BEGIN
{
use Archive::Zip qw( :CONSTANTS :MISC_CONSTANTS :ERROR_CODES
:PKZIP_CONSTANTS :UTILITY_METHODS );
}
use Time::Local();
use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
use File::Path;
use File::Basename;
use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember';
use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember';
use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember';
use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember';
use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
use constant DEFAULT_FILE_PERMISSIONS => 0100666;
use constant DIRECTORY_ATTRIB => 040000;
use constant FILE_ATTRIB => 0100000;
sub _newFromZipFile {
my $class = shift;
my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
return $self;
}
sub newFromString {
my $class = shift;
my $self = $class->STRINGMEMBERCLASS->_newFromString(@_);
return $self;
}
sub newFromFile {
my $class = shift;
my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
return $self;
}
sub newDirectoryNamed {
my $class = shift;
my $self = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
return $self;
}
sub new {
my $class = shift;
my $self = {
'lastModFileDateTime' => 0,
'fileAttributeFormat' => FA_UNIX,
'versionMadeBy' => 20,
'versionNeededToExtract' => 20,
'bitFlag' => 0,
'compressionMethod' => COMPRESSION_STORED,
'desiredCompressionMethod' => COMPRESSION_STORED,
'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
'internalFileAttributes' => 0,
'externalFileAttributes' => 0, 'fileName' => '',
'cdExtraField' => '',
'localExtraField' => '',
'fileComment' => '',
'crc32' => 0,
'compressedSize' => 0,
'uncompressedSize' => 0,
@_
};
bless( $self, $class );
$self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
return $self;
}
sub _becomeDirectoryIfNecessary {
my $self = shift;
$self->_become(DIRECTORYMEMBERCLASS)
if $self->isDirectory();
return $self;
}
sub _become {
return bless( $_[0], $_[1] );
}
sub versionMadeBy {
shift->{'versionMadeBy'};
}
sub fileAttributeFormat {
( $ ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
: $_[0]->{'fileAttributeFormat'};
}
sub versionNeededToExtract {
shift->{'versionNeededToExtract'};
}
sub bitFlag {
shift->{'bitFlag'};
}
sub compressionMethod {
shift->{'compressionMethod'};
}
sub desiredCompressionMethod {
my $self = shift;
my $newDesiredCompressionMethod = shift;
my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
if ( defined($newDesiredCompressionMethod) )
{
$self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
if ( $newDesiredCompressionMethod == COMPRESSION_STORED )
{
$self->{'desiredCompressionLevel'} = 0;
}
elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED )
{
$self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
}
}
return $oldDesiredCompressionMethod;
}
sub desiredCompressionLevel {
my $self = shift;
my $newDesiredCompressionLevel = shift;
my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
if ( defined($newDesiredCompressionLevel) )
{
$self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
$self->{'desiredCompressionMethod'} =
( $newDesiredCompressionLevel
? COMPRESSION_DEFLATED
: COMPRESSION_STORED );
}
return $oldDesiredCompressionLevel;
}
sub fileName {
my $self = shift;
my $newName = shift;
if ($newName)
{
$newName =~ s{[\\/]+}{/}g; $self->{'fileName'} = $newName;
}
return $self->{'fileName'};
}
sub lastModFileDateTime {
my $modTime = shift->{'lastModFileDateTime'};
$modTime =~ m/^(\d+)$/; return $1;
}
sub lastModTime {
my $self = shift;
return _dosToUnixTime( $self->lastModFileDateTime() );
}
sub setLastModFileDateTimeFromUnix {
my $self = shift;
my $time_t = shift;
$self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
}
sub _dosToUnixTime {
my $dt = shift;
return time() unless defined($dt);
my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
my $mday = ( ( $dt >> 16 ) & 0x1f );
my $hour = ( ( $dt >> 11 ) & 0x1f );
my $min = ( ( $dt >> 5 ) & 0x3f );
my $sec = ( ( $dt << 1 ) & 0x3e );
my $time_t =
eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
return time() if ($@);
return $time_t;
}
sub internalFileAttributes {
shift->{'internalFileAttributes'};
}
sub externalFileAttributes {
shift->{'externalFileAttributes'};
}
sub _mapPermissionsFromUnix {
my $perms = shift;
return $perms << 16;
}
sub _mapPermissionsToUnix {
my $self = shift;
my $format = $self->{'fileAttributeFormat'};
my $attribs = $self->{'externalFileAttributes'};
my $mode = 0;
if ( $format == FA_AMIGA )
{
$attribs = $attribs >> 17 & 7; $mode = $attribs << 6 | $attribs << 3 | $attribs;
return $mode;
}
if ( $format == FA_THEOS )
{
$attribs &= 0xF1FFFFFF;
if ( ( $attribs & 0xF0000000 ) != 0x40000000 )
{
$attribs &= 0x01FFFFFF; }
else
{
$attribs &= 0x41FFFFFF; }
}
if ( $format == FA_UNIX
|| $format == FA_VAX_VMS
|| $format == FA_ACORN
|| $format == FA_ATARI_ST
|| $format == FA_BEOS
|| $format == FA_QDOS
|| $format == FA_TANDEM )
{
$mode = $attribs >> 16;
return $mode if $mode != 0 or not $self->localExtraField;
}
if ( $format == FA_MSDOS )
{
$mode = $attribs >> 16;
}
$attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 );
$mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
return $mode;
}
sub unixFileAttributes {
my $self = shift;
my $oldPerms = $self->_mapPermissionsToUnix();
if (@_)
{
my $perms = shift;
if ( $self->isDirectory() )
{
$perms &= ~FILE_ATTRIB;
$perms |= DIRECTORY_ATTRIB;
}
else
{
$perms &= ~DIRECTORY_ATTRIB;
$perms |= FILE_ATTRIB;
}
$self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
}
return $oldPerms;
}
sub localExtraField {
( $ ? ( $_[0]->{'localExtraField'} = $_[1] )
: $_[0]->{'localExtraField'};
}
sub cdExtraField {
( $}
sub extraFields {
my $self = shift;
return $self->localExtraField() . $self->cdExtraField();
}
sub fileComment {
( $}
sub hasDataDescriptor {
my $self = shift;
if (@_)
{
my $shouldHave = shift;
if ($shouldHave)
{
$self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
}
else
{
$self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
}
}
return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
}
sub crc32 {
shift->{'crc32'};
}
sub crc32String {
sprintf( "%08x", shift->{'crc32'} );
}
sub compressedSize {
shift->{'compressedSize'};
}
sub uncompressedSize {
shift->{'uncompressedSize'};
}
sub isEncrypted {
shift->bitFlag() & GPBF_ENCRYPTED_MASK;
}
sub isTextFile {
my $self = shift;
my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
if (@_)
{
my $flag = shift;
$self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
$self->{'internalFileAttributes'} |=
( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
}
return $bit == IFA_TEXT_FILE;
}
sub isBinaryFile {
my $self = shift;
my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
if (@_)
{
my $flag = shift;
$self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
$self->{'internalFileAttributes'} |=
( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE );
}
return $bit == IFA_BINARY_FILE;
}
sub extractToFileNamed {
my $self = shift;
my $name = shift; return _error("encryption unsupported") if $self->isEncrypted();
mkpath( dirname($name) ); my ( $status, $fh ) = _newFileHandle( $name, 'w' );
return _ioError("Can't open file $name for write") unless $status;
my $retval = $self->extractToFileHandle($fh);
$fh->close();
utime( $self->lastModTime(), $self->lastModTime(), $name );
return $retval;
}
sub isDirectory {
return 0;
}
sub externalFileName {
return undef;
}
sub _writeOffset {
shift->{'writeOffset'};
}
sub _readOffset {
shift->{'readOffset'};
}
sub writeLocalHeaderRelativeOffset {
shift->{'writeLocalHeaderRelativeOffset'};
}
sub wasWritten { shift->{'wasWritten'} }
sub _dataEnded {
shift->{'dataEnded'};
}
sub _readDataRemaining {
shift->{'readDataRemaining'};
}
sub _inflater {
shift->{'inflater'};
}
sub _deflater {
shift->{'deflater'};
}
sub _localHeaderSize {
my $self = shift;
return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH +
length( $self->fileName() ) + length( $self->localExtraField() );
}
sub _centralDirectoryHeaderSize {
my $self = shift;
return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
length( $self->fileName() ) + length( $self->cdExtraField() ) +
length( $self->fileComment() );
}
sub _unixToDosTime {
my $time_t = shift;
my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
my $dt = 0;
$dt += ( $sec >> 1 );
$dt += ( $min << 5 );
$dt += ( $hour << 11 );
$dt += ( $mday << 16 );
$dt += ( ( $mon + 1 ) << 21 );
$dt += ( ( $year - 80 ) << 25 );
return $dt;
}
sub _writeLocalFileHeader {
my $self = shift;
my $fh = shift;
my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
$fh->print($signatureData)
or return _ioError("writing local header signature");
my $header = pack(
LOCAL_FILE_HEADER_FORMAT,
$self->versionNeededToExtract(),
$self->bitFlag(),
$self->desiredCompressionMethod(),
$self->lastModFileDateTime(),
$self->crc32(),
$self->compressedSize(), $self->uncompressedSize(),
length( $self->fileName() ),
length( $self->localExtraField() )
);
$fh->print($header) or return _ioError("writing local header");
if ( $self->fileName() )
{
$fh->print( $self->fileName() )
or return _ioError("writing local header filename");
}
if ( $self->localExtraField() )
{
$fh->print( $self->localExtraField() )
or return _ioError("writing local extra field");
}
return AZ_OK;
}
sub _writeCentralDirectoryFileHeader {
my $self = shift;
my $fh = shift;
my $sigData =
pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
$fh->print($sigData)
or return _ioError("writing central directory header signature");
my $fileNameLength = length( $self->fileName() );
my $extraFieldLength = length( $self->cdExtraField() );
my $fileCommentLength = length( $self->fileComment() );
my $header = pack(
CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
$self->versionMadeBy(),
$self->fileAttributeFormat(),
$self->versionNeededToExtract(),
$self->bitFlag(),
$self->desiredCompressionMethod(),
$self->lastModFileDateTime(),
$self->crc32(), $self->_writeOffset(), $self->uncompressedSize(), $fileNameLength,
$extraFieldLength,
$fileCommentLength,
0, $self->internalFileAttributes(),
$self->externalFileAttributes(),
$self->writeLocalHeaderRelativeOffset()
);
$fh->print($header)
or return _ioError("writing central directory header");
if ($fileNameLength)
{
$fh->print( $self->fileName() )
or return _ioError("writing central directory header signature");
}
if ($extraFieldLength)
{
$fh->print( $self->cdExtraField() )
or return _ioError("writing central directory extra field");
}
if ($fileCommentLength)
{
$fh->print( $self->fileComment() )
or return _ioError("writing central directory file comment");
}
return AZ_OK;
}
sub _writeDataDescriptor {
my $self = shift;
my $fh = shift;
my $header = pack(
DATA_DESCRIPTOR_FORMAT,
$self->crc32(),
$self->_writeOffset(), $self->uncompressedSize()
);
$fh->print($header)
or return _ioError("writing data descriptor");
return AZ_OK;
}
sub _refreshLocalFileHeader {
my $self = shift;
my $fh = shift;
my $here = $fh->tell();
$fh->seek( $self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH,
IO::Seekable::SEEK_SET )
or return _ioError("seeking to rewrite local header");
my $header = pack(
LOCAL_FILE_HEADER_FORMAT,
$self->versionNeededToExtract(),
$self->bitFlag(),
$self->desiredCompressionMethod(),
$self->lastModFileDateTime(),
$self->crc32(),
$self->_writeOffset(), $self->uncompressedSize(),
length( $self->fileName() ),
length( $self->localExtraField() )
);
$fh->print($header)
or return _ioError("re-writing local header");
$fh->seek( $here, IO::Seekable::SEEK_SET )
or return _ioError("seeking after rewrite of local header");
return AZ_OK;
}
sub readChunk {
my ( $self, $chunkSize ) = @_;
if ( $self->readIsDone() )
{
$self->endRead();
my $dummy = '';
return ( \$dummy, AZ_STREAM_END );
}
$chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
$chunkSize = $self->_readDataRemaining()
if $chunkSize > $self->_readDataRemaining();
my $buffer = '';
my $outputRef;
my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
return ( \$buffer, $status ) unless $status == AZ_OK;
$self->{'readDataRemaining'} -= $bytesRead;
$self->{'readOffset'} += $bytesRead;
if ( $self->compressionMethod() == COMPRESSION_STORED )
{
$self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
}
( $outputRef, $status ) = &{ $self->{'chunkHandler'} } ( $self, \$buffer );
$self->{'writeOffset'} += length($$outputRef);
$self->endRead()
if $self->readIsDone();
return ( $outputRef, $status );
}
sub _readRawChunk {
my $self = shift;
return $self->_subclassResponsibility();
}
sub _noChunk {
my $self = shift;
return ( \undef, _error("trying to copy chunk when init failed") );
}
sub _copyChunk {
my ( $self, $dataRef ) = @_;
return ( $dataRef, AZ_OK );
}
sub _deflateChunk {
my ( $self, $buffer ) = @_;
my ( $out, $status ) = $self->_deflater()->deflate($buffer);
if ( $self->_readDataRemaining() == 0 )
{
my $extraOutput;
( $extraOutput, $status ) = $self->_deflater()->flush();
$out .= $extraOutput;
$self->endRead();
return ( \$out, AZ_STREAM_END );
}
elsif ( $status == Z_OK )
{
return ( \$out, AZ_OK );
}
else
{
$self->endRead();
my $retval = _error( 'deflate error', $status );
my $dummy = '';
return ( \$dummy, $retval );
}
}
sub _inflateChunk {
my ( $self, $buffer ) = @_;
my ( $out, $status ) = $self->_inflater()->inflate($buffer);
my $retval;
$self->endRead() unless $status == Z_OK;
if ( $status == Z_OK || $status == Z_STREAM_END )
{
$retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK;
return ( \$out, $retval );
}
else
{
$retval = _error( 'inflate error', $status );
my $dummy = '';
return ( \$dummy, $retval );
}
}
sub rewindData {
my $self = shift;
my $status;
$self->{'chunkHandler'} = $self->can('_noChunk');
$self->desiredCompressionMethod(COMPRESSION_STORED)
if $self->uncompressedSize() == 0;
$self->{'crc32'} = 0
if ( $self->compressionMethod() == COMPRESSION_STORED );
if ( $self->compressionMethod() == COMPRESSION_STORED
and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
{
( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
'-Level' => $self->desiredCompressionLevel(),
'-WindowBits' => -MAX_WBITS(), '-Bufsize' => $Archive::Zip::ChunkSize,
@_
); return _error( 'deflateInit error:', $status )
unless $status == Z_OK;
$self->{'chunkHandler'} = $self->can('_deflateChunk');
}
elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
and $self->desiredCompressionMethod() == COMPRESSION_STORED )
{
( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
'-WindowBits' => -MAX_WBITS(), '-Bufsize' => $Archive::Zip::ChunkSize,
@_
); return _error( 'inflateInit error:', $status )
unless $status == Z_OK;
$self->{'chunkHandler'} = $self->can('_inflateChunk');
}
elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() )
{
$self->{'chunkHandler'} = $self->can('_copyChunk');
}
else
{
return _error(
sprintf(
"Unsupported compression combination: read %d, write %d",
$self->compressionMethod(),
$self->desiredCompressionMethod()
)
);
}
$self->{'readDataRemaining'} =
( $self->compressionMethod() == COMPRESSION_STORED )
? $self->uncompressedSize()
: $self->compressedSize();
$self->{'dataEnded'} = 0;
$self->{'readOffset'} = 0;
return AZ_OK;
}
sub endRead {
my $self = shift;
delete $self->{'inflater'};
delete $self->{'deflater'};
$self->{'dataEnded'} = 1;
$self->{'readDataRemaining'} = 0;
return AZ_OK;
}
sub readIsDone {
my $self = shift;
return ( $self->_dataEnded() or !$self->_readDataRemaining() );
}
sub contents {
my $self = shift;
my $newContents = shift;
if ( defined($newContents) )
{
$self->_become(STRINGMEMBERCLASS);
return $self->contents($newContents);
}
else
{
my $oldCompression =
$self->desiredCompressionMethod(COMPRESSION_STORED);
my $status = $self->rewindData(@_);
if ( $status != AZ_OK )
{
$self->endRead();
return $status;
}
my $retval = '';
while ( $status == AZ_OK )
{
my $ref;
( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
if ( length($$ref) == $self->uncompressedSize() )
{
$retval = $$ref;
}
else { $retval .= $$ref }
}
$self->desiredCompressionMethod($oldCompression);
$self->endRead();
$status = AZ_OK if $status == AZ_STREAM_END;
$retval = undef unless $status == AZ_OK;
return wantarray ? ( $retval, $status ) : $retval;
}
}
sub extractToFileHandle {
my $self = shift;
return _error("encryption unsupported") if $self->isEncrypted();
my $fh = shift;
_binmode($fh);
my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
my $status = $self->rewindData(@_);
$status = $self->_writeData($fh) if $status == AZ_OK;
$self->desiredCompressionMethod($oldCompression);
$self->endRead();
return $status;
}
sub _writeToFileHandle {
my $self = shift;
my $fh = shift;
my $fhIsSeekable = shift;
my $offset = shift;
return _error("no member name given for $self")
unless $self->fileName();
$self->{'writeLocalHeaderRelativeOffset'} = $offset;
$self->{'wasWritten'} = 0;
my $headerFieldsUnknown =
( ( $self->uncompressedSize() > 0 )
and ( $self->compressionMethod() == COMPRESSION_STORED
or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) );
my $shouldWriteDataDescriptor =
( $headerFieldsUnknown and not $fhIsSeekable );
$self->hasDataDescriptor(1)
if ($shouldWriteDataDescriptor);
$self->{'writeOffset'} = 0;
my $status = $self->rewindData();
( $status = $self->_writeLocalFileHeader($fh) )
if $status == AZ_OK;
( $status = $self->_writeData($fh) )
if $status == AZ_OK;
if ( $status == AZ_OK )
{
$self->{'wasWritten'} = 1;
if ( $self->hasDataDescriptor() )
{
$status = $self->_writeDataDescriptor($fh);
}
elsif ($headerFieldsUnknown)
{
$status = $self->_refreshLocalFileHeader($fh);
}
}
return $status;
}
sub _writeData {
my $self = shift;
my $writeFh = shift;
return AZ_OK if ( $self->uncompressedSize() == 0 );
my $status;
my $chunkSize = $Archive::Zip::ChunkSize;
while ( $self->_readDataRemaining() > 0 )
{
my $outRef;
( $outRef, $status ) = $self->readChunk($chunkSize);
return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
if ( length($$outRef) > 0 )
{
$writeFh->print($$outRef)
or return _ioError("write error during copy");
}
last if $status == AZ_STREAM_END;
}
$self->{'compressedSize'} = $self->_writeOffset();
return AZ_OK;
}
sub _usesFileNamed
{
return 0;
}
package Archive::Zip::DirectoryMember;
use File::Path;
use vars qw( @ISA );
@ISA = qw ( Archive::Zip::Member );
BEGIN { use Archive::Zip qw( :ERROR_CODES :UTILITY_METHODS ) }
sub _newNamed {
my $class = shift;
my $fileName = shift; my $newName = shift; $newName = _asZipDirName($fileName) unless $newName;
my $self = $class->new(@_);
$self->{'externalFileName'} = $fileName;
$self->fileName($newName);
if ( -e $fileName )
{
if ( -d _ )
{
my @stat = stat(_);
$self->unixFileAttributes( $stat[2] );
$self->setLastModFileDateTimeFromUnix( $stat[9] );
}
else {
_error( $fileName, ' exists but is not a directory' );
return undef;
}
}
else
{
$self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS );
$self->setLastModFileDateTimeFromUnix( time() );
}
return $self;
}
sub externalFileName {
shift->{'externalFileName'};
}
sub isDirectory {
return 1;
}
sub extractToFileNamed {
my $self = shift;
my $name = shift; my $attribs = $self->unixFileAttributes() & 07777;
mkpath( $name, 0, $attribs ); utime( $self->lastModTime(), $self->lastModTime(), $name );
return AZ_OK;
}
sub fileName {
my $self = shift;
my $newName = shift;
$newName =~ s{/?$}{/} if defined($newName);
return $self->SUPER::fileName($newName);
}
sub contents
{
undef;
}
package Archive::Zip::FileMember;
use vars qw( @ISA );
@ISA = qw ( Archive::Zip::Member );
BEGIN { use Archive::Zip qw( :UTILITY_METHODS ) }
sub externalFileName {
shift->{'externalFileName'};
}
sub _usesFileNamed {
my $self = shift;
my $fileName = shift;
my $xfn = $self->externalFileName();
return undef if ref($xfn);
return $xfn eq $fileName;
}
sub fh {
my $self = shift;
$self->_openFile()
if !defined( $self->{'fh'} ) || !$self->{'fh'}->opened();
return $self->{'fh'};
}
sub _openFile {
my $self = shift;
my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' );
if ( !$status )
{
_ioError( "Can't open", $self->externalFileName() );
return undef;
}
$self->{'fh'} = $fh;
_binmode($fh);
return $fh;
}
sub _closeFile {
my $self = shift;
my $fh = $self->{'fh'};
$self->{'fh'} = undef;
}
sub endRead {
my $self = shift;
$self->_closeFile();
return $self->SUPER::endRead(@_);
}
sub _become {
my $self = shift;
my $newClass = shift;
return $self if ref($self) eq $newClass;
delete( $self->{'externalFileName'} );
delete( $self->{'fh'} );
return $self->SUPER::_become($newClass);
}
package Archive::Zip::NewFileMember;
use vars qw( @ISA );
@ISA = qw ( Archive::Zip::FileMember );
BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :UTILITY_METHODS ) }
sub _newFromFileNamed {
my $class = shift;
my $fileName = shift; my $newName = shift;
$newName = _asZipDirName($fileName) unless defined($newName);
return undef unless ( stat($fileName) && -r _ && !-d _ );
my $self = $class->new(@_);
$self->fileName($newName);
$self->{'externalFileName'} = $fileName;
$self->{'compressionMethod'} = COMPRESSION_STORED;
my @stat = stat(_);
$self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7];
$self->desiredCompressionMethod( ( $self->compressedSize() > 0 )
? COMPRESSION_DEFLATED
: COMPRESSION_STORED );
$self->unixFileAttributes( $stat[2] );
$self->setLastModFileDateTimeFromUnix( $stat[9] );
$self->isTextFile( -T _ );
return $self;
}
sub rewindData {
my $self = shift;
my $status = $self->SUPER::rewindData(@_);
return $status unless $status == AZ_OK;
return AZ_IO_ERROR unless $self->fh();
$self->fh()->clearerr();
$self->fh()->seek( 0, IO::Seekable::SEEK_SET )
or return _ioError( "rewinding", $self->externalFileName() );
return AZ_OK;
}
sub _readRawChunk {
my ( $self, $dataRef, $chunkSize ) = @_;
return ( 0, AZ_OK ) unless $chunkSize;
my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
or return ( 0, _ioError("reading data") );
return ( $bytesRead, AZ_OK );
}
sub extractToFileNamed {
my $self = shift;
my $name = shift; if ( File::Spec->rel2abs($name) eq
File::Spec->rel2abs( $self->externalFileName() ) and -r $name )
{
return AZ_OK;
}
else
{
return $self->SUPER::extractToFileNamed( $name, @_ );
}
}
package Archive::Zip::ZipFileMember;
use vars qw( @ISA );
@ISA = qw ( Archive::Zip::FileMember );
BEGIN
{
use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
:UTILITY_METHODS );
}
sub _newFromZipFile {
my $class = shift;
my $fh = shift;
my $externalFileName = shift;
my $possibleEocdOffset = shift;
my $self = $class->new(
'crc32' => 0,
'diskNumberStart' => 0,
'localHeaderRelativeOffset' => 0,
'dataOffset' => 0, @_
);
$self->{'externalFileName'} = $externalFileName;
$self->{'fh'} = $fh;
$self->{'possibleEocdOffset'} = $possibleEocdOffset;
return $self;
}
sub isDirectory {
my $self = shift;
return ( substr( $self->fileName(), -1, 1 ) eq '/'
and $self->uncompressedSize() == 0 );
}
sub _seekToLocalHeader {
my $self = shift;
my $where = shift;
$where = $self->localHeaderRelativeOffset() unless defined($where);
my $status;
my $signature;
$status = $self->fh()->seek( $where, IO::Seekable::SEEK_SET );
return _ioError("seeking to local header") unless $status;
( $status, $signature ) =
_readSignature( $self->fh(), $self->externalFileName(),
LOCAL_FILE_HEADER_SIGNATURE );
return $status if $status == AZ_IO_ERROR;
if ( $status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'} )
{
$status =
$self->_seekToLocalHeader( $self->localHeaderRelativeOffset() +
$self->{'possibleEocdOffset'} );
if ( $status == AZ_OK )
{
$self->{'localHeaderRelativeOffset'} +=
$self->{'possibleEocdOffset'};
$self->{'possibleEocdOffset'} = 0;
}
}
return $status;
}
sub _become {
my $self = shift;
my $newClass = shift;
return $self if ref($self) eq $newClass;
my $status = AZ_OK;
if ( _isSeekable( $self->fh() ) )
{
my $here = $self->fh()->tell();
$status = $self->_seekToLocalHeader();
$status = $self->_readLocalFileHeader() if $status == AZ_OK;
$self->fh()->seek( $here, IO::Seekable::SEEK_SET );
return $status unless $status == AZ_OK;
}
delete( $self->{'diskNumberStart'} );
delete( $self->{'localHeaderRelativeOffset'} );
delete( $self->{'dataOffset'} );
return $self->SUPER::_become($newClass);
}
sub diskNumberStart {
shift->{'diskNumberStart'};
}
sub localHeaderRelativeOffset {
shift->{'localHeaderRelativeOffset'};
}
sub dataOffset {
shift->{'dataOffset'};
}
sub _skipLocalFileHeader {
my $self = shift;
my $header;
my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH )
{
return _ioError("reading local file header");
}
my $fileNameLength;
my $extraFieldLength;
( undef, undef, undef, undef, undef, undef, undef, $fileNameLength,
$extraFieldLength )
= unpack( LOCAL_FILE_HEADER_FORMAT, $header );
if ($fileNameLength)
{
$self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
or return _ioError("skipping local file name");
}
if ($extraFieldLength)
{
$bytesRead =
$self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
if ( $bytesRead != $extraFieldLength )
{
return _ioError("reading local extra field");
}
}
$self->{'dataOffset'} = $self->fh()->tell();
return AZ_OK;
}
sub _readLocalFileHeader {
my $self = shift;
my $header;
my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH )
{
return _ioError("reading local file header");
}
my $fileNameLength;
my $crc32;
my $compressedSize;
my $uncompressedSize;
my $extraFieldLength;
( $self->{'versionNeededToExtract'}, $self->{'bitFlag'},
$self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
$crc32, $compressedSize,
$uncompressedSize, $fileNameLength,
$extraFieldLength )
= unpack( LOCAL_FILE_HEADER_FORMAT, $header );
if ($fileNameLength)
{
my $fileName;
$bytesRead = $self->fh()->read( $fileName, $fileNameLength );
if ( $bytesRead != $fileNameLength )
{
return _ioError("reading local file name");
}
$self->fileName($fileName);
}
if ($extraFieldLength)
{
$bytesRead =
$self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
if ( $bytesRead != $extraFieldLength )
{
return _ioError("reading local extra field");
}
}
$self->{'dataOffset'} = $self->fh()->tell();
if ( not $self->hasDataDescriptor() )
{
$self->{'crc32'} = $crc32;
$self->{'compressedSize'} = $compressedSize;
$self->{'uncompressedSize'} = $uncompressedSize;
}
$self->hasDataDescriptor(0);
return AZ_OK;
}
sub _readCentralDirectoryFileHeader {
my $self = shift;
my $fh = $self->fh();
my $header = '';
my $bytesRead = $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH );
if ( $bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH )
{
return _ioError("reading central dir header");
}
my ( $fileNameLength, $extraFieldLength, $fileCommentLength );
( $self->{'versionMadeBy'}, $self->{'fileAttributeFormat'},
$self->{'versionNeededToExtract'}, $self->{'bitFlag'},
$self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
$self->{'crc32'}, $self->{'compressedSize'},
$self->{'uncompressedSize'}, $fileNameLength,
$extraFieldLength, $fileCommentLength,
$self->{'diskNumberStart'}, $self->{'internalFileAttributes'},
$self->{'externalFileAttributes'}, $self->{'localHeaderRelativeOffset'} )
= unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header );
if ($fileNameLength)
{
$bytesRead = $fh->read( $self->{'fileName'}, $fileNameLength );
if ( $bytesRead != $fileNameLength )
{
_ioError("reading central dir filename");
}
}
if ($extraFieldLength)
{
$bytesRead = $fh->read( $self->{'cdExtraField'}, $extraFieldLength );
if ( $bytesRead != $extraFieldLength )
{
return _ioError("reading central dir extra field");
}
}
if ($fileCommentLength)
{
$bytesRead = $fh->read( $self->{'fileComment'}, $fileCommentLength );
if ( $bytesRead != $fileCommentLength )
{
return _ioError("reading central dir file comment");
}
}
$self->desiredCompressionMethod( $self->compressionMethod() );
return AZ_OK;
}
sub rewindData {
my $self = shift;
my $status = $self->SUPER::rewindData(@_);
return $status unless $status == AZ_OK;
return AZ_IO_ERROR unless $self->fh();
$self->fh()->clearerr();
$status = $self->_seekToLocalHeader();
return $status unless $status == AZ_OK;
$status = $self->_skipLocalFileHeader();
return $status unless $status == AZ_OK;
$self->fh()->seek( $self->dataOffset(), IO::Seekable::SEEK_SET )
or return _ioError("seeking to beginning of file data");
return AZ_OK;
}
sub _readRawChunk {
my ( $self, $dataRef, $chunkSize ) = @_;
return ( 0, AZ_OK ) unless $chunkSize;
my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
or return ( 0, _ioError("reading data") );
return ( $bytesRead, AZ_OK );
}
package Archive::Zip::StringMember;
use vars qw( @ISA );
@ISA = qw ( Archive::Zip::Member );
BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES ) }
sub _newFromString {
my $class = shift;
my $string = shift;
my $name = shift;
my $self = $class->new(@_);
$self->contents($string);
$self->fileName($name) if defined($name);
$self->setLastModFileDateTimeFromUnix( time() );
$self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
return $self;
}
sub _become {
my $self = shift;
my $newClass = shift;
return $self if ref($self) eq $newClass;
delete( $self->{'contents'} );
return $self->SUPER::_become($newClass);
}
sub contents {
my $self = shift;
my $string = shift;
if ( defined($string) )
{
$self->{'contents'} = ( ref($string) eq 'SCALAR' ) ? $$string : $string;
$self->{'uncompressedSize'} = $self->{'compressedSize'} =
length( $self->{'contents'} );
$self->{'compressionMethod'} = COMPRESSION_STORED;
}
return $self->{'contents'};
}
sub _readRawChunk {
my ( $self, $dataRef, $chunkSize ) = @_;
$$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize );
return ( length($$dataRef), AZ_OK );
}
1;
__END__