ext/Compress/Zlib/lib/IO/Compress/Zip.pm

   1 package IO::Compress::Zip ;
   2
   3 use strict ;
   4 use warnings;
   5
   6 use Compress::Zlib::Common qw(createSelfTiedObject);
   7 use CompressPlugin::Deflate;
   8 use CompressPlugin::Identity;
   9 use IO::Compress::RawDeflate;
  10
  11 require Exporter ;
  12
  13 our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError);
  14
  15 $VERSION = '2.000_04';
  16 $ZipError = '';
  17
  18 @ISA = qw(Exporter IO::Compress::RawDeflate);
  19 @EXPORT_OK = qw( $ZipError zip ) ;
  20 %EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
  21 push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
  22 Exporter::export_ok_tags('all');
  23
  24
  25 sub new
  26 {
  27     my $class = shift ;
  28
  29     my $obj = createSelfTiedObject($class, \$ZipError);
  30     $obj->_create(undef, @_);
  31 }
  32
  33 sub zip
  34 {
  35     my $obj = createSelfTiedObject(undef, \$ZipError);
  36     return $obj->_def(@_);
  37 }
  38
  39 sub mkComp
  40 {
  41     my $self = shift ;
  42     my $class = shift ;
  43     my $got = shift ;
  44
  45     my ($obj, $errstr, $errno) ;
  46
  47     if (*$self->{ZipData}{Store}) {
  48         #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
  49         ($obj, $errstr, $errno) = CompressPlugin::Identity::mkCompObject(
  50                                                  $got->value('CRC32'),
  51                                                  $got->value('Adler32'),
  52                                                  $got->value('Level'),
  53                                                  $got->value('Strategy')
  54                                                  );
  55     }
  56     else {
  57         #return CompressPlugin::Deflate::mkCompObject($self, $class, $got)
  58         ($obj, $errstr, $errno) = CompressPlugin::Deflate::mkCompObject(
  59                                                  $got->value('CRC32'),
  60                                                  $got->value('Adler32'),
  61                                                  $got->value('Level'),
  62                                                  $got->value('Strategy')
  63                                                  );
  64     }
  65
  66    return $self->saveErrorString(undef, $errstr, $errno)
  67        if ! defined $obj;
  68
  69    return $obj;
  70 }
  71
  72
  73
  74 sub mkHeader
  75 {
  76     my $self  = shift;
  77     my $param = shift ;
  78
  79     my $filename = '';
  80     $filename = $param->value('Name') || '';
  81
  82     my $comment = '';
  83     $comment = $param->value('Comment') || '';
  84
  85     my $extract = $param->value('OS_Code') << 8 + 20 ;
  86     my $hdr = '';
  87
  88     my $time = _unixToDosTime($param->value('Time'));
  89     *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} ;
  90
  91     my $strm = *$self->{ZipData}{Stream} ? 8 : 0 ;
  92     my $method = *$self->{ZipData}{Store} ? 0 : 8 ;
  93
  94     $hdr .= pack "V", 0x04034b50 ; # signature
  95     $hdr .= pack 'v', $extract   ; # extract Version & OS
  96     $hdr .= pack 'v', $strm      ; # general purpose flag (set streaming mode)
  97     $hdr .= pack 'v', $method    ; # compression method (deflate)
  98     $hdr .= pack 'V', $time      ; # last mod date/time
  99     $hdr .= pack 'V', 0          ; # crc32               - 0 when streaming
 100     $hdr .= pack 'V', 0          ; # compressed length   - 0 when streaming
 101     $hdr .= pack 'V', 0          ; # uncompressed length - 0 when streaming
 102     $hdr .= pack 'v', length $filename ; # filename length
 103     $hdr .= pack 'v', 0          ; # extra length
 104
 105     $hdr .= $filename ;
 106
 107
 108     my $ctl = '';
 109
 110     $ctl .= pack "V", 0x02014b50 ; # signature
 111     $ctl .= pack 'v', $extract   ; # version made by
 112     $ctl .= pack 'v', $extract   ; # extract Version
 113     $ctl .= pack 'v', $strm      ; # general purpose flag (streaming mode)
 114     $ctl .= pack 'v', $method    ; # compression method (deflate)
 115     $ctl .= pack 'V', $time      ; # last mod date/time
 116     $ctl .= pack 'V', 0          ; # crc32
 117     $ctl .= pack 'V', 0          ; # compressed length
 118     $ctl .= pack 'V', 0          ; # uncompressed length
 119     $ctl .= pack 'v', length $filename ; # filename length
 120     $ctl .= pack 'v', 0          ; # extra length
 121     $ctl .= pack 'v', length $comment ;  # file comment length
 122     $ctl .= pack 'v', 0          ; # disk number start
 123     $ctl .= pack 'v', 0          ; # internal file attributes
 124     $ctl .= pack 'V', 0          ; # external file attributes
 125     $ctl .= pack 'V', *$self->{ZipData}{Offset}  ; # offset to local header
 126
 127     $ctl .= $filename ;
 128     #$ctl .= $extra ;
 129     $ctl .= $comment ;
 130
 131     *$self->{ZipData}{Offset} += length $hdr ;
 132
 133     *$self->{ZipData}{CentralHeader} = $ctl;
 134
 135     return $hdr;
 136 }
 137
 138 sub mkTrailer
 139 {
 140     my $self = shift ;
 141
 142     my $crc32             = *$self->{Compress}->crc32();
 143     my $compressedBytes   = *$self->{Compress}->compressedBytes();
 144     my $uncompressedBytes = *$self->{Compress}->uncompressedBytes();
 145
 146     my $data ;
 147     $data .= pack "V", $crc32 ;                           # CRC32
 148     $data .= pack "V", $compressedBytes   ;               # Compressed Size
 149     $data .= pack "V", $uncompressedBytes;                # Uncompressed Size
 150
 151     my $hdr = '';
 152
 153     if (*$self->{ZipData}{Stream}) {
 154         $hdr  = pack "V", 0x08074b50 ;                       # signature
 155         $hdr .= $data ;
 156     }
 157     else {
 158         $self->writeAt(*$self->{ZipData}{StartOffset} + 14, $data)
 159             or return undef;
 160     }
 161
 162     my $ctl = *$self->{ZipData}{CentralHeader} ;
 163     substr($ctl, 16, 12) = $data ;
 164     #substr($ctl, 16, 4) = pack "V", $crc32 ;             # CRC32
 165     #substr($ctl, 20, 4) = pack "V", $compressedBytes   ; # Compressed Size
 166     #substr($ctl, 24, 4) = pack "V", $uncompressedBytes ; # Uncompressed Size
 167
 168     *$self->{ZipData}{Offset} += length($hdr) + $compressedBytes;
 169     push @{ *$self->{ZipData}{CentralDir} }, $ctl ;
 170
 171     return $hdr;
 172 }
 173
 174 sub mkFinalTrailer
 175 {
 176     my $self = shift ;
 177
 178     my $entries = @{ *$self->{ZipData}{CentralDir} };
 179     my $cd = join '', @{ *$self->{ZipData}{CentralDir} };
 180
 181     my $ecd = '';
 182     $ecd .= pack "V", 0x06054b50 ; # signature
 183     $ecd .= pack 'v', 0          ; # number of disk
 184     $ecd .= pack 'v', 0          ; # number if disk with central dir
 185     $ecd .= pack 'v', $entries   ; # entries in central dir on this disk
 186     $ecd .= pack 'v', $entries   ; # entries in central dir
 187     $ecd .= pack 'V', length $cd ; # size of central dir
 188     $ecd .= pack 'V', *$self->{ZipData}{Offset} ; # offset to start central dir
 189     $ecd .= pack 'v', 0          ; # zipfile comment length
 190     #$ecd .= $comment;
 191
 192     return $cd . $ecd ;
 193 }
 194
 195 sub ckParams
 196 {
 197     my $self = shift ;
 198     my $got = shift;
 199
 200     $got->value('CRC32' => 1);
 201
 202     if (! $got->parsed('Time') ) {
 203         # Modification time defaults to now.
 204         $got->value('Time' => time) ;
 205     }
 206
 207     *$self->{ZipData}{Stream} = $got->value('Stream');
 208     *$self->{ZipData}{Store} = $got->value('Store');
 209     *$self->{ZipData}{StartOffset} = *$self->{ZipData}{Offset} = 0;
 210
 211     return 1 ;
 212 }
 213
 214 #sub newHeader
 215 #{
 216 #    my $self = shift ;
 217 #
 218 #    return $self->mkHeader(*$self->{Got});
 219 #}
 220
 221 sub getExtraParams
 222 {
 223     my $self = shift ;
 224
 225     use Compress::Zlib::ParseParameters;
 226     use Compress::Zlib qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
 227
 228
 229     return (
 230             # zlib behaviour
 231             $self->getZlibParams(),
 232
 233             'Stream'    => [1, 1, Parse_boolean,   1],
 234             'Store'     => [0, 1, Parse_boolean,   0],
 235
 236 #            # Zip header fields
 237 #           'Minimal'   => [0, 1, Parse_boolean,   0],
 238             'Comment'   => [0, 1, Parse_any,       undef],
 239             'ZipComment'=> [0, 1, Parse_any,       undef],
 240             'Name'      => [0, 1, Parse_any,       undef],
 241             'Time'      => [0, 1, Parse_any,       undef],
 242             'OS_Code'   => [0, 1, Parse_unsigned,  $Compress::Zlib::gzip_os_code],
 243
 244 #           'TextFlag'  => [0, 1, Parse_boolean,   0],
 245 #           'ExtraField'=> [0, 1, Parse_string,    undef],
 246         );
 247 }
 248
 249 sub getInverseClass
 250 {
 251     return ('IO::Uncompress::Unzip',
 252                 \$IO::Uncompress::Unzip::UnzipError);
 253 }
 254
 255 sub getFileInfo
 256 {
 257     my $self = shift ;
 258     my $params = shift;
 259     my $filename = shift ;
 260
 261     my $defaultTime = (stat($filename))[9] ;
 262
 263     $params->value('Name' => $filename)
 264         if ! $params->parsed('Name') ;
 265
 266     $params->value('Time' => $defaultTime)
 267         if ! $params->parsed('Time') ;
 268
 269
 270 }
 271
 272 # from Archive::Zip
 273 sub _unixToDosTime    # Archive::Zip::Member
 274 {
 275         my $time_t = shift;
 276     # TODO - add something to cope with unix time < 1980
 277         my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
 278         my $dt = 0;
 279         $dt += ( $sec >> 1 );
 280         $dt += ( $min << 5 );
 281         $dt += ( $hour << 11 );
 282         $dt += ( $mday << 16 );
 283         $dt += ( ( $mon + 1 ) << 21 );
 284         $dt += ( ( $year - 80 ) << 25 );
 285         return $dt;
 286 }
 287
 288 1;
 289
 290 __END__