Compress::Zlib becomes zlib agnostic

[p5sagit/p5-mst-13.2.git] / ext / Compress / Zlib / lib / IO / Compress / Zip.pm

package IO::Compress::Zip ;

use strict ;
use warnings;

use Compress::Zlib::Common qw(createSelfTiedObject);
use CompressPlugin::Deflate;
use CompressPlugin::Identity;
use IO::Compress::RawDeflate;

require Exporter ;

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

$VERSION = '2.000_04';
$ZipError = '';

@ISA = qw(Exporter IO::Compress::RawDeflate);
@EXPORT_OK = qw( $ZipError zip ) ;
%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');


sub new
{
    my $class = shift ;

    my $obj = createSelfTiedObject($class, \$ZipError);    
    $obj->_create(undef, @_);
}

sub zip
{
    my $obj = createSelfTiedObject(undef, \$ZipError);    
    return $obj->_def(@_);
}

sub mkComp
{
    my $self = shift ;
    my $class = shift ;
    my $got = shift ;

    my ($obj, $errstr, $errno) ;

    if (*$self->{ZipData}{Store}) {
        #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
        ($obj, $errstr, $errno) = CompressPlugin::Identity::mkCompObject(
                                                 $got->value('CRC32'),
                                                 $got->value('Adler32'),
                                                 $got->value('Level'),
                                                 $got->value('Strategy')
                                                 );
    }
    else {
        #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
        ($obj, $errstr, $errno) = CompressPlugin::Deflate::mkCompObject(
                                                 $got->value('CRC32'),
                                                 $got->value('Adler32'),
                                                 $got->value('Level'),
                                                 $got->value('Strategy')
                                                 );
    }

   return $self->saveErrorString(undef, $errstr, $errno)
       if ! defined $obj;

   return $obj;    
}



sub mkHeader
{
    my $self  = shift;
    my $param = shift ;
    
    my $filename = '';
    $filename = $param->value('Name') || '';

    my $comment = '';
    $comment = $param->value('Comment') || '';

    my $extract = $param->value('OS_Code') << 8 + 20 ;
    my $hdr = '';

    my $time = _unixToDosTime($param->value('Time'));
    *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} ;

    my $strm = *$self->{ZipData}{Stream} ? 8 : 0 ;
    my $method = *$self->{ZipData}{Store} ? 0 : 8 ;

    $hdr .= pack "V", 0x04034b50 ; # signature
    $hdr .= pack 'v', $extract   ; # extract Version & OS
    $hdr .= pack 'v', $strm      ; # general purpose flag (set streaming mode)
    $hdr .= pack 'v', $method    ; # compression method (deflate)
    $hdr .= pack 'V', $time      ; # last mod date/time
    $hdr .= pack 'V', 0          ; # crc32               - 0 when streaming
    $hdr .= pack 'V', 0          ; # compressed length   - 0 when streaming
    $hdr .= pack 'V', 0          ; # uncompressed length - 0 when streaming
    $hdr .= pack 'v', length $filename ; # filename length
    $hdr .= pack 'v', 0          ; # extra length
    
    $hdr .= $filename ;


    my $ctl = '';

    $ctl .= pack "V", 0x02014b50 ; # signature
    $ctl .= pack 'v', $extract   ; # version made by
    $ctl .= pack 'v', $extract   ; # extract Version
    $ctl .= pack 'v', $strm      ; # general purpose flag (streaming mode)
    $ctl .= pack 'v', $method    ; # compression method (deflate)
    $ctl .= pack 'V', $time      ; # last mod date/time
    $ctl .= pack 'V', 0          ; # crc32
    $ctl .= pack 'V', 0          ; # compressed length
    $ctl .= pack 'V', 0          ; # uncompressed length
    $ctl .= pack 'v', length $filename ; # filename length
    $ctl .= pack 'v', 0          ; # extra length
    $ctl .= pack 'v', length $comment ;  # file comment length
    $ctl .= pack 'v', 0          ; # disk number start 
    $ctl .= pack 'v', 0          ; # internal file attributes
    $ctl .= pack 'V', 0          ; # external file attributes
    $ctl .= pack 'V', *$self->{ZipData}{Offset}  ; # offset to local header
    
    $ctl .= $filename ;
    #$ctl .= $extra ;
    $ctl .= $comment ;

    *$self->{ZipData}{Offset} += length $hdr ;

    *$self->{ZipData}{CentralHeader} = $ctl;

    return $hdr;
}

sub mkTrailer
{
    my $self = shift ;

    my $crc32             = *$self->{Compress}->crc32();
    my $compressedBytes   = *$self->{Compress}->compressedBytes();
    my $uncompressedBytes = *$self->{Compress}->uncompressedBytes();

    my $data ;
    $data .= pack "V", $crc32 ;                           # CRC32
    $data .= pack "V", $compressedBytes   ;               # Compressed Size
    $data .= pack "V", $uncompressedBytes;                # Uncompressed Size

    my $hdr = '';

    if (*$self->{ZipData}{Stream}) {
        $hdr  = pack "V", 0x08074b50 ;                       # signature
        $hdr .= $data ;
    }
    else {
        $self->writeAt(*$self->{ZipData}{StartOffset} + 14, $data)
            or return undef;
    }

    my $ctl = *$self->{ZipData}{CentralHeader} ;
    substr($ctl, 16, 12) = $data ;
    #substr($ctl, 16, 4) = pack "V", $crc32 ;             # CRC32
    #substr($ctl, 20, 4) = pack "V", $compressedBytes   ; # Compressed Size
    #substr($ctl, 24, 4) = pack "V", $uncompressedBytes ; # Uncompressed Size

    *$self->{ZipData}{Offset} += length($hdr) + $compressedBytes;
    push @{ *$self->{ZipData}{CentralDir} }, $ctl ;

    return $hdr;
}

sub mkFinalTrailer
{
    my $self = shift ;

    my $entries = @{ *$self->{ZipData}{CentralDir} };
    my $cd = join '', @{ *$self->{ZipData}{CentralDir} };

    my $ecd = '';
    $ecd .= pack "V", 0x06054b50 ; # signature
    $ecd .= pack 'v', 0          ; # number of disk
    $ecd .= pack 'v', 0          ; # number if disk with central dir
    $ecd .= pack 'v', $entries   ; # entries in central dir on this disk
    $ecd .= pack 'v', $entries   ; # entries in central dir
    $ecd .= pack 'V', length $cd ; # size of central dir
    $ecd .= pack 'V', *$self->{ZipData}{Offset} ; # offset to start central dir
    $ecd .= pack 'v', 0          ; # zipfile comment length
    #$ecd .= $comment;

    return $cd . $ecd ;
}

sub ckParams
{
    my $self = shift ;
    my $got = shift;
    
    $got->value('CRC32' => 1);

    if (! $got->parsed('Time') ) {
        # Modification time defaults to now.
        $got->value('Time' => time) ;
    }

    *$self->{ZipData}{Stream} = $got->value('Stream');
    *$self->{ZipData}{Store} = $got->value('Store');
    *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} = 0;

    return 1 ;
}

#sub newHeader
#{
#    my $self = shift ;
#
#    return $self->mkHeader(*$self->{Got});
#}

sub getExtraParams
{
    my $self = shift ;

    use Compress::Zlib::ParseParameters;
    use Compress::Zlib qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);

    
    return (
            # zlib behaviour
            $self->getZlibParams(),

            'Stream'    => [1, 1, Parse_boolean,   1],
            'Store'     => [0, 1, Parse_boolean,   0],
            
#            # Zip header fields
#           'Minimal'   => [0, 1, Parse_boolean,   0],
            'Comment'   => [0, 1, Parse_any,       undef],
            'ZipComment'=> [0, 1, Parse_any,       undef],
            'Name'      => [0, 1, Parse_any,       undef],
            'Time'      => [0, 1, Parse_any,       undef],
            'OS_Code'   => [0, 1, Parse_unsigned,  $Compress::Zlib::gzip_os_code],
            
#           'TextFlag'  => [0, 1, Parse_boolean,   0],
#           'ExtraField'=> [0, 1, Parse_string,    undef],
        );
}

sub getInverseClass
{
    return ('IO::Uncompress::Unzip',
                \$IO::Uncompress::Unzip::UnzipError);
}

sub getFileInfo
{
    my $self = shift ;
    my $params = shift;
    my $filename = shift ;

    my $defaultTime = (stat($filename))[9] ;

    $params->value('Name' => $filename)
        if ! $params->parsed('Name') ;

    $params->value('Time' => $defaultTime) 
        if ! $params->parsed('Time') ;
    
    
}

# from Archive::Zip
sub _unixToDosTime    # Archive::Zip::Member
{
	my $time_t = shift;
    # TODO - add something to cope with unix time < 1980 
	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;
}

1;

__END__