xref: /openbsd-src/gnu/usr.bin/perl/cpan/IO-Compress/bin/zipdetails (revision f2da64fbbbf1b03f09f390ab01267c93dfd77c4c) 
1#!/usr/bin/perl
2
3# zipdetails
4#
5# Display info on the contents of a Zip file
6#
7
8BEGIN { pop @INC if $INC[-1] eq '.' }
9use strict;
10use warnings ;
11
12use IO::File;
13use Encode;
14
15# Compression types
16use constant ZIP_CM_STORE                      => 0 ;
17use constant ZIP_CM_IMPLODE                    => 6 ;
18use constant ZIP_CM_DEFLATE                    => 8 ;
19use constant ZIP_CM_BZIP2                      => 12 ;
20use constant ZIP_CM_LZMA                       => 14 ;
21use constant ZIP_CM_PPMD                       => 98 ;
22
23# General Purpose Flag
24use constant ZIP_GP_FLAG_ENCRYPTED_MASK        => (1 << 0) ;
25use constant ZIP_GP_FLAG_STREAMING_MASK        => (1 << 3) ;
26use constant ZIP_GP_FLAG_PATCHED_MASK          => (1 << 5) ;
27use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => (1 << 6) ;
28use constant ZIP_GP_FLAG_LZMA_EOS_PRESENT      => (1 << 1) ;
29use constant ZIP_GP_FLAG_LANGUAGE_ENCODING     => (1 << 11) ;
30
31# Internal File Attributes
32use constant ZIP_IFA_TEXT_MASK                 => 1;
33
34# Signatures for each of the headers
35use constant ZIP_LOCAL_HDR_SIG                 => 0x04034b50;
36use constant ZIP_DATA_HDR_SIG                  => 0x08074b50;
37use constant ZIP_CENTRAL_HDR_SIG               => 0x02014b50;
38use constant ZIP_END_CENTRAL_HDR_SIG           => 0x06054b50;
39use constant ZIP64_END_CENTRAL_REC_HDR_SIG     => 0x06064b50;
40use constant ZIP64_END_CENTRAL_LOC_HDR_SIG     => 0x07064b50;
41use constant ZIP64_ARCHIVE_EXTRA_SIG           => 0x08064b50;
42use constant ZIP64_DIGITAL_SIGNATURE_SIG       => 0x05054b50;
43
44use constant ZIP_ARCHIVE_EXTRA_DATA_RECORD_SIG => 0x08064b50;
45
46# Extra sizes
47use constant ZIP_EXTRA_HEADER_SIZE          => 2 ;
48use constant ZIP_EXTRA_MAX_SIZE             => 0xFFFF ;
49use constant ZIP_EXTRA_SUBFIELD_ID_SIZE     => 2 ;
50use constant ZIP_EXTRA_SUBFIELD_LEN_SIZE    => 2 ;
51use constant ZIP_EXTRA_SUBFIELD_HEADER_SIZE => ZIP_EXTRA_SUBFIELD_ID_SIZE +
52                                               ZIP_EXTRA_SUBFIELD_LEN_SIZE;
53use constant ZIP_EXTRA_SUBFIELD_MAX_SIZE    => ZIP_EXTRA_MAX_SIZE -
54                                               ZIP_EXTRA_SUBFIELD_HEADER_SIZE;
55
56my %ZIP_CompressionMethods =
57    (
58          0 => 'Stored',
59          1 => 'Shrunk',
60          2 => 'Reduced compression factor 1',
61          3 => 'Reduced compression factor 2',
62          4 => 'Reduced compression factor 3',
63          5 => 'Reduced compression factor 4',
64          6 => 'Imploded',
65          7 => 'Reserved for Tokenizing compression algorithm',
66          8 => 'Deflated',
67          9 => 'Enhanced Deflating using Deflate64(tm)',
68         10 => 'PKWARE Data Compression Library Imploding',
69         11 => 'Reserved by PKWARE',
70         12 => 'BZIP2 ',
71         13 => 'Reserved by PKWARE',
72         14 => 'LZMA',
73         15 => 'Reserved by PKWARE',
74         16 => 'Reserved by PKWARE',
75         17 => 'Reserved by PKWARE',
76         18 => 'File is compressed using IBM TERSE (new)',
77         19 => 'IBM LZ77 z Architecture (PFS)',
78         96 => 'WinZip JPEG Compression',
79         97 => 'WavPack compressed data',
80         98 => 'PPMd version I, Rev 1',
81         99 => 'AES Encryption',
82     );
83
84my %OS_Lookup = (
85    0   => "MS-DOS",
86    1   => "Amiga",
87    2   => "OpenVMS",
88    3   => "Unix",
89    4   => "VM/CMS",
90    5   => "Atari ST",
91    6   => "HPFS (OS/2, NT 3.x)",
92    7   => "Macintosh",
93    8   => "Z-System",
94    9   => "CP/M",
95    10  => "Windoxs NTFS or TOPS-20",
96    11  => "MVS or NTFS",
97    12  => "VSE or SMS/QDOS",
98    13  => "Acorn RISC OS",
99    14  => "VFAT",
100    15  => "alternate MVS",
101    16  => "BeOS",
102    17  => "Tandem",
103    18  => "OS/400",
104    19  => "OS/X (Darwin)",
105    30  => "AtheOS/Syllable",
106    );
107
108
109my %Lookup = (
110    ZIP_LOCAL_HDR_SIG,             \&LocalHeader,
111    ZIP_DATA_HDR_SIG,              \&DataHeader,
112    ZIP_CENTRAL_HDR_SIG,           \&CentralHeader,
113    ZIP_END_CENTRAL_HDR_SIG,       \&EndCentralHeader,
114    ZIP64_END_CENTRAL_REC_HDR_SIG, \&Zip64EndCentralHeader,
115    ZIP64_END_CENTRAL_LOC_HDR_SIG, \&Zip64EndCentralLocator,
116
117    # TODO - Archive Encryption Headers
118    #ZIP_ARCHIVE_EXTRA_DATA_RECORD_SIG
119);
120
121my %Extras = (
122      0x0001,  ['ZIP64', \&decode_Zip64],
123      0x0007,  ['AV Info', undef],
124      0x0008,  ['Extended Language Encoding', undef],
125      0x0009,  ['OS/2 extended attributes', undef],
126      0x000a,  ['NTFS FileTimes', \&decode_NTFS_Filetimes],
127      0x000c,  ['OpenVMS', undef],
128      0x000d,  ['Unix', undef],
129      0x000e,  ['Stream & Fork Descriptors', undef],
130      0x000f,  ['Patch Descriptor', undef],
131      0x0014,  ['PKCS#7 Store for X.509 Certificates', undef],
132      0x0015,  ['X.509 Certificate ID and Signature for individual file', undef],
133      0x0016,  ['X.509 Certificate ID for Central Directory', undef],
134      0x0017,  ['Strong Encryption Header', undef],
135      0x0018,  ['Record Management Controls', undef],
136      0x0019,  ['PKCS#7 Encryption Recipient Certificate List', undef],
137
138
139      #The Header ID mappings defined by Info-ZIP and third parties are:
140
141      0x0065,  ['IBM S/390 attributes - uncompressed', undef],
142      0x0066,  ['IBM S/390 attributes - compressed', undef],
143      0x07c8,  ['Info-ZIP Macintosh (old, J. Lee)', undef],
144      0x2605,  ['ZipIt Macintosh (first version)', undef],
145      0x2705,  ['ZipIt Macintosh v 1.3.5 and newer (w/o full filename)', undef],
146      0x2805,  ['ZipIt Macintosh v 1.3.5 and newer ', undef],
147      0x334d,  ["Info-ZIP Macintosh (new, D. Haase's 'Mac3' field)", undef],
148      0x4154,  ['Tandem NSK', undef],
149      0x4341,  ['Acorn/SparkFS (David Pilling)', undef],
150      0x4453,  ['Windows NT security descriptor', \&decode_NT_security],
151      0x4690,  ['POSZIP 4690', undef],
152      0x4704,  ['VM/CMS', undef],
153      0x470f,  ['MVS', undef],
154      0x4854,  ['Theos, old inofficial port', undef],
155      0x4b46,  ['FWKCS MD5 (see below)', undef],
156      0x4c41,  ['OS/2 access control list (text ACL)', undef],
157      0x4d49,  ['Info-ZIP OpenVMS (obsolete)', undef],
158      0x4d63,  ['Macintosh SmartZIP, by Macro Bambini', undef],
159      0x4f4c,  ['Xceed original location extra field', undef],
160      0x5356,  ['AOS/VS (binary ACL)', undef],
161      0x5455,  ['Extended Timestamp', \&decode_UT],
162      0x554e,  ['Xceed unicode extra field', \&decode_Xceed_unicode],
163      0x5855,  ['Info-ZIP Unix (original; also OS/2, NT, etc.)', \&decode_UX],
164      0x5a4c,  ['ZipArchive Unicode Filename', undef],
165      0x5a4d,  ['ZipArchive Offsets Array', undef],
166      0x6375,  ["Info-ZIP Unicode Comment", \&decode_up ],
167      0x6542,  ['BeOS (BeBox, PowerMac, etc.)', undef],
168      0x6854,  ['Theos', undef],
169      0x7075,  ["Info-ZIP Unicode Path", \&decode_up ],
170      0x756e,  ['ASi Unix', undef],
171      0x7441,  ['AtheOS (AtheOS/Syllable attributes)', undef],
172      0x7855,  ["Unix Extra type 2", \&decode_Ux],
173      0x7875,  ["Unix Extra Type 3", \&decode_ux],
174      0x9901,  ['AES Encryption', \&decode_AES],
175      0xA220,  ["Microsoft Microsoft Open Packaging Growth Hint", undef ],
176      0xCAFE,  ["Java Executable", \&decode_Java_exe],
177      0xfb4a,  ['SMS/QDOS', undef],
178
179       );
180
181my $VERSION = "1.06_01" ;
182
183my $FH;
184
185my $ZIP64 = 0 ;
186my $NIBBLES = 8;
187my $LocalHeaderCount = 0;
188my $CentralHeaderCount = 0;
189
190my $START;
191my $OFFSET = new U64 0;
192my $TRAILING = 0 ;
193my $PAYLOADLIMIT = new U64 256;
194my $ZERO = new U64 0 ;
195
196sub prOff
197{
198    my $offset = shift;
199    my $s = offset($OFFSET);
200    $OFFSET->add($offset);
201    return $s;
202}
203
204sub offset
205{
206    my $v = shift ;
207
208    if (ref $v eq 'U64') {
209        my $hi = $v->getHigh();
210        my $lo = $v->getLow();
211
212        if ($hi)
213        {
214            my $hiNib = $NIBBLES - 8 ;
215            sprintf("%0${hiNib}X", $hi) .
216            sprintf("%08X", $lo);
217        }
218        else
219        {
220            sprintf("%0${NIBBLES}X", $lo);
221        }
222    }
223    else {
224        sprintf("%0${NIBBLES}X", $v);
225    }
226
227}
228
229my ($OFF,  $LENGTH,  $CONTENT, $TEXT, $VALUE) ;
230
231my $FMT1 ;
232my $FMT2 ;
233
234sub setupFormat
235{
236    my $wantVerbose = shift ;
237    my $nibbles = shift;
238
239    my $width = '@' . ('>' x ($nibbles -1));
240    my $space = " " x length($width);
241
242    my $fmt ;
243
244    if ($wantVerbose) {
245
246        $FMT1 = "
247        format STDOUT =
248$width $width ^<<<<<<<<<<<^<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
249\$OFF,     \$LENGTH,  \$CONTENT, \$TEXT,               \$VALUE
250$space $space ^<<<<<<<<<<<^<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
251                    \$CONTENT, \$TEXT,               \$VALUE
252.
253";
254
255        $FMT2 = "
256        format STDOUT =
257$width $width ^<<<<<<<<<<<  ^<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
258\$OFF,     \$LENGTH,  \$CONTENT, \$TEXT,               \$VALUE
259$space $space ^<<<<<<<<<<<  ^<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
260              \$CONTENT, \$TEXT,               \$VALUE
261.  " ;
262
263    }
264    else {
265
266        $FMT1 = "
267        format STDOUT =
268$width ^<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
269\$OFF,      \$TEXT,               \$VALUE
270$space ^<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
271                    \$TEXT,               \$VALUE
272.
273";
274
275        $FMT2 = "
276    format STDOUT =
277$width   ^<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
278\$OFF,     \$TEXT,               \$VALUE
279$space   ^<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
280                    \$TEXT,               \$VALUE
281.
282" ;
283    }
284
285    eval "$FMT1";
286
287    $| = 1;
288
289}
290
291sub mySpr
292{
293    my $format = shift ;
294
295    return "" if ! defined $format;
296    return $format unless @_ ;
297    return sprintf $format, @_ ;
298}
299
300sub out0
301{
302    my $size = shift;
303    my $text = shift;
304    my $format = shift;
305
306    $OFF     = prOff($size);
307    $LENGTH  = offset($size) ;
308    $CONTENT = '...';
309    $TEXT    = $text;
310    $VALUE   = mySpr $format,  @_;
311
312    write;
313
314    skip($FH, $size);
315}
316
317sub xDump
318{
319    my $input = shift;
320
321    $input =~ tr/\0-\37\177-\377/./;
322    return $input;
323}
324
325sub hexDump
326{
327    my $input = shift;
328
329    my $out = unpack('H*', $input) ;
330    $out =~ s#(..)# $1#g ;
331    $out =~ s/^ //;
332    $out = uc $out;
333
334    return $out;
335}
336
337sub out
338{
339    my $data = shift;
340    my $text = shift;
341    my $format = shift;
342
343    my $size = length($data) ;
344
345    $OFF     = prOff($size);
346    $LENGTH  = offset($size) ;
347    $CONTENT = hexDump($data);
348    $TEXT    = $text;
349    $VALUE   = mySpr $format,  @_;
350
351    no warnings;
352
353    write;
354}
355
356sub out1
357{
358    my $text = shift;
359    my $format = shift;
360
361    $OFF     = '';
362    $LENGTH  = '' ;
363    $CONTENT = '';
364    $TEXT    = $text;
365    $VALUE   = mySpr $format,  @_;
366
367    write;
368}
369
370sub out2
371{
372    my $data = shift ;
373    my $text = shift ;
374    my $format = shift;
375
376    my $size = length($data) ;
377    $OFF     = prOff($size);
378    $LENGTH  = offset($size);
379    $CONTENT = hexDump($data);
380    $TEXT    = $text;
381    $VALUE   = mySpr $format,  @_;
382
383    no warnings;
384    eval "$FMT2";
385    write ;
386    eval "$FMT1";
387}
388
389sub Value
390{
391    my $letter = shift;
392    my @value = @_;
393
394    if ($letter eq 'C')
395      { return Value_C(@value) }
396    elsif ($letter eq 'v')
397      { return Value_v(@value) }
398    elsif ($letter eq 'V')
399      { return Value_V(@value) }
400    elsif ($letter eq 'VV')
401      { return Value_VV(@value) }
402}
403
404sub outer
405{
406    my $name = shift ;
407    my $unpack = shift ;
408    my $size = shift ;
409    my $cb1  = shift ;
410    my $cb2  = shift ;
411
412
413    myRead(my $buff, $size);
414    my (@value) = unpack $unpack, $buff;
415    my $hex = Value($unpack,  @value);
416
417    if (defined $cb1) {
418        my $v ;
419        if (ref $cb1 eq 'CODE') {
420            $v = $cb1->(@value) ;
421        }
422        else {
423            $v = $cb1 ;
424        }
425
426        $v = "'" . $v unless $v =~ /^'/;
427        $v .= "'"  unless $v =~ /'$/;
428        $hex .= " $v" ;
429    }
430
431    out $buff, $name, $hex ;
432
433    $cb2->(@value)
434        if defined $cb2 ;
435
436    return $value[0];
437}
438
439sub out_C
440{
441    my $name = shift ;
442    my $cb1  = shift ;
443    my $cb2  = shift ;
444
445    outer($name, 'C', 1, $cb1, $cb2);
446}
447
448sub out_v
449{
450    my $name = shift ;
451    my $cb1  = shift ;
452    my $cb2  = shift ;
453
454    outer($name, 'v', 2, $cb1, $cb2);
455}
456
457sub out_V
458{
459    my $name = shift ;
460    my $cb1  = shift ;
461    my $cb2  = shift ;
462
463    outer($name, 'V', 4, $cb1, $cb2);
464}
465
466sub out_VV
467{
468    my $name = shift ;
469    my $cb1  = shift ;
470    my $cb2  = shift ;
471
472    outer($name, 'VV', 8, $cb1, $cb2);
473}
474
475sub outSomeData
476{
477    my $size = shift;
478    my $message = shift;
479
480    my $size64 = U64::mkU64($size);
481
482    if ($size64->gt($ZERO)) {
483        my $size32 = $size64->getLow();
484        if ($size64->gt($PAYLOADLIMIT) ) {
485            out0 $size32, $message;
486        } else {
487            myRead(my $buffer, $size32 );
488            out $buffer, $message, xDump $buffer ;
489        }
490    }
491}
492
493sub unpackValue_C
494{
495    Value_v(unpack "C", $_[0]);
496}
497
498sub Value_C
499{
500    sprintf "%02X", $_[0];
501}
502
503
504sub unpackValue_v
505{
506    Value_v(unpack "v", $_[0]);
507}
508
509sub Value_v
510{
511    sprintf "%04X", $_[0];
512}
513
514sub unpackValue_V
515{
516    Value_V(unpack "V", $_[0]);
517}
518
519sub Value_V
520{
521    my $v = defined $_[0] ? $_[0] : 0;
522    sprintf "%08X", $v;
523}
524
525sub unpackValue_VV
526{
527    my ($lo, $hi) = unpack ("V V", $_[0]);
528    Value_VV($lo, $hi);
529}
530
531sub Value_U64
532{
533    my $u64 = shift ;
534    Value_VV($u64->getLow(), $u64->getHigh());
535}
536
537sub Value_VV
538{
539    my $lo = defined $_[0] ? $_[0] : 0;
540    my $hi = defined $_[1] ? $_[1] : 0;
541
542    if ($hi == 0)
543    {
544        sprintf "%016X", $lo;
545    }
546    else
547    {
548        sprintf("%08X", $hi) .
549        sprintf "%08X", $lo;
550    }
551}
552
553sub Value_VV64
554{
555    my $buffer = shift;
556
557    my ($lo, $hi) = unpack ("V V" , $buffer);
558    no warnings 'uninitialized';
559    return $hi * (0xFFFFFFFF+1) + $lo;
560}
561
562sub read_U64
563{
564    my $b ;
565    myRead($b, 8);
566    my ($lo, $hi) = unpack ("V V" , $b);
567    no warnings 'uninitialized';
568    return ($b, new U64 $hi, $lo);
569}
570
571sub read_VV
572{
573    my $b ;
574    myRead($b, 8);
575    my ($lo, $hi) = unpack ("V V" , $b);
576    no warnings 'uninitialized';
577    return ($b, $hi * (0xFFFFFFFF+1) + $lo);
578}
579
580sub read_V
581{
582    my $b ;
583    myRead($b, 4);
584    return ($b, unpack ("V", $b));
585}
586
587sub read_v
588{
589    my $b ;
590    myRead($b, 2);
591    return ($b, unpack "v", $b);
592}
593
594
595sub read_C
596{
597    my $b ;
598    myRead($b, 1);
599    return ($b, unpack "C", $b);
600}
601
602
603my $opt_verbose = 0;
604while (@ARGV && $ARGV[0] =~ /^-/)
605{
606    my $opt = shift;
607
608    if ($opt =~ /^-h/i)
609    {
610        Usage();
611        exit;
612    }
613    elsif ($opt =~ /^-v/i)
614    {
615        $opt_verbose = 1;
616    }
617    else {
618        Usage();
619    }
620}
621
622Usage() unless @ARGV == 1;
623
624my $filename = shift @ARGV;
625
626die "$filename does not exist\n"
627    unless -e $filename ;
628
629die "$filename not a standard file\n"
630    unless -f $filename ;
631
632$FH = new IO::File "<$filename"
633    or die "Cannot open $filename: $!\n";
634
635
636my $FILELEN = -s $filename ;
637$TRAILING = -s $filename ;
638$NIBBLES = U64::nibbles(-s $filename) ;
639#$NIBBLES = int ($NIBBLES / 4) + ( ($NIBBLES % 4) ? 1 : 0 );
640#$NIBBLES = 4 * $NIBBLES;
641# Minimum of 4 nibbles
642$NIBBLES = 4 if $NIBBLES < 4 ;
643
644die "$filename too short to be a zip file\n"
645    if $FILELEN <  100 ;
646
647setupFormat($opt_verbose, $NIBBLES);
648
649if(0)
650{
651    # Sanity check that this is a Zip file
652    my ($buffer, $signature) = read_V();
653
654    warn "$filename doesn't look like a zip file\n"
655        if $signature != ZIP_LOCAL_HDR_SIG ;
656    $FH->seek(0, SEEK_SET) ;
657}
658
659
660our  @CentralDirectory = scanCentralDirectory($FH);
661die "No Central Directory found\n"
662    if ! @CentralDirectory ;
663
664$OFFSET->reset();
665$FH->seek(0, SEEK_SET) ;
666
667outSomeData($START, "PREFIX DATA")
668    if defined $START && $START > 0 ;
669
670while (1)
671{
672    last if $FH->eof();
673
674    if ($FH->tell() >= $TRAILING) {
675        print "\n" ;
676        outSomeData($FILELEN - $TRAILING, "TRAILING DATA");
677        last;
678
679    }
680
681    my ($buffer, $signature) = read_V();
682
683    my $handler = $Lookup{$signature};
684
685    if (!defined $handler)
686    {
687        my $offset = $FH->tell() - 4;
688        printf "\n\nUnexpecded END at offset %08X, value %s\n", $offset, Value_V($signature);
689        last;
690    }
691
692    $ZIP64 = 0 if $signature != ZIP_DATA_HDR_SIG ;
693    $handler->($signature, $buffer);
694}
695
696print "Done\n";
697
698exit ;
699
700sub compressionMethod
701{
702    my $id = shift ;
703    Value_v($id) . " '" . ($ZIP_CompressionMethods{$id} || "Unknown Method") . "'" ;
704}
705
706sub LocalHeader
707{
708    my $signature = shift ;
709    my $data = shift ;
710
711    print "\n";
712    ++ $LocalHeaderCount;
713    out $data, "LOCAL HEADER #" . sprintf("%X", $LocalHeaderCount) , Value_V($signature);
714
715    my $buffer;
716
717    my ($loc, $CDcompressedLength) = @{ shift @CentralDirectory };
718    # TODO - add test to check that the loc from central header matches
719
720    out_C  "Extract Zip Spec", \&decodeZipVer;
721    out_C  "Extract OS", \&decodeOS;
722
723    my ($bgp, $gpFlag) = read_v();
724    my ($bcm, $compressedMethod) = read_v();
725
726    out $bgp, "General Purpose Flag", Value_v($gpFlag) ;
727    GeneralPurposeBits($compressedMethod, $gpFlag);
728
729    out $bcm, "Compression Method",   compressionMethod($compressedMethod) ;
730
731    out_V "Last Mod Time", sub { scalar getTime(_dosToUnixTime($_[0])) };
732
733    my $crc                = out_V "CRC";
734    my $compressedLength   = out_V "Compressed Length";
735    my $uncompressedLength = out_V "Uncompressed Length";
736    my $filenameLength     = out_v "Filename Length";
737    my $extraLength        = out_v "Extra Length";
738
739    my $filename ;
740    myRead($filename, $filenameLength);
741    out $filename, "Filename",  "'". $filename . "'";
742
743    my $cl64 = new U64 $compressedLength ;
744    my %ExtraContext = ();
745    if ($extraLength)
746    {
747        my @z64 = ($uncompressedLength, $compressedLength, 1, 1);
748        $ExtraContext{Zip64} = \@z64 ;
749        $ExtraContext{InCentralDir} = 0;
750        walkExtra($extraLength, \%ExtraContext);
751    }
752
753    my $size = 0;
754    $size = printAes(\%ExtraContext)
755        if $compressedMethod == 99 ;
756
757    $size += printLzmaProperties()
758        if $compressedMethod == ZIP_CM_LZMA ;
759
760    $CDcompressedLength->subtract($size)
761        if $size ;
762
763    if ($CDcompressedLength->getHigh() || $CDcompressedLength->getLow()) {
764        outSomeData($CDcompressedLength, "PAYLOAD") ;
765    }
766
767    if ($compressedMethod == 99) {
768        my $auth ;
769        myRead($auth, 10);
770        out $auth, "AES Auth",  hexDump($auth);
771    }
772}
773
774
775sub CentralHeader
776{
777    my $signature = shift ;
778    my $data = shift ;
779
780    ++ $CentralHeaderCount;
781    print "\n";
782    out $data, "CENTRAL HEADER #" . sprintf("%X", $CentralHeaderCount) . "", Value_V($signature);
783    my $buffer;
784
785    out_C "Created Zip Spec", \&decodeZipVer;
786    out_C "Created OS", \&decodeOS;
787    out_C  "Extract Zip Spec", \&decodeZipVer;
788    out_C  "Extract OS", \&decodeOS;
789
790    my ($bgp, $gpFlag) = read_v();
791    my ($bcm, $compressedMethod) = read_v();
792
793    out $bgp, "General Purpose Flag", Value_v($gpFlag) ;
794    GeneralPurposeBits($compressedMethod, $gpFlag);
795
796    out $bcm, "Compression Method", compressionMethod($compressedMethod) ;
797
798    out_V "Last Mod Time", sub { scalar getTime(_dosToUnixTime($_[0])) };
799
800    my $crc                = out_V "CRC";
801    my $compressedLength   = out_V "Compressed Length";
802    my $uncompressedLength = out_V "Uncompressed Length";
803    my $filenameLength     = out_v "Filename Length";
804    my $extraLength        = out_v "Extra Length";
805    my $comment_length     = out_v "Comment Length";
806    my $disk_start         = out_v "Disk Start";
807    my $int_file_attrib    = out_v "Int File Attributes";
808
809    out1 "[Bit 0]",  $int_file_attrib & 1 ? "1 Text Data" : "0 'Binary Data'";
810
811    my $ext_file_attrib    = out_V "Ext File Attributes";
812    out1 "[Bit 0]",  "Read-Only"
813        if $ext_file_attrib & 0x01 ;
814    out1 "[Bit 1]",  "Hidden"
815        if $ext_file_attrib & 0x02 ;
816    out1 "[Bit 2]",  "System"
817        if $ext_file_attrib & 0x04 ;
818    out1 "[Bit 3]",  "Label"
819        if $ext_file_attrib & 0x08 ;
820    out1 "[Bit 4]",  "Directory"
821        if $ext_file_attrib & 0x10 ;
822    out1 "[Bit 5]",  "Archive"
823        if $ext_file_attrib & 0x20 ;
824
825    my $lcl_hdr_offset     = out_V "Local Header Offset";
826
827    my $filename ;
828    myRead($filename, $filenameLength);
829    out $filename, "Filename",  "'". $filename . "'";
830
831    my %ExtraContext = ();
832    if ($extraLength)
833    {
834        my @z64 = ($uncompressedLength, $compressedLength, $lcl_hdr_offset, $disk_start);
835        $ExtraContext{Zip64} = \@z64 ;
836        $ExtraContext{InCentralDir} = 1;
837        walkExtra($extraLength, \%ExtraContext);
838    }
839
840    if ($comment_length)
841    {
842        my $comment ;
843        myRead($comment, $comment_length);
844        out $comment, "Comment",  "'". $comment . "'";
845    }
846}
847
848sub decodeZipVer
849{
850    my $ver = shift ;
851
852    my $sHi = int($ver /10) ;
853    my $sLo = $ver % 10 ;
854
855    #out1 "Zip Spec", "$sHi.$sLo";
856    "$sHi.$sLo";
857}
858
859sub decodeOS
860{
861    my $ver = shift ;
862
863    $OS_Lookup{$ver} || "Unknown" ;
864}
865
866sub Zip64EndCentralHeader
867{
868    my $signature = shift ;
869    my $data = shift ;
870
871    print "\n";
872    out $data, "ZIP64 END CENTRAL DIR RECORD", Value_V($signature);
873
874    my $buff;
875    myRead($buff, 8);
876
877    out $buff, "Size of record",       unpackValue_VV($buff);
878
879    my $size  = Value_VV64($buff);
880
881    out_C  "Created Zip Spec", \&decodeZipVer;
882    out_C  "Created OS", \&decodeOS;
883    out_C  "Extract Zip Spec", \&decodeZipVer;
884    out_C  "Extract OS", \&decodeOS;
885    out_V  "Number of this disk";
886    out_V  "Central Dir Disk no";
887    out_VV "Entries in this disk";
888    out_VV "Total Entries";
889    out_VV "Size of Central Dir";
890    out_VV "Offset to Central dir";
891
892    # TODO -
893    die "Unsupported Size ($size) in Zip64EndCentralHeader\n"
894        if $size !=  44;
895}
896
897
898sub Zip64EndCentralLocator
899{
900    my $signature = shift ;
901    my $data = shift ;
902
903    print "\n";
904    out $data, "ZIP64 END CENTRAL DIR LOCATOR", Value_V($signature);
905
906    out_V  "Central Dir Disk no";
907    out_VV "Offset to Central dir";
908    out_V  "Total no of Disks";
909}
910
911sub EndCentralHeader
912{
913    my $signature = shift ;
914    my $data = shift ;
915
916    print "\n";
917    out $data, "END CENTRAL HEADER", Value_V($signature);
918
919    out_v "Number of this disk";
920    out_v "Central Dir Disk no";
921    out_v "Entries in this disk";
922    out_v "Total Entries";
923    out_V "Size of Central Dir";
924    out_V "Offset to Central Dir";
925    my $comment_length = out_v "Comment Length";
926
927    if ($comment_length)
928    {
929        my $comment ;
930        myRead($comment, $comment_length);
931        out $comment, "Comment", "'$comment'";
932    }
933}
934
935sub DataHeader
936{
937    my $signature = shift ;
938    my $data = shift ;
939
940    print "\n";
941    out $data, "STREAMING DATA HEADER", Value_V($signature);
942
943    out_V "CRC";
944
945    if ($ZIP64)
946    {
947        out_VV "Compressed Length" ;
948        out_VV "Uncompressed Length" ;
949    }
950    else
951    {
952        out_V "Compressed Length" ;
953        out_V "Uncompressed Length" ;
954    }
955}
956
957
958sub GeneralPurposeBits
959{
960    my $method = shift;
961    my $gp = shift;
962
963    out1 "[Bit  0]", "1 'Encryption'" if $gp & ZIP_GP_FLAG_ENCRYPTED_MASK;
964
965    my %lookup = (
966        0 =>    "Normal Compression",
967        1 =>    "Maximum Compression",
968        2 =>    "Fast Compression",
969        3 =>    "Super Fast Compression");
970
971
972    if ($method == ZIP_CM_DEFLATE)
973    {
974        my $mid = $gp & 0x03;
975
976        out1 "[Bits 1-2]", "$mid '$lookup{$mid}'";
977    }
978
979    if ($method == ZIP_CM_LZMA)
980    {
981        if ($gp & ZIP_GP_FLAG_LZMA_EOS_PRESENT) {
982            out1 "[Bit 1]", "1 'LZMA EOS Marker Present'" ;
983        }
984        else {
985            out1 "[Bit 1]", "0 'LZMA EOS Marker Not Present'" ;
986        }
987    }
988
989    if ($method == ZIP_CM_IMPLODE) # Imploding
990    {
991        out1 "[Bit 1]", ($gp & 1 ? "1 '8k" : "0 '4k") . " Sliding Dictionary'" ;
992        out1 "[Bit 2]", ($gp & 2 ? "1 '3" : "0 '2"  ) . " Shannon-Fano
993        Trees'" ;
994    }
995
996    out1 "[Bit  3]", "1 'Streamed'"           if $gp & ZIP_GP_FLAG_STREAMING_MASK;
997    out1 "[Bit  4]", "1 'Enhanced Deflating'" if $gp & 1 << 4;
998    out1 "[Bit  5]", "1 'Compressed Patched'" if $gp & 1 << 5 ;
999    out1 "[Bit  6]", "1 'Strong Encryption'"  if $gp & ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK;
1000    out1 "[Bit 11]", "1 'Language Encoding'"  if $gp & ZIP_GP_FLAG_LANGUAGE_ENCODING;
1001    out1 "[Bit 12]", "1 'Pkware Enhanced Compression'"  if $gp & 1 <<12 ;
1002    out1 "[Bit 13]", "1 'Encrypted Central Dir'"  if $gp & 1 <<13 ;
1003
1004    return ();
1005}
1006
1007
1008
1009
1010sub skip
1011{
1012    my $fh = $_[0] ;
1013    my $size = $_[1];
1014
1015    use Fcntl qw(SEEK_CUR);
1016    if (ref $size eq 'U64') {
1017        seek($fh, $size->get64bit(), SEEK_CUR);
1018    }
1019    else {
1020        seek($fh, $size, SEEK_CUR);
1021    }
1022
1023}
1024
1025
1026sub myRead
1027{
1028    my $got = \$_[0] ;
1029    my $size = $_[1];
1030
1031    my $wantSize = $size;
1032    $$got = '';
1033
1034    if ($size == 0)
1035    {
1036        return ;
1037    }
1038
1039    if ($size > 0)
1040    {
1041        my $buff ;
1042        my $status = $FH->read($buff, $size);
1043        return $status
1044            if $status < 0;
1045        $$got .= $buff ;
1046    }
1047
1048    my $len = length $$got;
1049    die "Truncated file (got $len, wanted $wantSize): $!\n"
1050        if length $$got != $wantSize;
1051}
1052
1053
1054
1055
1056sub walkExtra
1057{
1058    my $XLEN = shift;
1059    my $context = shift;
1060
1061    my $buff ;
1062    my $offset = 0 ;
1063
1064    my $id;
1065    my $subLen;
1066    my $payload ;
1067
1068    my $count = 0 ;
1069
1070    if ($XLEN < ZIP_EXTRA_SUBFIELD_ID_SIZE + ZIP_EXTRA_SUBFIELD_LEN_SIZE)
1071    {
1072        # Android zipalign is prime candidate for this non-standard extra field.
1073        myRead($payload, $XLEN);
1074        my $data = hexDump($payload);
1075
1076        out $payload, "Malformed Extra Data", $data;
1077
1078        return undef;
1079    }
1080
1081    while ($offset < $XLEN) {
1082
1083        ++ $count;
1084
1085        return undef
1086            if $offset + ZIP_EXTRA_SUBFIELD_HEADER_SIZE  > $XLEN ;
1087
1088        myRead($id, ZIP_EXTRA_SUBFIELD_ID_SIZE);
1089        $offset += ZIP_EXTRA_SUBFIELD_ID_SIZE;
1090        my $lookID = unpack "v", $id ;
1091        my ($who, $decoder) =  @{ defined $Extras{$lookID} ? $Extras{$lookID} : ['', undef] };
1092        #my ($who, $decoder) =  @{ $Extras{unpack "v", $id} || ['', undef] };
1093
1094        $who = "$id: $who"
1095            if $id =~ /\w\w/ ;
1096
1097        $who = "'$who'";
1098        out $id, "Extra ID #" . Value_v($count), unpackValue_v($id) . " $who" ;
1099
1100        myRead($buff, ZIP_EXTRA_SUBFIELD_LEN_SIZE);
1101        $offset += ZIP_EXTRA_SUBFIELD_LEN_SIZE;
1102
1103        $subLen =  unpack("v", $buff);
1104        out2 $buff, "Length", Value_v($subLen) ;
1105
1106        return undef
1107            if $offset + $subLen > $XLEN ;
1108
1109        if (! defined $decoder)
1110        {
1111            myRead($payload, $subLen);
1112            my $data = hexDump($payload);
1113
1114            out2 $payload, "Extra Payload", $data;
1115        }
1116        else
1117        {
1118            $decoder->($subLen, $context) ;
1119        }
1120
1121        $offset += $subLen ;
1122    }
1123
1124    return undef ;
1125}
1126
1127
1128sub full32
1129{
1130    return $_[0] == 0xFFFFFFFF ;
1131}
1132
1133sub decode_Zip64
1134{
1135    my $len = shift;
1136    my $context = shift;
1137
1138    my $z64Data = $context->{Zip64};
1139
1140    $ZIP64 = 1;
1141
1142    if (full32 $z64Data->[0] ) {
1143        out_VV "  Uncompressed Size";
1144    }
1145
1146    if (full32 $z64Data->[1] ) {
1147        out_VV "  Compressed Size";
1148    }
1149
1150    if (full32 $z64Data->[2] ) {
1151        out_VV "  Offset to Central Dir";
1152    }
1153
1154    if ($z64Data->[3] == 0xFFFF ) {
1155        out_V "  Disk Number";
1156    }
1157}
1158
1159sub Ntfs2Unix
1160{
1161    my $v = shift;
1162    my $u64 = shift;
1163
1164    # NTFS offset is 19DB1DED53E8000
1165
1166    my $hex = Value_U64($u64) ;
1167    my $NTFS_OFFSET = new U64 0x19DB1DE, 0xD53E8000 ;
1168    $u64->subtract($NTFS_OFFSET);
1169    my $elapse = $u64->get64bit();
1170    my $ns = ($elapse % 10000000) * 100;
1171    $elapse = int ($elapse/10000000);
1172    return "$hex '" . localtime($elapse) .
1173           " " . sprintf("%0dns'", $ns);
1174}
1175
1176sub decode_NTFS_Filetimes
1177{
1178    my $len = shift;
1179    my $context = shift;
1180
1181    out_V "  Reserved";
1182    out_v "  Tag1";
1183    out_v "  Size1" ;
1184
1185    my ($m, $s1) = read_U64;
1186    out $m, "  Mtime", Ntfs2Unix($m, $s1);
1187
1188    my ($c, $s2) = read_U64;
1189    out $c, "  Ctime", Ntfs2Unix($m, $s2);
1190
1191    my ($a, $s3) = read_U64;
1192    out $m, "  Atime", Ntfs2Unix($m, $s3);
1193}
1194
1195sub getTime
1196{
1197    my $time = shift ;
1198
1199    return "'" . localtime($time) . "'" ;
1200}
1201
1202sub decode_UT
1203{
1204    my $len = shift;
1205    my $context = shift;
1206
1207    my ($data, $flags) = read_C();
1208
1209    my $f = Value_C $flags;
1210    $f .= " mod"    if $flags & 1;
1211    $f .= " access" if $flags & 2;
1212    $f .= " change" if $flags & 4;
1213
1214    out $data, "  Flags", "'$f'";
1215
1216    -- $len;
1217
1218    if ($flags & 1)
1219    {
1220        my ($data, $time) = read_V();
1221
1222        out2 $data, "Mod Time",    Value_V($time) . " " . getTime($time) ;
1223
1224        $len -= 4 ;
1225    }
1226
1227
1228      if ($flags & 2 && $len > 0 )
1229      {
1230          my ($data, $time) = read_V();
1231
1232          out2 $data, "Access Time",    Value_V($time) . " " . getTime($time) ;
1233          $len -= 4 ;
1234      }
1235
1236      if ($flags & 4 && $len > 0)
1237      {
1238          my ($data, $time) = read_V();
1239
1240          out2 $data, "Change Time",    Value_V($time) . " " . getTime($time) ;
1241      }
1242}
1243
1244
1245
1246sub decode_AES
1247{
1248    my $len = shift;
1249    my $context = shift;
1250
1251    return if $len == 0 ;
1252
1253    my %lookup = ( 1 => "AE-1", 2 => "AE-2");
1254    out_v "  Vendor Version", sub {  $lookup{$_[0]} || "Unknown"  } ;
1255
1256    my $id ;
1257    myRead($id, 2);
1258    out $id, "  Vendor ID", unpackValue_v($id) . " '$id'";
1259
1260    my %strengths = (1 => "128-bit encryption key",
1261                     2 => "192-bit encryption key",
1262                     3 => "256-bit encryption key",
1263                    );
1264
1265    my $strength = out_C "  Encryption Strength", sub {$strengths{$_[0]} || "Unknown" } ;
1266
1267    my ($bmethod, $method) = read_v();
1268    out $bmethod, "  Compression Method", compressionMethod($method) ;
1269
1270    $context->{AesStrength} = $strength ;
1271}
1272
1273sub decode_UX
1274{
1275    my $len = shift;
1276    my $context = shift;
1277    my $inCentralHdr = $context->{InCentralDir} ;
1278
1279    return if $len == 0 ;
1280
1281    my ($data, $time) = read_V();
1282    out2 $data, "Access Time",    Value_V($time) . " " . getTime($time) ;
1283
1284    ($data, $time) = read_V();
1285    out2 $data, "Mod Time",    Value_V($time) . " " . getTime($time) ;
1286
1287    if (! $inCentralHdr ) {
1288        out_v "  UID" ;
1289        out_v "  GID";
1290    }
1291}
1292
1293sub decode_Ux
1294{
1295    my $len = shift;
1296    my $context = shift;
1297
1298    return if $len == 0 ;
1299    out_v "  UID" ;
1300    out_v "  GID";
1301}
1302
1303sub decodeLitteEndian
1304{
1305    my $value = shift ;
1306
1307    if (length $value == 4)
1308    {
1309        return Value_V unpack ("V", $value)
1310    }
1311    else {
1312        # TODO - fix this
1313        die "unsupported\n";
1314    }
1315
1316    my $got = 0 ;
1317    my $shift = 0;
1318
1319    #hexDump
1320    #reverse
1321    #my @a =unpack "C*", $value;
1322    #@a = reverse @a;
1323    #hexDump(@a);
1324
1325    for (reverse unpack "C*", $value)
1326    {
1327        $got = ($got << 8) + $_ ;
1328    }
1329
1330    return $got ;
1331}
1332
1333sub decode_ux
1334{
1335    my $len = shift;
1336    my $context = shift;
1337
1338    return if $len == 0 ;
1339    out_C "  Version" ;
1340    my $uidSize = out_C "  UID Size";
1341    myRead(my $data, $uidSize);
1342    out2 $data, "UID", decodeLitteEndian($data);
1343
1344    my $gidSize = out_C "  GID Size";
1345    myRead($data, $gidSize);
1346    out2 $data, "GID", decodeLitteEndian($data);
1347
1348}
1349
1350sub decode_Java_exe
1351{
1352    my $len = shift;
1353    my $context = shift;
1354
1355}
1356
1357sub decode_up
1358{
1359    my $len = shift;
1360    my $context = shift;
1361
1362
1363    out_C "  Version";
1364    out_V "  NameCRC32";
1365
1366    myRead(my $data, $len - 5);
1367
1368    out $data, "  UnicodeName", $data;
1369}
1370
1371sub decode_Xceed_unicode
1372{
1373    my $len = shift;
1374    my $context = shift;
1375
1376    my $data ;
1377
1378    # guess the fields used for this one
1379    myRead($data, 4);
1380    out $data, "  ID", $data;
1381
1382    out_v "  Length";
1383    out_v "  Null";
1384
1385    myRead($data, $len - 8);
1386
1387    out $data, "  UTF16LE Name", decode("UTF16LE", $data);
1388}
1389
1390
1391sub decode_NT_security
1392{
1393    my $len = shift;
1394    my $context = shift;
1395    my $inCentralHdr = $context->{InCentralDir} ;
1396
1397    out_V "  Uncompressed Size" ;
1398
1399    if (! $inCentralHdr) {
1400
1401        out_C "  Version" ;
1402
1403        out_v "  Type";
1404
1405        out_V "  NameCRC32" ;
1406
1407        my $plen = $len - 4 - 1 - 2 - 4;
1408        myRead(my $payload, $plen);
1409        out $plen, "  Extra Payload", hexDump($payload);
1410    }
1411}
1412
1413sub printAes
1414{
1415    my $context = shift ;
1416
1417    my %saltSize = (
1418                        1 => 8,
1419                        2 => 12,
1420                        3 => 16,
1421                    );
1422
1423    myRead(my $salt, $saltSize{$context->{AesStrength} });
1424    out $salt, "AES Salt", hexDump($salt);
1425    myRead(my $pwv, 2);
1426    out $pwv, "AES Pwd Ver", hexDump($pwv);
1427
1428    return  $saltSize{$context->{AesStrength}} + 2 + 10;
1429}
1430
1431sub printLzmaProperties
1432{
1433    my $len = 0;
1434
1435    my $b1;
1436    my $b2;
1437    my $buffer;
1438
1439    myRead($b1, 2);
1440    my ($verHi, $verLow) = unpack ("CC", $b1);
1441
1442    out $b1, "LZMA Version", sprintf("%02X%02X", $verHi, $verLow) . " '$verHi.$verLow'";
1443    my $LzmaPropertiesSize = out_v "LZMA Properties Size";
1444    $len += 4;
1445
1446    my $LzmaInfo = out_C "LZMA Info",  sub { $_[0] == 93 ? "(Default)" : ""};
1447
1448    my $PosStateBits = 0;
1449    my $LiteralPosStateBits = 0;
1450    my $LiteralContextBits = 0;
1451    $PosStateBits = int($LzmaInfo / (9 * 5));
1452	$LzmaInfo -= $PosStateBits * 9 * 5;
1453	$LiteralPosStateBits = int($LzmaInfo / 9);
1454	$LiteralContextBits = $LzmaInfo - $LiteralPosStateBits * 9;
1455
1456    out1 "  PosStateBits",        $PosStateBits;
1457    out1 "  LiteralPosStateBits", $LiteralPosStateBits;
1458    out1 "  LiteralContextBits",  $LiteralContextBits;
1459
1460    out_V "LZMA Dictionary Size";
1461
1462    # TODO - assumption that this is 5
1463    $len += $LzmaPropertiesSize;
1464
1465    skip($FH, $LzmaPropertiesSize - 5)
1466        if  $LzmaPropertiesSize != 5 ;
1467
1468    return $len;
1469}
1470
1471sub scanCentralDirectory
1472{
1473    my $fh = shift;
1474
1475    my $here = $fh->tell();
1476
1477    # Use cases
1478    # 1 32-bit CD
1479    # 2 64-bit CD
1480
1481    my @CD = ();
1482    my $offset = findCentralDirectoryOffset($fh);
1483
1484    return ()
1485        if ! defined $offset;
1486
1487    $fh->seek($offset, SEEK_SET) ;
1488
1489    # Now walk the Central Directory Records
1490    my $buffer ;
1491    while ($fh->read($buffer, 46) == 46  &&
1492           unpack("V", $buffer) == ZIP_CENTRAL_HDR_SIG) {
1493
1494        my $compressedLength   = unpack("V", substr($buffer, 20, 4));
1495        my $uncompressedLength = unpack("V", substr($buffer, 24, 4));
1496        my $filename_length    = unpack("v", substr($buffer, 28, 2));
1497        my $extra_length       = unpack("v", substr($buffer, 30, 2));
1498        my $comment_length     = unpack("v", substr($buffer, 32, 2));
1499        my $locHeaderOffset    = unpack("V", substr($buffer, 42, 4));
1500
1501        $START = $locHeaderOffset
1502            if ! defined $START;
1503
1504        skip($fh, $filename_length ) ;
1505
1506        my $v64 = new U64 $compressedLength ;
1507        my $loc64 = new U64 $locHeaderOffset ;
1508        my $got = [$loc64, $v64] ;
1509
1510        if (full32 $compressedLength || full32  $locHeaderOffset) {
1511            $fh->read($buffer, $extra_length) ;
1512            # TODO - fix this
1513            die "xxx $offset $comment_length $filename_length $extra_length" . length($buffer)
1514                if length($buffer) != $extra_length;
1515            $got = get64Extra($buffer, full32($uncompressedLength),
1516                                 $v64,
1517                                 $loc64);
1518
1519            # If not Zip64 extra field, assume size is 0xFFFFFFFF
1520            #$v64 = $got if defined $got;
1521        }
1522        else {
1523            skip($fh, $extra_length) ;
1524        }
1525
1526        skip($fh, $comment_length ) ;
1527
1528        push @CD, $got ;
1529    }
1530
1531    $fh->seek($here, SEEK_SET) ;
1532
1533    @CD = sort { $a->[0]->cmp($b->[0]) } @CD ;
1534    return @CD;
1535}
1536
1537sub get64Extra
1538{
1539    my $buffer = shift;
1540    my $is_uncomp = shift ;
1541    my $comp = shift ;
1542    my $loc = shift ;
1543
1544    my $extra = findID(0x0001, $buffer);
1545
1546    if ( defined $extra)
1547    {
1548        my $offset = 0;
1549        $offset += 8 if $is_uncomp;
1550        if ($comp->max32()) {
1551            $comp = U64::newUnpack_V64(substr($extra,  $offset)) ;
1552            $offset += 8;
1553        }
1554        if ($loc->max32()) {
1555            $loc = U64::newUnpack_V64(substr($extra,  $offset)) ;
1556        }
1557    }
1558
1559    return [$loc, $comp] ;
1560}
1561
1562sub offsetFromZip64
1563{
1564    my $fh = shift ;
1565    my $here = shift;
1566
1567    $fh->seek($here - 20, SEEK_SET)
1568    # TODO - fix this
1569        or die "xx $!" ;
1570
1571    my $buffer;
1572    my $got = 0;
1573    ($got = $fh->read($buffer, 20)) == 20
1574    # TODO - fix this
1575        or die "xxx $here $got $!" ;
1576
1577    if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_LOC_HDR_SIG ) {
1578        my $cd64 = Value_VV64 substr($buffer,  8, 8);
1579
1580        $fh->seek($cd64, SEEK_SET) ;
1581
1582        $fh->read($buffer, 4) == 4
1583        # TODO - fix this
1584            or die "xxx" ;
1585
1586        if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_REC_HDR_SIG ) {
1587
1588            $fh->read($buffer, 8) ==  8
1589            # TODO - fix this
1590                or die "xxx" ;
1591            my $size  = Value_VV64($buffer);
1592            $fh->read($buffer, $size) ==  $size
1593            # TODO - fix this
1594                or die "xxx" ;
1595
1596            my $cd64 =  Value_VV64 substr($buffer,  36, 8);
1597
1598            return $cd64 ;
1599        }
1600
1601        # TODO - fix this
1602        die "zzz";
1603    }
1604
1605    # TODO - fix this
1606    die "zzz";
1607}
1608
1609use constant Pack_ZIP_END_CENTRAL_HDR_SIG => pack("V", ZIP_END_CENTRAL_HDR_SIG);
1610
1611sub findCentralDirectoryOffset
1612{
1613    my $fh = shift ;
1614
1615    # Most common use-case is where there is no comment, so
1616    # know exactly where the end of central directory record
1617    # should be.
1618
1619    $fh->seek(-22, SEEK_END) ;
1620    my $here = $fh->tell();
1621
1622    my $buffer;
1623    $fh->read($buffer, 22) == 22
1624    # TODO - fix this
1625        or die "xxx" ;
1626
1627    my $zip64 = 0;
1628    my $centralDirOffset ;
1629    if ( unpack("V", $buffer) == ZIP_END_CENTRAL_HDR_SIG ) {
1630        $centralDirOffset = unpack("V", substr($buffer, 16,  4));
1631    }
1632    else {
1633        $fh->seek(0, SEEK_END) ;
1634
1635        my $fileLen = $fh->tell();
1636        my $want = 0 ;
1637
1638        while(1) {
1639            $want += 1024 * 32;
1640            my $seekTo = $fileLen - $want;
1641            if ($seekTo < 0 ) {
1642                $seekTo = 0;
1643                $want = $fileLen ;
1644            }
1645            $fh->seek( $seekTo, SEEK_SET)
1646            # TODO - fix this
1647                or die "xxx $!" ;
1648            my $got;
1649            ($got = $fh->read($buffer, $want)) == $want
1650            # TODO - fix this
1651                or die "xxx $got  $!" ;
1652            my $pos = rindex( $buffer, Pack_ZIP_END_CENTRAL_HDR_SIG);
1653
1654            if ($pos >= 0 && $want - $pos > 22) {
1655                $here = $seekTo + $pos ;
1656                $centralDirOffset = unpack("V", substr($buffer, $pos + 16,  4));
1657                my $commentLength = unpack("V", substr($buffer, $pos + 20,  2));
1658                $commentLength = 0 if ! defined $commentLength ;
1659
1660                my $expectedEof = $fileLen - $want + $pos + 22 + $commentLength  ;
1661                # check for trailing data after end of zip
1662                if ($expectedEof < $fileLen ) {
1663                    $TRAILING = $expectedEof ;
1664                }
1665                last ;
1666            }
1667
1668            return undef
1669                if $want == $fileLen;
1670        }
1671    }
1672
1673    $centralDirOffset = offsetFromZip64($fh, $here)
1674        if full32 $centralDirOffset ;
1675
1676    return $centralDirOffset ;
1677}
1678
1679sub findID
1680{
1681    my $id_want = shift ;
1682    my $data    = shift;
1683
1684    my $XLEN = length $data ;
1685
1686    my $offset = 0 ;
1687    while ($offset < $XLEN) {
1688
1689        return undef
1690            if $offset + ZIP_EXTRA_SUBFIELD_HEADER_SIZE  > $XLEN ;
1691
1692        my $id = substr($data, $offset, ZIP_EXTRA_SUBFIELD_ID_SIZE);
1693        $id = unpack("v", $id);
1694        $offset += ZIP_EXTRA_SUBFIELD_ID_SIZE;
1695
1696        my $subLen =  unpack("v", substr($data, $offset,
1697                                            ZIP_EXTRA_SUBFIELD_LEN_SIZE));
1698        $offset += ZIP_EXTRA_SUBFIELD_LEN_SIZE ;
1699
1700        return undef
1701            if $offset + $subLen > $XLEN ;
1702
1703        return substr($data, $offset, $subLen)
1704            if $id eq $id_want ;
1705
1706        $offset += $subLen ;
1707    }
1708
1709    return undef ;
1710}
1711
1712
1713sub _dosToUnixTime
1714{
1715    my $dt = shift;
1716
1717    my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
1718    my $mon  = ( ( $dt >> 21 ) & 0x0f ) - 1;
1719    my $mday = ( ( $dt >> 16 ) & 0x1f );
1720
1721    my $hour = ( ( $dt >> 11 ) & 0x1f );
1722    my $min  = ( ( $dt >> 5 ) & 0x3f );
1723    my $sec  = ( ( $dt << 1 ) & 0x3e );
1724
1725
1726    use POSIX 'mktime';
1727
1728    my $time_t = mktime( $sec, $min, $hour, $mday, $mon, $year, 0, 0, -1 );
1729    return 0 if ! defined $time_t;
1730    return $time_t;
1731}
1732
1733
1734{
1735    package U64;
1736
1737    use constant MAX32 => 0xFFFFFFFF ;
1738    use constant HI_1 => MAX32 + 1 ;
1739    use constant LOW   => 0 ;
1740    use constant HIGH  => 1;
1741
1742    sub new
1743    {
1744        my $class = shift ;
1745
1746        my $high = 0 ;
1747        my $low  = 0 ;
1748
1749        if (@_ == 2) {
1750            $high = shift ;
1751            $low  = shift ;
1752        }
1753        elsif (@_ == 1) {
1754            $low  = shift ;
1755        }
1756
1757        bless [$low, $high], $class;
1758    }
1759
1760    sub newUnpack_V64
1761    {
1762        my $string = shift;
1763
1764        my ($low, $hi) = unpack "V V", $string ;
1765        bless [ $low, $hi ], "U64";
1766    }
1767
1768    sub newUnpack_V32
1769    {
1770        my $string = shift;
1771
1772        my $low = unpack "V", $string ;
1773        bless [ $low, 0 ], "U64";
1774    }
1775
1776    sub reset
1777    {
1778        my $self = shift;
1779        $self->[HIGH] = $self->[LOW] = 0;
1780    }
1781
1782    sub clone
1783    {
1784        my $self = shift;
1785        bless [ @$self ], ref $self ;
1786    }
1787
1788    sub mkU64
1789    {
1790        my $value = shift;
1791
1792        return $value
1793            if ref $value eq 'U64';
1794
1795        bless [  $value, 0 ], "U64" ;
1796    }
1797
1798    sub getHigh
1799    {
1800        my $self = shift;
1801        return $self->[HIGH];
1802    }
1803
1804    sub getLow
1805    {
1806        my $self = shift;
1807        return $self->[LOW];
1808    }
1809
1810    sub get32bit
1811    {
1812        my $self = shift;
1813        return $self->[LOW];
1814    }
1815
1816    sub get64bit
1817    {
1818        my $self = shift;
1819        # Not using << here because the result will still be
1820        # a 32-bit value on systems where int size is 32-bits
1821        return $self->[HIGH] * HI_1 + $self->[LOW];
1822    }
1823
1824    sub add
1825    {
1826        my $self = shift;
1827        my $value = shift;
1828
1829        if (ref $value eq 'U64') {
1830            $self->[HIGH] += $value->[HIGH] ;
1831            $value = $value->[LOW];
1832        }
1833
1834        my $available = MAX32 - $self->[LOW] ;
1835
1836        if ($value > $available) {
1837           ++ $self->[HIGH] ;
1838           $self->[LOW] = $value - $available - 1;
1839        }
1840        else {
1841           $self->[LOW] += $value ;
1842        }
1843
1844    }
1845
1846    sub subtract
1847    {
1848        my $self = shift;
1849        my $value = shift;
1850
1851        if (ref $value eq 'U64') {
1852
1853            if ($value->[HIGH]) {
1854                die "unsupport subtract option"
1855                    if $self->[HIGH] == 0 ||
1856                       $value->[HIGH] > $self->[HIGH] ;
1857
1858               $self->[HIGH] -= $value->[HIGH] ;
1859            }
1860
1861            $value = $value->[LOW] ;
1862        }
1863
1864        if ($value > $self->[LOW]) {
1865           -- $self->[HIGH] ;
1866           $self->[LOW] = MAX32 - $value + $self->[LOW] + 1;
1867        }
1868        else {
1869           $self->[LOW] -= $value;
1870        }
1871    }
1872
1873    sub rshift
1874    {
1875        my $self = shift;
1876        my $count = shift;
1877
1878        for (1 .. $count)
1879        {
1880            $self->[LOW] >>= 1;
1881            $self->[LOW] |= 0x80000000
1882                if $self->[HIGH] & 1 ;
1883            $self->[HIGH] >>= 1;
1884        }
1885    }
1886
1887    sub is64bit
1888    {
1889        my $self = shift;
1890        return $self->[HIGH] > 0 ;
1891    }
1892
1893    sub getPacked_V64
1894    {
1895        my $self = shift;
1896
1897        return pack "V V", @$self ;
1898    }
1899
1900    sub getPacked_V32
1901    {
1902        my $self = shift;
1903
1904        return pack "V", $self->[LOW] ;
1905    }
1906
1907    sub pack_V64
1908    {
1909        my $low  = shift;
1910
1911        return pack "V V", $low, 0;
1912    }
1913
1914    sub max32
1915    {
1916        my $self = shift;
1917        return $self->[HIGH] == 0 && $self->[LOW] == MAX32;
1918    }
1919
1920    sub stringify
1921    {
1922        my $self = shift;
1923
1924        return "High [$self->[HIGH]], Low [$self->[LOW]]";
1925    }
1926
1927    sub equal
1928    {
1929        my $self = shift;
1930        my $other = shift;
1931
1932        return $self->[LOW]  == $other->[LOW] &&
1933               $self->[HIGH] == $other->[HIGH] ;
1934    }
1935
1936    sub gt
1937    {
1938        my $self = shift;
1939        my $other = shift;
1940
1941        return $self->cmp($other) > 0 ;
1942    }
1943
1944    sub cmp
1945    {
1946        my $self = shift;
1947        my $other = shift ;
1948
1949        if ($self->[LOW] == $other->[LOW]) {
1950            return $self->[HIGH] - $other->[HIGH] ;
1951        }
1952        else {
1953            return $self->[LOW] - $other->[LOW] ;
1954        }
1955    }
1956
1957    sub nibbles
1958    {
1959        my @nibbles = (
1960            [ 16 => HI_1 * 0x10000000 ],
1961            [ 15 => HI_1 * 0x1000000 ],
1962            [ 14 => HI_1 * 0x100000 ],
1963            [ 13 => HI_1 * 0x10000 ],
1964            [ 12 => HI_1 * 0x1000 ],
1965            [ 11 => HI_1 * 0x100 ],
1966            [ 10 => HI_1 * 0x10 ],
1967            [  9 => HI_1 * 0x1 ],
1968
1969            [  8 => 0x10000000 ],
1970            [  7 => 0x1000000 ],
1971            [  6 => 0x100000 ],
1972            [  5 => 0x10000 ],
1973            [  4 => 0x1000 ],
1974            [  3 => 0x100 ],
1975            [  2 => 0x10 ],
1976            [  1 => 0x1 ],
1977        );
1978        my $value = shift ;
1979
1980        for my $pair (@nibbles)
1981        {
1982            my ($count, $limit) = @{ $pair };
1983
1984            return $count
1985                if $value >= $limit ;
1986        }
1987
1988    }
1989}
1990
1991sub Usage
1992{
1993    die <<EOM;
1994zipdetails [OPTIONS] file
1995
1996Display details about the internal structure of a Zip file.
1997
1998This is zipdetails version $VERSION
1999
2000OPTIONS
2001     -h     display help
2002     -v     Verbose - output more stuff
2003
2004Copyright (c) 2011 Paul Marquess. All rights reserved.
2005
2006This program is free software; you can redistribute it and/or
2007modify it under the same terms as Perl itself.
2008EOM
2009
2010
2011}
2012
2013__END__
2014
2015=head1 NAME
2016
2017zipdetails - display the internal structure of zip files
2018
2019=head1 SYNOPSIS
2020
2021    zipdetaile [-v] zipfile.zip
2022	zipdetails -h
2023
2024=head1 DESCRIPTION
2025
2026Zipdetails displays information about the internal record structure of the
2027zip file. It is not concerned with displaying any details of the compressed
2028data stored in the zip file.
2029
2030The program assumes prior understanding of the internal structure of a Zip
2031file. You should have a copy of the Zip APPNOTE file at hand to help
2032understand the output from this program (L<SEE ALSO> for details).
2033
2034=head2 OPTIONS
2035
2036=over 5
2037
2038=item -v
2039
2040Enable Verbose mode
2041
2042=item -h
2043
2044Display help
2045
2046=back
2047
2048
2049By default zipdetails will output the details of the zip file in three
2050columns.
2051
2052=over 5
2053
2054=item Column 1
2055
2056This contains the offset from the start of the file in hex.
2057
2058=item Column 2
2059
2060This contains a textual description of the field.
2061
2062=item Column 3
2063
2064If the field contains a numeric value it will be displayed in hex. Zip
2065stored most numbers in little-endian format - the value displayed will have
2066the little-endian encoding removed.
2067
2068Next, is an optional description of what the value means.
2069
2070
2071=back
2072
2073If the C<-v> option is present, column 1 is expanded to include
2074
2075=over 5
2076
2077=item *
2078
2079The offset from the start of the file in hex.
2080
2081=item *
2082
2083The length of the filed in hex.
2084
2085=item *
2086
2087A hex dump of the bytes in field in the order they are stored in the zip
2088file.
2089
2090=back
2091
2092
2093=head1 TODO
2094
2095Error handling is still a work in progress.  If the program encounters a
2096problem reading a zip file it is likely to terminate with an unhelpful
2097error message.
2098
2099
2100=head1 SEE ALSO
2101
2102
2103The primary reference for Zip files is the "appnote" document available at
2104L<http://www.pkware.com/documents/casestudies/APPNOTE.TXT>.
2105
2106An alternative reference is the Info-Zip appnote. This is available from
2107L<ftp://ftp.info-zip.org/pub/infozip/doc/>
2108
2109
2110The C<zipinfo> program that comes with the info-zip distribution
2111(L<http://www.info-zip.org/>) can also display details of the structure of
2112a zip file.
2113
2114See also L<Archive::Zip::SimpleZip>, L<IO::Compress::Zip>,
2115L<IO::Uncompress::Unzip>.
2116
2117
2118=head1 AUTHOR
2119
2120Paul Marquess F<pmqs@cpan.org>.
2121
2122=head1 COPYRIGHT
2123
2124Copyright (c) 2011-2013 Paul Marquess. All rights reserved.
2125
2126This program is free software; you can redistribute it and/or modify it
2127under the same terms as Perl itself.
2128
2129