File Coverage

blib/lib/Archive/Zip/SimpleZip.pm

Criterion	Covered	Total	%
statement	210	226	92.9
branch	100	128	78.1
condition	27	39	69.2
subroutine	33	40	82.5
pod	5	9	55.5
total	375	442	84.8

package Archive::Zip::SimpleZip;

use strict;
use warnings;

require 5.006;

use IO::Compress::Zip 2.201 qw(:all);
use IO::Compress::Base::Common  2.201 ();
use IO::Compress::Adapter::Deflate 2.201 ;

use Fcntl ();
use File::Spec ();
use IO::File ();
use Scalar::Util ();
use Carp;
require Exporter ;

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

$SimpleZipError= '';
$VERSION = "1.000";

@ISA = qw(Exporter);
@EXPORT_OK = qw( $SimpleZipError ) ;

%EXPORT_TAGS = %IO::Compress::Zip::EXPORT_TAGS ;

Exporter::export_ok_tags('all');

our %PARAMS = (
        'name'          => [IO::Compress::Base::Common::Parse_any,       ''],
        'comment'       => [IO::Compress::Base::Common::Parse_any,       ''],
        'zipcomment'    => [IO::Compress::Base::Common::Parse_any,       ''],
        'stream'        => [IO::Compress::Base::Common::Parse_boolean,   0],
        'method'        => [IO::Compress::Base::Common::Parse_unsigned,  ZIP_CM_DEFLATE],
        'minimal'       => [IO::Compress::Base::Common::Parse_boolean,   0],
        'zip64'         => [IO::Compress::Base::Common::Parse_boolean,   0],
        'filtername'    => [IO::Compress::Base::Common::Parse_code,      undef],
        'canonicalname' => [IO::Compress::Base::Common::Parse_boolean,   1],
        'textflag'      => [IO::Compress::Base::Common::Parse_boolean,   0],
        'storelinks'    => [IO::Compress::Base::Common::Parse_boolean,   0],
        'autoflush'     => [IO::Compress::Base::Common::Parse_boolean,   0],
        #'storedirs'    => [IO::Compress::Base::Common::Parse_boolean,   0],
        'encode'       => [IO::Compress::Base::Common::Parse_any,        undef],
        #'extrafieldlocal'  => [IO::Compress::Base::Common::Parse_any,    undef],
        #'extrafieldcentral'=> [IO::Compress::Base::Common::Parse_any,    undef],
        'filtercontainer' => [IO::Compress::Base::Common::Parse_code,  undef],
#        'time'          => [IO::Compress::Base::Common::Parse_any,       undef],
#        'extime'        => [IO::Compress::Base::Common::Parse_any,       undef],
#        'efs'           => [IO::Compress::Base::Common::Parse_boolean,   0],

        # Zlib
        'level'         => [IO::Compress::Base::Common::Parse_signed,    Z_DEFAULT_COMPRESSION],
        'strategy'      => [IO::Compress::Base::Common::Parse_signed,    Z_DEFAULT_STRATEGY],

        # Lzma
        'preset'        => [IO::Compress::Base::Common::Parse_unsigned, 6],
        'extreme'       => [IO::Compress::Base::Common::Parse_boolean,  0],

        # Bzip2
        'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned,  1],
        'workfactor'    => [IO::Compress::Base::Common::Parse_unsigned,  0],
        'verbosity'     => [IO::Compress::Base::Common::Parse_boolean,   0],
    );


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

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

    if ($top)
    {
        for my $opt ( qw(name comment) )
        {
            _myDie("$opt option not valid in constructor")
                if $got->parsed($opt);
        }

        $got->setValue('crc32'   => 1);
        $got->setValue('adler32' => 0);
        $got->setValue('os_code' => $Compress::Raw::Zlib::gzip_os_code);
    }
    else
    {
        for my $opt ( qw( zipcomment) )
        {
            _myDie("$opt option only valid in constructor")
                if $got->parsed($opt);
        }
    }

    my $e = $got->getValue("encode");
    if (defined $e)
    {
        _myDie("Encode::find_encoding not found") if ! defined &Encode::find_encoding;
        _myDie("Unknown Encoding '$e'")           if ! defined Encode::find_encoding($e) ;
    }

    return $got;
}

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


#sub simplezip
#{
#    my $from = shift;
#    my $filename = shift ;
#    #my %opts
#
#    my $z = new Archive::Zip::SimpleZip $filename, @_;
#
#    if (ref $from eq 'ARRAY')
#    {
#        $z->add($_) for @$from;
#    }
#    elsif (ref $from)
#    {
#        die "bad";
#    }
#    else
#    {
#        $z->add($filename);
#    }
#
#    $z->close();
#}


sub new
{
    my $class = shift;

    $SimpleZipError = '';

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

    my $outValue = shift ;
    my $fh;

    if (!defined $outValue)
    {
        return _illegalFilename
    }

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

    if ($outType eq 'filename')
    {
        if (-e $outValue && ( ! -f _ || ! -w _))
        {
            return _illegalFilename
        }

        $fh = new IO::File ">$outValue"
            or return _illegalFilename;
    }
    elsif( $outType eq 'buffer' || $outType eq 'handle')
    {
        $fh = $outValue;
    }
    else
    {
        return _illegalFilename
    }

    my $got = _ckParams(undef, 1, @_);
    $got->setValue('autoclose' => 1) unless $outType eq 'handle' ;
    $got->setValue('stream' => 1) if $isSTDOUT ;

    my $obj = {
                ZipFile      => $outValue,
                FH           => $fh,
                Open         => 1,
                FilesWritten => 0,
                Opts         => $got,
                Error        => undef,
                Raw          => undef,
              };

    bless $obj, $class;
}

sub DESTROY
{
    my $self = shift;
    $self->close();
}

sub close
{
    my $self = shift;

    return 0
        if ! $self->{Open} ;

    $self->{Open} = 0;
    if ($self->{FilesWritten} || defined $self->{Raw})
    {
         if(defined $self->{Zip})
         {
             if (defined $self->{Raw})
             {
                 $self->{Raw} = undef ;
             }

            $self->{Zip}->_flushCompressed() || return 0;
            $self->{Zip}->close() || return 0;
            delete $self->{Zip} ;
         }
    }

    1;
}

sub _newStream
{
    my $self = shift;
    my $filename = shift ;
    my $options =  shift;

    if (defined $filename)
    {
        IO::Compress::Zip::getFileInfo(undef, $options, $filename) ;

        # Force STORE for directories, symbolic links & empty files
        $options->setValue(method => ZIP_CM_STORE)
            if -d $filename || -z _ || -l $filename ;
    }

    # Archive::Zip::SimpleZip handles canonical
    $options->setValue(canonicalname => 0);

    $! = 0;
    if (! defined $self->{Zip}) {
        $self->{Zip} = IO::Compress::Base::Common::createSelfTiedObject('IO::Compress::Zip', \$SimpleZipError);
        $self->{Zip}->_create($options, $self->{FH})
            or die "_create $SimpleZipError";
        $self->{Zip}->autoflush()
            if  $options->getValue('autoflush');

    }
    else {
        $self->{Zip}->_newStream($options)
            or die "_newStream - $SimpleZipError";
    }

    ++ $self->{FilesWritten} ;

    return 1;
}


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

    return $_[1];
}


sub error
{
    my $self = shift;
    return $self->{Error};
}

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

}

sub _stdPreq
{
    my $self = shift;

    return 0
        if $self->{Error} ;

    return $self->_setError(0, "Zip file closed")
        if ! $self->{Open} ;

    return $self->_setError(0, "openMember filehandle already open")
        if  defined $self->{Raw};

     return 1;
}

sub add
{
    my $self = shift;
    my $filename = shift;

    $self->_stdPreq or return 0 ;

    return $self->_setError(0, "File '$filename' does not exist")
        if ! -e $filename  ;

    return $self->_setError(0, "File '$filename' cannot be read")
        if ! -r $filename ;

    my $options =  $self->{Opts}->clone();

    my $got = _ckParams($options, 0, @_);

    # Force Encode off.
    $got->setValue('encode', undef);

    my $isLink = $got->getValue('storelinks') && -l $filename ;
    my $isDir = -d $filename;

    return 0
        if $filename eq '.' || $filename eq '..';

    if ($options->getValue("canonicalname"))
    {
        if (! $got->parsed("name"))
        {
            $got->setValue(name => IO::Compress::Zip::canonicalName($filename, $isDir && ! $isLink));
        }
        else
        {
            $got->setValue(name => IO::Compress::Zip::canonicalName($got->getValue("name"), $isDir && ! $isLink));
        }
    }

    my ($mode, $uid, $gid, $size, $atime, $mtime, $ctime) ;

    if ( $got->parsed('storelinks') )
    {
        ($mode, $uid, $gid, $size, $atime, $mtime, $ctime)
                = (lstat($filename))[2, 4, 5, 7, 8, 9, 10] ;
    }
    else
    {
        ($mode, $uid, $gid, $size, $atime, $mtime, $ctime)
                = (stat($filename))[2, 4, 5,7, 8, 9, 10] ;
    }

    $got->setValue(time => $mtime);

    if (! $got->getValue('minimal')) {

        $got->setValue(extime => [$atime, $mtime, $ctime]) ;

        use Perl::OSType;
        my $type = Perl::OSType::os_type();
        if ( $type eq 'Unix' )
        {
            $got->setValue(exunixn => [$uid, $gid]) ;
        }
        # TODO add Windows
    }

    $self->_newStream($filename, $got);

    if($isLink)
    {
        my $target = readlink($filename);
        $self->{Zip}->write($target);
    }
    elsif (-d $filename)
    {
        # Do nothing, a directory has no payload
    }
    elsif (-f $filename)
    {
        my $fh = new IO::File "<$filename"
            or die "Cannot open file $filename: $!";

        binmode $fh;

        my $data;
        my $last ;
        while ($fh->read($data, 1024 * 16))
        {
            $self->{Zip}->write($data);
        }
    }
    else
    {
        return 0;
    }

    return 1;
}


sub addString
{
    my $self    = shift;
    my $string  = shift;

    $self->_stdPreq or return 0 ;

    my $options =  $self->{Opts}->clone();

    my $got = _ckParams($options, 0, @_);

    _myDie("Missing 'Name' parameter in addString")
        if ! $got->parsed("name");

    $got->setValue(name => IO::Compress::Zip::canonicalName($got->getValue("name")))
        if $options->getValue("canonicalname") ;

    $self->_newStream(undef, $got);
    $self->{Zip}->write($string);

    return 1;
}

sub addFileHandle
{
    my $self = shift;
    my $fh   = shift;

    $self->_stdPreq or return 0 ;

    my $options =  $self->{Opts}->clone() ;

    my $got = _ckParams($options, 0, @_);

    _myDie("Missing 'Name' parameter in addFileHandle")
        if ! $got->parsed("name");

    $got->setValue(name => IO::Compress::Zip::canonicalName($got->getValue("name")))
        if $options->getValue("canonicalname") ;

    $self->_newStream(undef, $got);

    my $data;

    while ($fh->read($data, 1024 * 16))
    {
        $self->{Zip}->write($data);
    }

    return 1;
}

# sub createDirectory
# {
#     my $self = shift ;
#     my $directory = shift;

#     # TODO - file attributes

#     $self->_stdPreq or return 0 ;

#     my $got = _ckParams($options, 0, @_);
#     $got->setValue(name => IO::Compress::Zip::canonicalName($filename, 1));

#     $self->_newStream(undef, $got);

#     return 1;
# }

sub openMember
{
    my $self    = shift;

    $self->_stdPreq or return undef ;

    my $options =  $self->{Opts}->clone();

    my $got = _ckParams($options, 0, @_);

    _myDie("Missing 'Name' parameter in openMember")
        if ! $got->parsed("name");

    $got->setValue(name => IO::Compress::Zip::canonicalName($got->getValue("name")))
        if $options->getValue("canonicalname") ;

    $self->_newStream(undef, $got);

#  if (1)
#  {
    my $z = IO::Compress::Base::Common::createSelfTiedObject("Archive::Zip::SimpleZip::Handle", \$SimpleZipError) ;

    $self->{Raw} = 1;

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

    return $z;
#  }
#  else
#  {
#    my $handle = Symbol::gensym();
#    tie *$handle, "Archive::Zip::SimpleZip::Handle", $self, $self->{Zip};
#
#    $self->{Raw} = 1;
#
#    return $handle;
#  }
}

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::SimpleZip::Handle ;

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

    sub UNTIE
    {
        my $self = shift ;
    }

    sub DESTROY
    {
        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 print
    {
        my $self = shift;
        $self->_stdPreq() or return 0 ;

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

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

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

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

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

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

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

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

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

    sub _stdPreq
    {
        my $self = shift;

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


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

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

         return 1;
    }

    sub _setError
    {
        $Archive::Zip::SimpleZip::SimpleZipError = $_[0] ;
        return 0;
    }

    sub clearerr
    {
        my $self = shift;

        return 0;
    }

    sub binmode { 1 }
#    sub clearerr { $Archive::Zip::SimpleZip::SimpleZipError = '' }

    *FILENO   = \&fileno;
    *PRINT    = \&print;
    *PRINTF   = \&printf;
    *WRITE    = \&syswrite;
    *write    = \&syswrite;
    *TELL     = \&tell;
    *EOF      = \&eof;
    *CLOSE    = \&close;
    *BINMODE  = \&binmode;
}

#{
#    package Archive::Zip::SimpleZip::HandleNEW ;
#
## TODO - fix this
##    require Tie::Handle;
##
##    @ISA = qw(Tie::Handle);
##@ISA = qw(IO::Handle) ;
#
#    sub TIEHANDLE
#    {
#        my $class = shift;
#        my $parent = shift;
#        my $zip = shift;
#        my $errorRef = shift;
#
#        my %obj = (
#            Zip  => $zip ,
#            SZ   => $parent,
#            Open => 1,
#        ) ;
#
#        Scalar::Util::weaken $obj{SZ}; # for 5.8
#        return bless \%obj, $class;
#    }
#
#    sub UNTIE
#    {
#        my $self = shift ;
#    }
#
#    sub DESTROY
#    {
#        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 print
#    {
#        my $self = shift;
#        $self->_stdPreq() or return 0 ;
#
#        $self->{Zip}->print(@_);
#    }
#
#    sub printf
#    {
#        my $self = shift;
#        $self->_stdPreq() or return 0 ;
#
#        $self->{Zip}->printf(@_);
#    }
#
#    sub syswrite
#    {
#        my $self = shift;
#        $self->_stdPreq() or return 0 ;
#
#        $self->{Zip}->syswrite(@_);
#    }
#
#    sub tell
#    {
#        my $self = shift;
#        $self->_stdPreq() or return 0 ;
#
#        $self->{Zip}->tell(@_);
#    }
#
#    sub eof
#    {
#        my $self = shift;
#        $self->_stdPreq() or return 0 ;
#
#        $self->{Zip}->eof;
#    }
#
#    sub _stdPreq
#    {
#        my $self = shift;
#
#        return _setError("Zip file closed")
#            if ! defined defined $self->{SZ} || ! $self->{SZ}{Open} ;
#
#
#        return _setError("openMember filehandle closed")
#            if  ! $self->{Open} || ! defined $self->{SZ}{Raw};
#
#        return 0
#            if $self->{SZ}{Error} ;
#
#         return 1;
#    }
#
#    sub _setError
#    {
#        $Archive::Zip::SimpleZip::SimpleZipError = $_[0] ;
#        return 0;
#    }
#
#    sub binmode { 1 }
##    sub clearerr { $Archive::Zip::SimpleZip::SimpleZipError = '' }
#
#    *FILENO   = \&fileno;
#    *PRINT    = \&print;
#    *PRINTF   = \&printf;
#    *WRITE    = \&syswrite;
#    *write    = \&syswrite;
#    *TELL     = \&tell;
##    sub IO::Handle::tell { bless $_[0], "Archive::Zip::SimpleZip::Handle" ; Archive::Zip::SimpleZip::Handle::tell @_ };
#    *EOF      = \&eof;
#    *CLOSE    = \&close;
#    *BINMODE  = \&binmode;
#}

1;

__END__