File Coverage

blib/lib/Archive/Zip/Crypt.pm
Criterion Covered Total %
statement 89 92 96.7
branch 23 44 52.2
condition 2 6 33.3
subroutine 13 13 100.0
pod n/a
total 127 155 81.9


line stmt bran cond sub pod time code
1             package Archive::Zip::Crypt;
2 2     2   128647 use v5.008;
  2         8  
  2         1431  
3 2     2   11 use strict;
  2         4  
  2         80  
4 2     2   1343 use Archive::Zip qw/ :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS /;
  2         259368  
  2         11214  
5              
6             =head1 NAME
7              
8             Archive::Zip::Crypt - Unpacking of password protected archives for Archive::Zip
9              
10             =head1 VERSION
11              
12             Version 0.02
13              
14             =cut
15              
16             our $VERSION = '0.02';
17              
18              
19             =head1 SYNOPSIS
20              
21             This is a little hack that adds the capability to unpack password-protected
22             archives to L. It adds a C method to
23             L (passwords may be different for different archive
24             members!) and overwrites a few others so they can use the decryption
25             functionality, so it may break wit Archive::Zip versions >1.30. This is a pure
26             Perl implementation and really slow as bit-fiddling stuff in Perl tends to be.
27              
28             use Archive::Zip;
29             use Archive::Zip::Crypt;
30              
31             my $zip = Archive::Zip->new($archive_name) or die "can't unzip";
32             foreach my $member_name ($zip->memberNames) {
33             my $member = $zip->memberNamed($member_name);
34             next if $member->isDirectory;
35             $member->password($password);
36             my $contents = $zip->contents($member) or die "error accessing $member_name";
37             }
38              
39             Note: it is important to C first, so C
40             can smear its bugs all over the former's namespace.
41              
42             =head1 METHODS
43              
44             =head2 Archive::Zip::Member::password($password)
45              
46             Set the encryption password on a member if called with an argument. Always
47             returns the current password.
48              
49             =cut
50              
51             =head1 AUTHOR
52              
53             Matthias Bethke, C<< >>
54              
55             =head1 BUGS
56              
57             None known but highly likely to be there. Please report any bugs or feature
58             requests to C, or through the web
59             interface at
60             L. I will be
61             notified, and then you'll automatically be notified of progress on your bug as
62             I make changes.
63              
64             =head1 ACKNOWLEDGEMENTS
65              
66             This was written as part of a project for 1&1 Internet AG. Thanks to them for supporting OSS!
67              
68             =head1 LICENSE AND COPYRIGHT
69              
70             Copyright 2008-2012 Matthias Bethke.
71              
72             This program is free software; you can redistribute it and/or modify it
73             under the terms of either: the GNU General Public License as published
74             by the Free Software Foundation; or the Artistic License.
75              
76             See http://dev.perl.org/licenses/ for more information.
77              
78              
79             =cut
80              
81             {
82             my @crc32tab = (
83             0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419,
84             0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4,
85             0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07,
86             0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de,
87             0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856,
88             0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
89             0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4,
90             0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b,
91             0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3,
92             0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a,
93             0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599,
94             0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
95             0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190,
96             0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f,
97             0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e,
98             0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01,
99             0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed,
100             0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
101             0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3,
102             0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2,
103             0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a,
104             0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5,
105             0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010,
106             0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
107             0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17,
108             0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6,
109             0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615,
110             0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8,
111             0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344,
112             0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
113             0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a,
114             0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5,
115             0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1,
116             0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c,
117             0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef,
118             0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
119             0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe,
120             0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31,
121             0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c,
122             0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713,
123             0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b,
124             0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
125             0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1,
126             0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c,
127             0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278,
128             0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7,
129             0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66,
130             0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
131             0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605,
132             0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8,
133             0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b,
134             0x2d02ef8d
135             );
136              
137             # Straightforward port of unzip's crc32().
138             # Other Perl implementations don't seem to behave the same
139             sub _crypt_crc32 {
140 84     84   124 return $crc32tab[($_[0] ^ $_[1]) & 0xff] ^ ($_[0] >> 8);
141             }
142             }
143              
144             # Do one scrambling step to obtain the next keystream byte
145             sub _update_keys {
146 2     2   24 use integer;
  2         5  
  2         18  
147 42     42   42 my $keyz = shift->{keyz};
148 42         62 $keyz->[0] = _crypt_crc32($keyz->[0], $_[0]);
149 42         41 $keyz->[1] += $keyz->[0] & 0xff;
150 42         43 $keyz->[1] = ($keyz->[1] * 134775813) + 1;
151 42         65 $keyz->[2] = _crypt_crc32($keyz->[2], $keyz->[1]>>24);
152 42         44 my $t = ($keyz->[2] | 3) & 0xffff;
153 42         62 $keyz->[3] = (($t * ($t ^ 1)) >> 8) & 0xff;
154             }
155              
156             # Initialize keys with a password that must be in $self->{password}
157             sub _init_keys {
158 2     2   2 my $self = shift;
159 2         3 @{$self->{keyz}} = (0x12345678, 0x23456789, 0x34567890);
  2         8  
160 2         13 _update_keys($self, ord($_)) foreach(unpack '(A1)*', $self->{password});
161             }
162              
163             # Decrypt a string passed in as a parameter and overwrite(!) it with the decrypted version.
164             sub _decrypt {
165 2     2   3 my $self = shift;
166 2         2 my $out;
167              
168 2         2 foreach(unpack '(A1)*', ${$_[0]}) {
  2         11  
169 32         44 my $t = chr($self->{keyz}[3] ^ ord($_));
170 32         38 _update_keys($self, ord($t));
171 32         37 $out .= $t;
172             }
173 2         5 ${$_[0]} = $out;
  2         3  
174             }
175              
176 2     2   551 no warnings 'redefine'; # Prepare for ugliness
  2         3  
  2         1968  
177              
178             # New public method: set decryption password on a member
179             *Archive::Zip::Member::password = sub {
180 2     2   1344 my ($self, $pw) = @_;
181 2 50       7 defined $pw and $self->{password} = $pw;
182 2         4 $self->{password};
183             };
184              
185             # Replaces original method
186             *Archive::Zip::Member::readChunk = sub {
187 4     4   81 my ( $self, $chunkSize ) = @_;
188              
189 4 100       12 if ( $self->readIsDone() ) {
190 2         12 $self->endRead();
191 2         15 my $dummy = '';
192 2         5 return ( \$dummy, AZ_STREAM_END );
193             }
194              
195 2 50       21 $chunkSize = $Archive::Zip::ChunkSize if not defined $chunkSize;
196 2 50       10 $chunkSize = $self->_readDataRemaining()
197             if $chunkSize > $self->_readDataRemaining();
198              
199 2         8 my $buffer = '';
200 2         3 my $outputRef;
201 2         6 my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
202 2 50       43 return ( \$buffer, $status ) unless $status == AZ_OK;
203              
204             # Begin patch
205 2 50       21 if($self->isEncrypted) {
206 2 50       71 unless($self->{readOffset}) {
207 2 50       4 croak("can't decrypt, use \$member->password('mypassword') first") unless defined $self->{password};
208 2         6 Archive::Zip::Crypt::_init_keys($self);
209             }
210 2         6 Archive::Zip::Crypt::_decrypt($self,\$buffer);
211 2 50       7 $buffer = substr($buffer,12) unless $self->{readOffset};
212             }
213             # End patch
214              
215 2         2 $self->{'readDataRemaining'} -= $bytesRead;
216 2         3 $self->{'readOffset'} += $bytesRead;
217              
218 2 50       5 if ( $self->compressionMethod() == COMPRESSION_STORED ) {
219 2         16 $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
220             }
221              
222 2         28 ( $outputRef, $status ) = &{ $self->{'chunkHandler'} }( $self, \$buffer );
  2         6  
223 2         9 $self->{'writeOffset'} += length($$outputRef);
224              
225 2 50       5 $self->endRead()
226             if $self->readIsDone();
227              
228 2         54 return ( $outputRef, $status );
229             };
230              
231             # Replaces original method. Avoids patching larger methods just to fool them
232             # about encryption. Yes, it's ugly :)
233             *Archive::Zip::Member::isEncrypted = sub {
234 4 50   4   21 return 0 if((caller(1))[3] =~ /::(?:extractToFile(?:Handle|Named))$/);
235 4         16 shift->bitFlag() & GPBF_ENCRYPTED_MASK;
236             };
237              
238              
239             # Replaces original method. Just takes the 12 bytes of encryption header into
240             # account if present
241             *Archive::Zip::ZipFileMember::_skipLocalFileHeader = sub {
242 2     2   529 my $self = shift;
243 2         2 my $header;
244 2         6 my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
245 2 50       27 if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH ) {
246 0         0 return _ioError("reading local file header");
247             }
248 2         3 my $fileNameLength;
249             my $extraFieldLength;
250 0         0 my $bitFlag;
251             (
252             undef, # $self->{'versionNeededToExtract'},
253 2         6 $bitFlag,
254             undef, # $self->{'compressionMethod'},
255             undef, # $self->{'lastModFileDateTime'},
256             undef, # $crc32,
257             undef, # $compressedSize,
258             undef, # $uncompressedSize,
259             $fileNameLength,
260             $extraFieldLength
261             ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
262              
263 2 50       8 if ($fileNameLength) {
264 2 50       5 $self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
265             or return _ioError("skipping local file name");
266             }
267              
268 2 50       37 if ($extraFieldLength) {
269 2         5 $bytesRead =
270             $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
271 2 50       32 if ( $bytesRead != $extraFieldLength ) {
272 0         0 return _ioError("reading local extra field");
273             }
274             }
275              
276 2         6 $self->{'dataOffset'} = $self->fh()->tell();
277              
278 2 50       25 if ( $bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK ) {
279              
280             # Read the crc32, compressedSize, and uncompressedSize from the
281             # extended data descriptor, which directly follows the compressed data.
282             #
283             # Skip over the compressed file data (assumes that EOCD compressedSize
284             # was correct)
285 2 50       5 $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
286             or return _ioError("seeking to extended local header");
287              
288             # these values should be set correctly from before.
289 2         34 my $oldCrc32 = $self->{'eocdCrc32'};
290 2         4 my $oldCompressedSize = $self->{'compressedSize'};
291 2         2 my $oldUncompressedSize = $self->{'uncompressedSize'};
292              
293 2         6 my $status = $self->_readDataDescriptor();
294 2 50       75 return $status unless $status == AZ_OK;
295              
296             # Begin patch
297             # Account for 12 bytes of encryption header in $oldUncompressedSize for encrypted members
298             # TODO uncompressedSize seems to differ only for some types of archives?
299 2 50 33     24 $oldUncompressedSize -= 12 if($self->isEncrypted and $oldUncompressedSize != $self->{'uncompressedSize'});
300             # End patch
301              
302 2 50 33     99 return _formatError(
303             "CRC or size mismatch while skipping data descriptor")
304             if ( $oldCrc32 != $self->{'crc32'}
305             || $oldUncompressedSize != $self->{'uncompressedSize'} );
306             }
307              
308 2         4 return AZ_OK;
309             };
310              
311             1;