1BEGIN { 2 if ($ENV{PERL_CORE}) { 3 chdir 't' if -d 't'; 4 @INC = ("../lib", "lib/compress"); 5 } 6} 7 8use lib qw(t t/compress); 9use strict; 10use warnings; 11use bytes; 12 13use Test::More ; 14use File::Spec ; 15use CompTestUtils; 16 17BEGIN { 18 plan(skip_all => "oneshot needs Perl 5.005 or better - you have Perl $]" ) 19 if $] < 5.005 ; 20 21 22 # use Test::NoWarnings, if available 23 my $extra = 0 ; 24 $extra = 1 25 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; 26 27 plan tests => 230 + $extra ; 28 29 #use_ok('IO::Compress::Zip', qw(zip $ZipError :zip_method)) ; 30 use_ok('IO::Compress::Zip', qw(:all)) ; 31 use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; 32} 33 34 35sub zipGetHeader 36{ 37 my $in = shift; 38 my $content = shift ; 39 my %opts = @_ ; 40 41 my $out ; 42 my $got ; 43 44 ok zip($in, \$out, %opts), " zip ok" ; 45 ok unzip(\$out, \$got), " unzip ok" 46 or diag $UnzipError ; 47 is $got, $content, " got expected content" ; 48 49 my $gunz = IO::Uncompress::Unzip->new( \$out, Strict => 0 ) 50 or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ; 51 ok $gunz, " Created IO::Uncompress::Unzip object"; 52 my $hdr = $gunz->getHeaderInfo(); 53 ok $hdr, " got Header info"; 54 my $uncomp ; 55 ok $gunz->read($uncomp), " read ok" ; 56 is $uncomp, $content, " got expected content"; 57 ok $gunz->close, " closed ok" ; 58 59 return $hdr ; 60 61} 62 63{ 64 title "Check zip header default NAME & MTIME settings" ; 65 66 my $lex = LexFile->new( my $file1 ); 67 68 my $content = "hello "; 69 my $hdr ; 70 my $mtime ; 71 72 writeFile($file1, $content); 73 $mtime = (stat($file1))[9]; 74 # make sure that the zip file isn't created in the same 75 # second as the input file 76 sleep 3 ; 77 $hdr = zipGetHeader($file1, $content); 78 79 is $hdr->{Name}, $file1, " Name is '$file1'"; 80 is $hdr->{Time}>>1, $mtime>>1, " Time is ok"; 81 82 title "Override Name" ; 83 84 writeFile($file1, $content); 85 $mtime = (stat($file1))[9]; 86 sleep 3 ; 87 $hdr = zipGetHeader($file1, $content, Name => "abcde"); 88 89 is $hdr->{Name}, "abcde", " Name is 'abcde'" ; 90 is $hdr->{Time} >> 1, $mtime >> 1, " Time is ok"; 91 92 title "Override Time" ; 93 94 writeFile($file1, $content); 95 my $useTime = time + 2000 ; 96 $hdr = zipGetHeader($file1, $content, Time => $useTime); 97 98 is $hdr->{Name}, $file1, " Name is '$file1'" ; 99 is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; 100 101 title "Override Name and Time" ; 102 103 $useTime = time + 5000 ; 104 writeFile($file1, $content); 105 $hdr = zipGetHeader($file1, $content, Time => $useTime, Name => "abcde"); 106 107 is $hdr->{Name}, "abcde", " Name is 'abcde'" ; 108 is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; 109 110 title "Filehandle doesn't have default Name or Time" ; 111 my $fh = IO::File->new( "< $file1" ) 112 or diag "Cannot open '$file1': $!\n" ; 113 sleep 3 ; 114 my $before = time ; 115 $hdr = zipGetHeader($fh, $content); 116 my $after = time ; 117 118 ok ! defined $hdr->{Name}, " Name is undef"; 119 cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok"; 120 cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok"; 121 122 $fh->close; 123 124 title "Buffer doesn't have default Name or Time" ; 125 my $buffer = $content; 126 $before = time ; 127 $hdr = zipGetHeader(\$buffer, $content); 128 $after = time ; 129 130 ok ! defined $hdr->{Name}, " Name is undef"; 131 cmp_ok $hdr->{Time} >> 1, '>=', $before >> 1, " Time is ok"; 132 cmp_ok $hdr->{Time} >> 1, '<=', $after >> 1, " Time is ok"; 133} 134 135{ 136 title "Check CanonicalName & FilterName"; 137 138 my $lex = LexFile->new( my $file1 ); 139 140 my $content = "hello" ; 141 writeFile($file1, $content); 142 my $hdr; 143 144 my $abs = File::Spec->catfile("", "fred", "joe"); 145 $hdr = zipGetHeader($file1, $content, Name => $abs, CanonicalName => 1) ; 146 is $hdr->{Name}, "fred/joe", " Name is 'fred/joe'" ; 147 148 $hdr = zipGetHeader($file1, $content, Name => $abs, CanonicalName => 0) ; 149 is $hdr->{Name}, File::Spec->catfile("", "fred", "joe"), " Name is '/fred/joe'" ; 150 151 $hdr = zipGetHeader($file1, $content, FilterName => sub {$_ = "abcde"}); 152 is $hdr->{Name}, "abcde", " Name is 'abcde'" ; 153 154 $hdr = zipGetHeader($file1, $content, Name => $abs, 155 CanonicalName => 1, 156 FilterName => sub { s/joe/jim/ }); 157 is $hdr->{Name}, "fred/jim", " Name is 'fred/jim'" ; 158 159 $hdr = zipGetHeader($file1, $content, Name => $abs, 160 CanonicalName => 0, 161 FilterName => sub { s/joe/jim/ }); 162 is $hdr->{Name}, File::Spec->catfile("", "fred", "jim"), " Name is '/fred/jim'" ; 163} 164 165{ 166 title "Detect encrypted zip file"; 167 168 my $files = "./t/" ; 169 $files = "./" if $ENV{PERL_CORE} ; 170 $files .= "files/"; 171 172 my $zipfile = "$files/encrypt-standard.zip" ; 173 my $output; 174 175 ok ! unzip "$files/encrypt-standard.zip" => \$output ; 176 like $UnzipError, qr/Encrypted content not supported/ ; 177 178 ok ! unzip "$files/encrypt-aes.zip" => \$output ; 179 like $UnzipError, qr/Encrypted content not supported/ ; 180} 181 182{ 183 title "jar file with deflated directory"; 184 185 # Create Jar as follow 186 # echo test > file && jar c file > jar.zip 187 188 # Note the deflated directory META-INF with length 0 & size 2 189 # 190 # $ unzip -vl t/files/jar.zip 191 # Archive: t/files/jar.zip 192 # Length Method Size Cmpr Date Time CRC-32 Name 193 # -------- ------ ------- ---- ---------- ----- -------- ---- 194 # 0 Defl:N 2 0% 2019-09-07 22:35 00000000 META-INF/ 195 # 54 Defl:N 53 2% 2019-09-07 22:35 934e49ff META-INF/MANIFEST.MF 196 # 5 Defl:N 7 -40% 2019-09-07 22:35 3bb935c6 file 197 # -------- ------- --- ------- 198 # 59 62 -5% 3 files 199 200 201 my $files = "./t/" ; 202 $files = "./" if $ENV{PERL_CORE} ; 203 $files .= "files/"; 204 205 my $zipfile = "$files/jar.zip" ; 206 my $output; 207 208 ok unzip $zipfile => \$output ; 209 210 is $output, "" ; 211 212} 213 214for my $stream (0, 1) 215{ 216 for my $zip64 (0, 1) 217 { 218 #next if $zip64 && ! $stream; 219 220 for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE) 221 { 222 223 title "Stream $stream, Zip64 $zip64, Method $method"; 224 225 my $lex = LexFile->new( my $file1 ); 226 227 my $content = "hello "; 228 #writeFile($file1, $content); 229 230 my $status = zip(\$content => $file1 , 231 Method => $method, 232 Stream => $stream, 233 Zip64 => $zip64); 234 235 ok $status, " zip ok" 236 or diag $ZipError ; 237 238 my $got ; 239 ok unzip($file1 => \$got), " unzip ok" 240 or diag $UnzipError ; 241 242 is $got, $content, " content ok"; 243 244 my $u = IO::Uncompress::Unzip->new( $file1 ) 245 or diag $ZipError ; 246 247 my $hdr = $u->getHeaderInfo(); 248 ok $hdr, " got header"; 249 250 is $hdr->{Stream}, $stream, " stream is $stream" ; 251 is $hdr->{MethodID}, $method, " MethodID is $method" ; 252 is $hdr->{Zip64}, $zip64, " Zip64 is $zip64" ; 253 } 254 } 255} 256 257for my $stream (0, 1) 258{ 259 for my $zip64 (0, 1) 260 { 261 next if $zip64 && ! $stream; 262 for my $method (ZIP_CM_STORE, ZIP_CM_DEFLATE) 263 { 264 title "Stream $stream, Zip64 $zip64, Method $method"; 265 266 my $file1; 267 my $file2; 268 my $zipfile; 269 my $lex = LexFile->new( $file1, $file2, $zipfile ); 270 271 my $content1 = "hello "; 272 writeFile($file1, $content1); 273 274 my $content2 = "goodbye "; 275 writeFile($file2, $content2); 276 277 my %content = ( $file1 => $content1, 278 $file2 => $content2, 279 ); 280 281 ok zip([$file1, $file2] => $zipfile , Method => $method, 282 Zip64 => $zip64, 283 Stream => $stream), " zip ok" 284 or diag $ZipError ; 285 286 for my $file ($file1, $file2) 287 { 288 my $got ; 289 ok unzip($zipfile => \$got, Name => $file), " unzip $file ok" 290 or diag $UnzipError ; 291 292 is $got, $content{$file}, " content ok"; 293 } 294 } 295 } 296} 297 298{ 299 title "Regression: ods streaming issue"; 300 301 # The file before meta.xml in test.ods is content.xml. 302 # Issue was triggered because content.xml was stored 303 # as streamed and the code to walk the compressed streaming 304 # content assumed that all of the input buffer was consumed 305 # in a single call to "uncompr". 306 307 my $files = "./t/" ; 308 $files = "./" if $ENV{PERL_CORE} ; 309 $files .= "files/"; 310 311 my $zipfile = "$files/test.ods" ; 312 my $file = "meta.xml"; 313 314 my $got; 315 316 ok unzip($zipfile => \$got, Name => $file), " unzip $file ok" 317 or diag $UnzipError ; 318 319 my $meta = '<?xml version="1.0" encoding="UTF-8"?> 320<office:document-meta xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:grddl="http://www.w3.org/2003/g/data-view#" office:version="1.2"><office:meta><meta:creation-date>2018-12-25T11:36:11.437260543</meta:creation-date><dc:date>2018-12-25T11:36:55.657945697</dc:date><meta:editing-duration>PT54S</meta:editing-duration><meta:editing-cycles>1</meta:editing-cycles><meta:document-statistic meta:table-count="1" meta:cell-count="3" meta:object-count="0"/><meta:generator>LibreOffice/6.0.7.3$Linux_X86_64 LibreOffice_project/00m0$Build-3</meta:generator></office:meta></office:document-meta>'; 321 322 is $got, $meta, " content ok"; 323 324} 325 326{ 327 title "Regression: odt non-streaming issue"; 328 # https://github.com/pmqs/IO-Compress/issues/13 329 330 # Some programs (LibreOffice) mark entries as Streamed (bit 3 of the General Purpose Bit Flags field is set) , 331 # but still fill out the Compressed Length, Uncompressed Length & CRC32 fields in the local file header 332 333 my $files = "./t/" ; 334 $files = "./" if $ENV{PERL_CORE} ; 335 $files .= "files/"; 336 337 my $zipfile = "$files/testfile1.odt" ; 338 my $file = "manifest.rdf"; 339 340 my $got; 341 342 ok unzip($zipfile => \$got, Name => $file), " unzip $file ok" 343 or diag $UnzipError ; 344 345 my $meta = <<'EOM'; 346<?xml version="1.0" encoding="utf-8"?> 347<rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> 348 <rdf:Description rdf:about=""> 349 <rdf:type rdf:resource="http://docs.oasis-open.org/ns/office/1.2/meta/pkg#Document"/> 350 </rdf:Description> 351</rdf:RDF> 352EOM 353 is $got, $meta, " content ok"; 354} 355 356# TODO add more error cases 357