File Coverage

blib/lib/Archive/Zip/SimpleUnzip.pm

Criterion	Covered	Total	%
statement	327	380	86.0
branch	72	126	57.1
condition	23	37	62.1
subroutine	57	70	81.4
pod	10	24	41.6
total	489	637	76.7

package Archive::Zip::SimpleUnzip;

require 5.006;

use strict ;
use warnings;
use bytes;

use IO::File;
use Carp;
use Scalar::Util ();

use IO::Compress::Base::Common  2.201 qw(:Status);
use IO::Compress::Zip::Constants 2.201 ;
use IO::Uncompress::Unzip 2.201 ;


require Exporter ;

our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $SimpleUnzipError);

$VERSION = '1.000';
$SimpleUnzipError = '';

@ISA    = qw(IO::Uncompress::Unzip Exporter);
@EXPORT_OK = qw( $SimpleUnzipError unzip );
%EXPORT_TAGS = %IO::Uncompress::RawInflate::EXPORT_TAGS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');

our %PARAMS = (
                'filesonly' => [IO::Compress::Base::Common::Parse_boolean, 0],
              );

sub _ckParams
{
    my $got = IO::Compress::Base::Parameters::new();

    $got->parse(\%PARAMS, @_)
        or _myDie("Parameter Error: " . $got->getError())  ;

    return $got;
}

sub _setError
{
    $SimpleUnzipError = $_[2] ;
    $_[0]->{Error} = $_[2]
        if defined  $_[0] ;

    return $_[1];
}

sub _myDie
{
    $SimpleUnzipError = $_[0];
    Carp::croak $_[0];
}

sub _illegalFilename
{
    return _setError(undef, undef, "Illegal Filename") ;
}

sub is64BitPerl
{
    use Config;
    # possibly use presence of pack/unpack "Q" for int size test?
    $Config{lseeksize} >= 8 and $Config{uvsize} >= 8;
}

sub new
{
    my $class = shift ;

    return _setError(undef, undef, "Missing Filename")
        unless @_ ;

    my $inValue = shift ;
    my $fh;

    if (!defined $inValue)
    {
        return _illegalFilename
    }

    my $isSTDOUT = ($inValue eq '-') ;
    my $inType = IO::Compress::Base::Common::whatIsOutput($inValue);

    if ($inType eq 'filename')
    {
        if (-e $inValue && ( ! -f _ || ! -r _))
        {
            return _illegalFilename
        }

        $fh = new IO::File "<$inValue"
            or return _setError(undef, undef, "cannot open file '$inValue': $!");
    }
    elsif( $inType eq 'buffer' || $inType eq 'handle')
    {
        $fh = $inValue;
    }
    else
    {
        return _illegalFilename
    }

    my %obj ;

    my $got = _ckParams(@_);
    my $filesOnly = $got->getValue('filesonly');

    my $inner = IO::Compress::Base::Common::createSelfTiedObject($class, \$SimpleUnzipError);

    *$inner->{Pause} = 1;
    $inner->_create(undef, 0, $fh)
        or return undef;

    my ($CD, $Members, $comment) = $inner->scanCentralDirectory($filesOnly);
    $obj{CD} = $CD;
    $obj{Members} = $Members ;
    $obj{Comment} = $comment;
    $obj{Cursor} = 0;
    $obj{Inner} = $inner;
    $obj{Open} = 1 ;

    bless \%obj, $class;
}

sub close
{
    my $self = shift;
    # TODO - fix me
#    $self->{Inner}->close();
    return 1;
}

sub DESTROY
{
    my $self = shift;
}

sub resetter
{
    my $inner = shift;
    my $member = shift;


    *$inner->{NewStream} = 0 ;
    *$inner->{EndStream} = 0 ;
    *$inner->{TotalInflatedBytesRead} = 0;
    *$inner->{Info}{TrailerLength} = 0;

    # disable streaming if present & set sizes from central dir
    # TODO - this will only allow a single file to be read at a time.
    #        police it or fix it.
    *$inner->{ZipData}{Streaming} = 0;
    *$inner->{ZipData}{Crc32} = $member->{CRC32};
    *$inner->{ZipData}{CompressedLen} = $member->{CompressedLength};
    *$inner->{ZipData}{UnCompressedLen} = $member->{UncompressedLength};
    *$inner->{CompressedInputLengthRemaining} =
            *$inner->{CompressedInputLength} = $member->{CompressedLength};
}

sub _readLocalHeader
{
    my $self = shift;
    my $member = shift;

    my $inner = $self->{Inner};

    resetter($inner, $member);

    my $status = $inner->smartSeek($member->{LocalHeaderOffset}, 0, SEEK_SET);
    $inner->_readFullZipHeader() ;
    $member->{DataOffset} = $inner->smartTell();
}

sub comment
{
    my $self = shift;

    return $self->{Comment} ;
}

sub _mkMember
{
    my $self = shift;
    my $member = shift;

    $self->_readLocalHeader($member);

    my %member ;
    $member{Inner}  = $self->{Inner};
    $member{Info} = $member;
    #Scalar::Util::weaken $member{Inner}; # for 5.8


    return bless \%member, 'Archive::Zip::SimpleUnzip::Member';
}

sub member
{
    my $self = shift;
    my $name = shift;

    return _setError(undef, undef, "Member '$name' not in zip")
        if ! defined $name ;

    my $member = $self->{Members}{$name};

    return _setError(undef, undef, "Member '$name' not in zip")
        if ! defined $member ;

    return $self->_mkMember($member) ;
}

sub open
{
    my $self = shift;
    my $name = shift;

    my $member = $self->{Members}{$name};

    # TODO - get to return unef
    die "Member '$name' not in zip file\n"
        if ! defined $member ;

     $self->_readLocalHeader($member);

#    return $self->{Inner};
    my $z = IO::Compress::Base::Common::createSelfTiedObject("Archive::Zip::SimpleUnzip::Handle", \$SimpleUnzipError) ;

    *$z->{Open} = 1 ;
    *$z->{SZ} = $self->{Inner};
    Scalar::Util::weaken *$z->{SZ}; # for 5.8

    $z;
}

sub extract # to file - return actual path or pass/fail?
{
    my $self = shift;
    my $name = shift;
    my $out  = shift;

    my $member = $self->member($name)
        or return undef ;

    return $member->extract(defined $out ? $out : $name);
}

sub getCanonicalPath
{
    my $self = shift;
    my $name = shift;

    return _canonicalPath($name);
}



sub _isDirectory
{
    my $self = shift;
    my $name = shift ;

    return substr($name, -1, 1) eq '/' &&
        $self->{Info}{UncompressedLength} == 0  ;
}

sub content
{
    my $self = shift;
    my $name = shift;

    my $member = $self->member($name)
        or return undef ;

    return $member->content();
}

sub exists
{
    my $self = shift;
    my $name = shift;

   return exists $self->{Members}{$name};
}

sub names
{
    my $self = shift ;
    return wantarray ? map { $_->{Name} } @{ $self->{CD} } : scalar @{ $self->{CD} } ;
}

sub next
{
    my $self = shift;
    return undef if $self->{Cursor} >= @{ $self->{CD} } ;
    return $self->_mkMember($self->{CD}[ $self->{Cursor} ++]) ;
}

# sub rewind
# {
#     my $self = shift;

#     $self->{Cursor} = 0;
# }

# sub unzip
# {
#     my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$SimpleUnzipError);
#     return $obj->_inf(@_) ;
# }

sub getExtraParams
{
    return ();
}

sub ckParams
{
    my $self = shift ;
    my $got = shift ;

    # unzip always needs crc32
    $got->setValue('crc32' => 1);

    return 1;
}

sub mkUncomp
{
    my $self = shift ;
    my $got = shift ;

    my $magic = $self->ckMagic()
        or return 0;

    return 1;
}

sub chkTrailer
{
    my $self = shift;
    my $trailer = shift;
    return STATUS_OK ;
}


sub seekOrDie
{
    # temp method to die if bad seek
    # TODO - revisist
    my $self   = shift ;
    my $offset = shift ;
    my $truncate = shift;
    my $position = shift || SEEK_SET;
    my $message = shift || "Error Seeking in CentralDirectory" ;

    my $got =  $self->smartSeek($offset, $truncate, $position);

    return $got ;
}

sub readOrDie
{
    # temp method to die if bad read
    # TODO - revisist
    my $self = shift;

    $self->smartReadExact(@_)
        or die "Error reading";
}

sub scanCentralDirectory
{
#    print "scanCentralDirectory\n";

    my $self = shift;
    my $filesOnly = shift ; # *$self->{FilesOnly};
    my $here = $self->smartTell();

    # Use cases
    # 1 32-bit CD
    # 2 64-bit CD

    my @CD = ();
    my %Members = ();
    my ($entries, $offset, $zipcomment) = $self->findCentralDirectoryOffset();

    return ()
        if ! defined $offset;

    return ([], {}, $zipcomment)
        if $entries == 0;

    $self->seekOrDie($offset, 0, SEEK_SET) ;

    # Now walk the Central Directory Records
    my $index = 0;
    my $buffer ;
    while ($self->smartReadExact(\$buffer, 46) &&
           unpack("V", $buffer) == ZIP_CENTRAL_HDR_SIG) {

        my $crc32              = unpack("V", substr($buffer, 16, 4));
        my $compressedLength   = unpack("V", substr($buffer, 20, 4));
        my $uncompressedLength = unpack("V", substr($buffer, 24, 4));
        my $filename_length    = unpack("v", substr($buffer, 28, 2));
        my $extra_length       = unpack("v", substr($buffer, 30, 2));
        my $comment_length     = unpack("v", substr($buffer, 32, 2));
        my $locHeaderOffset    = unpack("V", substr($buffer, 42, 4));

        my $filename;
        my $extraField;
        my $comment = '';
        if ($filename_length)
        {
            $self->smartReadExact(\$filename, $filename_length)
                or return $self->TruncatedTrailer("filename");
#            print "Filename [$filename]\n";
        }

        if ($extra_length)
        {
            $self->smartReadExact(\$extraField, $extra_length)
                or return $self->TruncatedTrailer("extra");

            # Check for Zip64
            my $zip64Extended = IO::Compress::Zlib::Extra::findID("\x01\x00", $extraField);
            if ($zip64Extended)
            {
                if ($uncompressedLength == 0xFFFFFFFF)
                {
                    $uncompressedLength = U64::Value_VV64  substr($zip64Extended, 0, 8, "");
                    # $uncompressedLength = unpack "Q<", substr($zip64Extended, 0, 8, "");
                }
                if ($compressedLength == 0xFFFFFFFF)
                {
                    $compressedLength = U64::Value_VV64  substr($zip64Extended, 0, 8, "");
                    # $compressedLength = unpack "Q<", substr($zip64Extended, 0, 8, "");
                }
                if ($locHeaderOffset == 0xFFFFFFFF)
                {
                    $locHeaderOffset = U64::Value_VV64  substr($zip64Extended, 0, 8, "");
                    # $locHeaderOffset = unpack "Q<", substr($zip64Extended, 0, 8, "");
                }
            }
        }

        next
            if $filesOnly && substr($filename, -1, 1) eq '/' && $uncompressedLength == 0;

        if ($comment_length)
        {
            $self->smartReadExact(\$comment, $comment_length)
                or return $self->TruncatedTrailer("comment");
        }

        my %data = (
                    'Name'               => $filename,
                    'Comment'            => $comment,
                    'LocalHeaderOffset'  => $locHeaderOffset,
                    'CompressedLength'   => $compressedLength ,
                    'UncompressedLength' => $uncompressedLength ,
                    'CRC32'              => $crc32 ,
                    #'Time'               => _dosToUnixTime($lastModTime),
                    #'Stream'             => $streamingMode,
                    #'Zip64'              => $zip64,
                    #
                    #'MethodID'           => $compressedMethod,
                    );
        push @CD, \%data;
        $Members{$filename} = \%data ;

        ++ $index;
    }

    $self->seekOrDie($here, 0, SEEK_SET) ;

    return (\@CD, \%Members, $zipcomment) ;
}

sub offsetFromZip64
{
#    print "offsetFromZip64\n";

    my $self = shift ;
    my $here = shift;

    $self->seekOrDie($here - 20, 0, SEEK_SET) ;

    my $buffer;
    my $got = 0;
    $self->readOrDie(\$buffer, 20) ;
        # or die "xxx $here $got $!" ;

    if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_LOC_HDR_SIG ) {
        my $cd64 = U64::Value_VV64 substr($buffer,  8, 8);
        # my $cd64 = unpack "Q<", substr($buffer,  8, 8);

        $self->seekOrDie($cd64, 0, SEEK_SET) ;

        $self->readOrDie(\$buffer, 4) ;

        if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_REC_HDR_SIG ) {

            $self->readOrDie(\$buffer, 8);
                # or die "xxx" ;
            my $size  = U64::Value_VV64($buffer);
            # my $size  = unpack "Q<", $buffer;

            $self->readOrDie(\$buffer, $size);
                # or die "xxx" ;

            my $cd64 =  U64::Value_VV64 substr($buffer,  36, 8);
            # my $cd64 = unpack "Q<", substr($buffer,  36, 8);

            return $cd64 ;
        }

        die "zzz1";
    }

    die "zzz2";
}

use constant Pack_ZIP_END_CENTRAL_HDR_SIG => pack("V", ZIP_END_CENTRAL_HDR_SIG);

sub findCentralDirectoryOffset
{
    my $self = shift ;

    # Most common use-case is where there is no comment, so
    # know exactly where the end of central directory record
    # should be.

    $self->seekOrDie(-22, 0, SEEK_END) ;
    my $here = $self->smartTell();

    my $buffer;
    $self->readOrDie(\$buffer, 22) ;

    my $zip64 = 0;
    my $centralDirOffset ;
    my $comment = '';
    my $entries = 0;
    if ( unpack("V", $buffer) == ZIP_END_CENTRAL_HDR_SIG ) {
        $entries          = unpack("v", substr($buffer, 8,  2));
        $centralDirOffset = unpack("V", substr($buffer, 16,  4));
    }
    else {
        $self->seekOrDie(0, 0, SEEK_END) ;

        my $fileLen = $self->smartTell();
        my $want = 0 ;

        while(1) {
            $want += 1024;
            my $seekTo = $fileLen - $want;
            if ($seekTo < 0 ) {
                $seekTo = 0;
                $want = $fileLen ;
            }

            $self->seekOrDie($seekTo, 0, SEEK_SET) ;
            my $got;
            $self->readOrDie(\$buffer, $want) ;
            my $pos = rindex( $buffer, Pack_ZIP_END_CENTRAL_HDR_SIG);

            if ($pos >= 0) {

                #$here = $self->smartTell();
                $here = $seekTo + $pos ;
                $entries            = unpack("v", substr($buffer, $pos + 8,  2));
                $centralDirOffset   = unpack("V", substr($buffer, $pos + 16, 4));
                my $comment_length  = unpack("v", substr($buffer, $pos + 20, 2));
                $comment = substr($buffer, $pos + 22, $comment_length)
                    if $comment_length ;

                last ;
            }

            return undef
                if $want == $fileLen;
        }
    }

    $centralDirOffset = $self->offsetFromZip64($here)
        if $entries and U64::full32 $centralDirOffset ;

#    print "findCentralDirectoryOffset $centralDirOffset [$comment]\n";
    return ($entries, $centralDirOffset, $comment) ;
}


sub STORABLE_freeze
{
    my $type = ref shift;
    croak "Cannot freeze $type object\n";
}

sub STORABLE_thaw
{
    my $type = ref shift;
    croak "Cannot thaw $type object\n";
}

{
    package Archive::Zip::SimpleUnzip::Member;

    use IO::File ;
    use File::Basename;
    use File::Path ;

    sub name
    {
        my $self = shift;
#        $self->_stdPreq() or return 0 ;

        return $self->{Info}{Name};
    }

    sub isDirectory
    {
        my $self = shift;
#        $self->_stdPreq() or return 0 ;

        return substr($self->{Info}{Name}, -1, 1) eq '/' &&
                $self->{Info}{UncompressedLength} == 0  ;
    }

    sub isFile
    {
        my $self = shift;
#        $self->_stdPreq() or return 0 ;

        # TODO - test for symlink
        return ! $self->isDirectory() ;
    }

# TODO
#
#    isZip64
#    isDir
#    isSymLink
#    isText
#    isBinary
#    isEncrypted
#    isStreamed
#    getComment
#    getExtra
#    compressedSize - 64 bit alert
#    uncompressedSize
#    time
#    isStored
#    compressionName
#

    sub compressedSize
    {
        my $self = shift;
#        $self->_stdPreq() or return 0 ;

        return $self->{Info}{CompressedLength};
    }

    sub uncompressedSize
    {
        my $self = shift;
#        $self->_stdPreq() or return 0 ;

        return $self->{Info}{UncompressedLength};
    }

    sub content
    {
        my $self = shift;
        my $data ;

        my $inner = $self->{Inner};

        $inner->reset() if $self->{NeedsReset}; $self->{NeedsReset} ++ ;
        Archive::Zip::SimpleUnzip::resetter($inner, $self->{Info});

        $inner->smartSeek($self->{Info}{DataOffset}, 0, SEEK_SET);
        $self->{Inner}->read($data, $self->{Info}{UncompressedLength});

        return $data;
    }

    sub open
    {
        my $self = shift;

#        return  return $self->{Inner} ;

#        my $handle = Symbol::gensym();
#        tie *$handle, "Archive::Zip::SimpleUnzip::Handle", $self->{SZ}{UnZip};
#        return $handle;

        my $z = IO::Compress::Base::Common::createSelfTiedObject("Archive::Zip::SimpleUnzip::Handle", \$SimpleUnzipError) ;

        *$z->{Open} = 1 ;
        *$z->{SZ} = $self->{Inner};

        my $inner = $self->{Inner};
        $inner->reset() if $self->{NeedsReset}; $self->{NeedsReset} ++ ;
        Archive::Zip::SimpleUnzip::resetter($self->{Inner}, $self->{Info});
        $inner->smartSeek($self->{Info}{DataOffset}, 0, SEEK_SET);

        Scalar::Util::weaken *$z->{SZ}; # for 5.8

        $z;
    }

    sub close
    {
        my $self = shift;
        return 1;
    }

    sub comment
    {
        my $self = shift;

        return $self->{Info}{Comment};
    }

    sub _canonicalPath
    {
        my $name = shift ;

        # Not an absolute path
        $name =~ s#^/+## ;

        # Remove trailing slash
        $name =~ s#/+$## ;

        $name =~ s#/+#/#g ;

        # Drop any ".." and "." paths
        # Use of ".." is unsafe
        my @paths = split '/', $name ;
        my @have =  grep { ! m#^\.(\.)?$# } @paths ;

        return @have ;

        $name = join '/', grep { ! m#^\.(\.)?$# } @paths ;

        # use Perl::OSType;
        # my $type = Perl::OSType::os_type();
        # if ( $type eq 'Unix' )
        # {
        # }
        # # TODO Win32
    }

    sub canonicalName
    {
        my $self = shift;

        return join '/', _canonicalPath($self->{Info}{Name});
    }

    sub extract # to file
    {
        my $self = shift;
        my $out  = shift;

        my $path ;
        my $filename ;

        if (defined $out)
        {
            # User has supplied output file, so allow absolute path
            $filename = $out;
        }
        else
        {
            # using name in zip file, so make it safe
            my @path = _canonicalPath(defined $out ? $out : $self->{Info}{Name}) ;
            $filename = join '/', @path ;
        }

        $path = $self->isDirectory() ? $filename : dirname $filename;

        if (defined $path)
        {
            # check path isn't already a plain file
            return _setError("Path is not a directory '$path'")
                if -e $path && ! -d $path ;

            if (! -d $path)
            {
                my $error ;
                File::Path::mkpath($path, {error => \$error})
                    or return _setError("Cannot create path '$path': $error");
            }
        }

        # TODO - symlink

        if ($self->isFile())
        {
            my $handle = $self->open();
            my $fh = new IO::File ">$filename"
                or return _setError("Cannot open file '$filename': $!");
            #$fh->binmode(); # not available in 5.8.0

            my $data;
            print $fh $data
                while $handle->read($data);
            $handle->close();
            $fh->close();
        }

        # TODO - set timestamps etc...

        return 1 ;
    }

    sub _setError
    {
        $Archive::Zip::SimpleUnzip::SimpleUnzipError = $_[0] ;
        return 0;
    }
}


{
    package Archive::Zip::SimpleUnzip::Handle ;

    sub TIEHANDLE
    {
        return $_[0] if ref($_[0]);
        die "OOPS\n" ;
    }

    sub UNTIE
    {
        my $self = shift ;
    }

    sub DESTROY
    {
#        print "DESTROY H";
        my $self = shift ;
        local ($., $@, $!, $^E, $?);
        $self->close() ;

        # TODO - memory leak with 5.8.0 - this isn't called until
        #        global destruction
        #
        %{ *$self } = () ;
        undef $self ;
    }


    sub close
    {
        my $self = shift ;
        return 1 if ! *$self->{Open};

        *$self->{Open} = 0 ;

#        untie *$self
#            if $] >= 5.008 ;

        if (defined *$self->{SZ})
        {
#            *$self->{SZ}{Raw} = undef ;
            *$self->{SZ} = undef ;
        }

        1;
    }

    sub read
    {
        # TODO - remember to fix the return value to match real read & not the broken one in IO::Uncompress
        my $self = shift;
        $self->_stdPreq() or return 0 ;

#        warn "READ [$self]\n";
#        warn "READ [*$self->{SZ}]\n";

#        $_[0] = *$self->{SZ}{Unzip};
#        my $status = goto &IO::Uncompress::Base::read;
#        $_[0] = \$_[0] unless ref $_[0];
        my $status = *$self->{SZ}->read(@_);
        $status = undef if $status < 0 ;
        return $status;
    }

    sub readline
    {
        my $self = shift;
        $self->_stdPreq() or return 0 ;
        *$self->{SZ}->getline(@_);
    }

    sub tell
    {
        my $self = shift;
        $self->_stdPreq() or return 0 ;

        *$self->{SZ}->tell(@_);
    }

    sub eof
    {
        my $self = shift;
        $self->_stdPreq() or return 0 ;

        *$self->{SZ}->eof;
    }

    sub _stdPreq
    {
        my $self = shift;

        # TODO - fix me
        return 1;

        return _setError("Zip file closed")
            if ! defined defined *$self->{SZ} || ! *$self->{Inner}{Open} ;


        return _setError("member filehandle closed")
            if  ! *$self->{Open} ; #|| ! defined *$self->{SZ}{Raw};

        return 0
            if *$self->{SZ}{Error} ;

         return 1;
    }

    sub _setError
    {
        $Archive::Zip::SimpleUnzip::SimpleUnzipError = $_[0] ;
        return 0;
    }

    sub binmode { 1 }

#    sub clearerr { $Archive::Zip::SimpleUnzip::SimpleUnzipError = '' }

    *BINMODE  = \&binmode;
#    *SEEK     = \&seek;
    *READ     = \&read;
    *sysread  = \&read;
    *TELL     = \&tell;
    *READLINE = \&readline;
    *EOF      = \&eof;
    *FILENO   = \&fileno;
    *CLOSE    = \&close;
}


1;

__END__