#!perl -w
use strict;
# (C) 2003-2007 Willem Jan Hengeveld <itsme@xs4all.nl>
# Web: http://www.xs4all.nl/~itsme/
#      http://wiki.xda-developers.com/
#
# $Id: cabdump.pl 1894 2008-06-26 10:50:13Z itsme $
#
#
#  script to parse the .inf file contained in CAB install archives.
#
#  the inf file is usually the first file in the cab, and 
#  has an extension of ".000" in the cabfile
#
#  when extracting files from the cab, the first 2 files are the .inf
#  file, and the setup.dll ( which has extension .999 in the cab )
#  followed by the files mentioned in the [files] section, in reverse order.
#
#  new feature: now can also process cab files which have the first folder
#  uncompressed, and containing the .inf file.
#
# BUG: Default_ImateV1.00.1.0.cab from 1-03-143-WWE.nb
#      files are not extracted correctly.
# also C:\local\phones\raseac\RaseacSP_256_FreePt_PPC2003.STRONGARM.cab
#      does not extract ok.
# 
# Z:\Desktop\889080-brightpoint_extrom_5.4.411.9260_rus_htc_p4350\__TFAT_HIDDEN_ROOT_DIR__/PP_AKv30-DefaultPage_ALL.CAB
#    files are named incorrectly


# bug2: decompressing on osx gives 'segmentation fault' -- in Compress/Raw/Zlib/Zlib.xs

$|=1;
# http://www.kyz.uklinux.net/formats/wince_cab_format.html
#
use IO::File;
use Getopt::Long;
use Compress::Zlib;
my %decompressors= (
    0=> sub { return $_[0]; },  # uncompressed
    1=> sub {   # mszip
        if (substr($_[0],0,2) ne "CK") {
            warn sprintf("mszip compression with invalid magic: %s\n", unpack 'H*',substr($_[0],0,2));
        }
        my $d= Compress::Zlib::inflateInit('-WindowBits'=>-MAX_WBITS(), '-Bufsize'=>32768);

        # NOTE: one extra byte needed after the compressed stream.
        my $o= $d->inflate(substr($_[0], 2));
        if (!defined $o) { die "error inflating: $! - $@\n"; }
        return $o;
    },
    2=> sub { die "quantum compression unsupported\n"; },   # quantum
    3=> sub { die "lzx compression unsupported\n"; },       # lzx
);
my $g_savefolder;
my $g_writeInfTxtFile;
my $g_verbose=0;
my $g_offset=0;

GetOptions(
    "f=s"=> \$g_savefolder,
    "i"=> \$g_writeInfTxtFile,
    "v+"=> \$g_verbose,
    "o=s" => sub { $g_offset= eval($_[1]) },
) or die usage();

sub usage {
    return <<__EOF__
Usage: cabdump [-o offset] [-f directory] [-i] cabfile [cabfile ...]
__EOF__
}
my %hivename= (1=>"HKCR", 2=>"HKCU", 3=>"HKLM", 4=>"HKU");

for my $filename (@ARGV) {
    my $fh= IO::File->new($filename, "r") or die "$filename: $!\n";
    binmode $fh;
    my $data;
    $fh->read($data, -s $fh);
    $fh->close();

    print "Processing file $filename\n\n" if ($g_verbose);

    if (substr($data, 0, 4) eq "MSCE") {
        my $info= ProcessInfFile($data);

        if ($g_writeInfTxtFile) {
            txtinf_write_file($info);
        }
        else {
            print_info($info);
        }
    }
    elsif (substr($data, $g_offset, 4) eq "MSCF") {
	$data= substr($data, $g_offset);
        my $cabinfo= ProcessCabFile($data);
        if ($g_savefolder) {
            my ($savedir)= ($filename =~ m{([^/]+?)(?:\.\w+)?\.cab$}i);

            ExtractFiles($data, $cabinfo, GetUniqueName($g_savefolder, $savedir), $cabinfo->{datareserved});
            print "\n\n" if ($g_verbose);
        }

        # after writing files, real file names are known now.
        if (!$cabinfo->{inffile}) {
            print "no inf file information found\n";
        }
        elsif ($g_writeInfTxtFile) {
            txtinf_write_file($cabinfo->{inffile}, $cabinfo);
        }
        else {
            print_info($cabinfo->{inffile});
        }
    }
    print "\n\n" if ($g_verbose);
}

exit(0);
sub GetUniqueName {
    my ($dir, $name)= @_;

    my $fn= "$dir/$name";
    my $i= 1;
    while (-e $fn) {
        $fn= sprintf("%s/%s-%d", $dir, $name, $i++);
    }

    return $fn;
}

# 0000: 0 "MSCF"     magic
# 0004: 1 00000000    ... csumHeader
# 0008: 2 00004d9d   cabfilesize
# 000c: 3 00000000    ... csumFolders
# 0010: 4 0000004c   coffFiles   - offset to files
# 0014: 5 00000000    ... csumFiles
# 0018: 6 03         verminor
# 0019: 7 01         vermajor
# 001a: 8 0002       nFolders
# 001c: 9 0003       nFiles
# 001e: a 0004       cabflags    '4' = contains reserved header, 1=has-prevcab, 2=has-nextcab
# 0020: b 09d1       setID
# 0022: c 0000       iCabinet
# 0024:   0014       headerreserved
# 0026:   00         folderreserved
# 0027:   00         datareserved
# 0028:     0000     res.cbJunk
# 002a:     0010     res.cbSig
# 002c:     00004d9d 
# 0030:     00000388
# 0034:     00000000
# 0038:     00000000
# <<< coffFolders
# 003c: 000000a3   #1 coffData
# 0040: 0001       #1 nBlocks
# 0042: 0000       #1 compressed

# 0044: 00004195   #2 coffData
# 0048: 0001       #2 nBlocks
# 004a: 0000       #2 compressed

# <<< coffFiles
# 004c: 000002ea   size
# 0050: 00000000   offset
# 0054: 0000       foldernr
# 0054: 354c       date
# 0058: 90a2       time
# 0058: 0020       attributes
# 005c: "SEC_NO~1.000"


##########################################
#  process cabfile
sub ProcessCabFile {
    my $data= shift;

    my @hdr_fields= unpack("a4V5CCv5", $data);
    my $magic= $hdr_fields[0];
    # 1 csumHeader  - always 0
    my $cabfilesize= $hdr_fields[2];
    # 3 csumFolders - always 0
    my $coffFiles= $hdr_fields[4];
    # 5 csumFiles   - always 0
    my $verminor= $hdr_fields[6];
    my $vermajor= $hdr_fields[7];
    my $nFolders= $hdr_fields[8];
    my $nFiles= $hdr_fields[9];
    my $cabflags= $hdr_fields[10];
    my $setID= $hdr_fields[11];
    my $iCabinet= $hdr_fields[12];

    printf("cabfile: size=%d ver=%d.%d  filedata at %08lx  #files=%d #folders=%d flags=%04x  setID=%04x cabnr=%d\n",
        $cabfilesize, $vermajor, $verminor, $coffFiles, $nFiles, $nFolders, $cabflags, $setID, $iCabinet) if ($g_verbose);
    print "unknown hdr_fields: @hdr_fields[1,3,5]\n" if ($g_verbose);

    #printf("00000000-%08lx cab header\n", 4+5*4+2+2*5);

    if ($magic ne "MSCF") {
        print "file is not a cabinet file, magic=$magic\n";
        return;
    }
    my ($headerreserved, $folderreserved, $datareserved)= (0,0,0);
    my $coffFolders= 0x24;
    if ($cabflags&4) {
        ($headerreserved, $folderreserved, $datareserved)= unpack("vCC", substr($data, 0x24, 4));
        $coffFolders= 0x28+$headerreserved;
    }
    if ($headerreserved) {
        my @hdrreserved= unpack("V*", substr($data, 0x28, $headerreserved));
        printf("%08lx: hdrreserved: %08lx - probably signature at %08lx, l=%08lx -  %d,%d\n", 0x28, @hdrreserved);
    }
    if ($cabflags&1) {
        my $i= index($data, "\x00", $coffFolders);
        my $cabprev= substr($data, $coffFolders, $i-$coffFolders);
        $coffFolders = $i+1;

        $i= index($data, "\x00", $coffFolders);
        my $diskprev= substr($data, $coffFolders, $i-$coffFolders);
        $coffFolders = $i+1;

        printf("CAB prev='%s' : '%s'\n", $diskprev, $cabprev);
    }
    if ($cabflags&2) {
        my $i= index($data, "\x00", $coffFolders);
        my $cabnext= substr($data, $coffFolders, $i-$coffFolders);
        $coffFolders = $i+1;

        $i= index($data, "\x00", $coffFolders);
        my $disknext= substr($data, $coffFolders, $i-$coffFolders);
        $coffFolders = $i+1;
        printf("CAB next='%s' : '%s'\n", $disknext, $cabnext);
    }

    my @folders;
    for (0..$nFolders-1) {
        my $folderofs= $coffFolders+(8+$folderreserved)*$_;
        my @folder_fields= unpack("Vvva*", substr($data, $folderofs, 8+$folderreserved));
        my $coffData= $folder_fields[0];
        my $nBlocks= $folder_fields[1];
        my $compressed= $folder_fields[2];  # 0 = none, 1 = mszip, 2 = quantum
        my $reserved= $folder_fields[3];
        # todo: add data reserved here?
        push @folders, { 
            coffData=>$coffData,
            nblocks=>$nBlocks,
            compressed=>$compressed,
            reserved=>$reserved,
        };
        printf("%08lx: folder %d : off=%08lx comp=%d  nblocks = %d\n", $folderofs, $_, $coffData, $compressed, $nBlocks) if ($g_verbose>1);
        if (length($reserved)) {
            if ($reserved !~ /^\x00+$/) {
                my @f= unpack("V5a*", $reserved);
                my $appname= substr($f[5], $f[1]-0x1c, $f[2]-1);
                my $provname= substr($f[5], $f[3]-0x1c, $f[4]-1);
                printf("reserved  cpu=%08lx, appname[@%x,%x]='%s', provname[@%x,%x]='%s'\n",
                    $f[0], $f[1], $f[2], $appname, $f[3], $f[4], $provname);

            }
        }
    }
    printf("%08lx-%08lx folder entries\n", 36, 36+8*$nFolders) if ($g_verbose>1);

    my @names;
    my $ofs= $coffFiles;
    my ($inffolder, $inffile);
    my ($dllfolder, $dllfile);
    my ($xmlfolder, $xmlfile);
    for my $filenr (0..$nFiles-1) {
        my $fileofs= $ofs;
        my @file_fields= unpack("VVvVv", substr($data, $fileofs, 16));
        $ofs += 16;

        my $endstr= index($data, "\x00", $ofs);

        my $name= substr($data, $ofs, $endstr-$ofs);
        $ofs= $endstr+1;

        my $size= $file_fields[0];
        my $offset= $file_fields[1];
        my $foldernr= $file_fields[2];  # 0xfffd=from_pref, 0xfffe=to_next, 0xffff=prev_next
        my $datetime= $file_fields[3];
        my $attributes= $file_fields[4];
        push @{$folders[$foldernr]{files}}, {
            name=>$name,
            size=>$size, 
            offset=>$offset,
            datetime=>$datetime,
            attributes=>$attributes,
            index=>$filenr,
        };
        printf("%08lx: folder %2d: file %2d: %6d %s\n", $fileofs, $foldernr, $filenr, $size, $name) if ($g_verbose>1);

        if ($name =~ /\.000$/) {
            ($inffolder, $inffile)=($foldernr, $filenr);
        }
        elsif ($name =~ /\.999$/) {
            ($dllfolder, $dllfile)=($foldernr, $filenr);
        }
        elsif ($name eq "_setup.xml") {
            ($xmlfolder, $xmlfile)=($foldernr, $filenr);
        }

        push(@names, $name);
    }
    printf("%08lx-%08lx file entries\n", $coffFiles, $ofs) if ($g_verbose>1);

    my $infdata= GetCabFileData($data, \@folders, $inffolder, $inffile, $datareserved)
        if (defined $inffolder && defined $inffile);

    my $info= ProcessInfFile($infdata) if ($infdata);
    if (!$info) {
        warn "error processing .inf file\n";
    }
    else {
        $info->{cabfilenames}= \@names;
    }

    #todo: process _setup.xml
    # <characteristic type="aac.zoom60.png" translation="install">
    # <characteristic type="Extract">
    # <parm name="Source" value="AACZOO~1.006" />



    return {
        folders=> \@folders,
        version=> "$vermajor.$verminor",
        nFiles=>$nFiles,
        flags=>$cabflags,
        setID=>$setID,
        iCabinet=>$iCabinet,
        inffile=>$info,
        datareserved=>$datareserved,
    };
}

sub ExtractFiles {
    my $data= shift;
    my ($cabinfo, $savedir, $datareserved)= @_;

    mkdir $savedir;

    for my $foldernr (0..$#{$cabinfo->{folders}}) {
        my $folder= $cabinfo->{folders}[$foldernr];
        for my $filenr (0..$#{$folder->{files}}) {
            my $file= $folder->{files}[$filenr];
            my $filedata= GetCabFileData($data, $cabinfo->{folders}, $foldernr, $filenr, $datareserved);

            my $filerec;
            if ($cabinfo->{inffile} && $file->{name} =~ /\.(\d\d\d)$/) {
                my $extnr= int($1);
                
                ($filerec) = grep { $_->{cabextnr}==$extnr } values %{$cabinfo->{inffile}{files}};
                #printf("file: %s\n", join(", ", map { sprintf("%s=%s", $_, $file->{$_})}keys %$file));
                #printf("filerec: %s\n", join(", ", map { sprintf("%s=%s", $_, $filerec->{$_})}keys %$filerec));
            }

            my $filename= $filerec ? $filerec->{name} : $file->{name};
            if (!$filename) {
                if ($file->{name} =~ /\.000$/) {
                    # give setup dll a sensible name.
                    ($filename= "$savedir.inf") =~ s/.*\///;
                }
                else {
                    $filename= $file->{name};
                }
            }
            my $unk1 = defined $filerec->{unk1}?$filerec->{unk1}:-1;
            printf("saving file %d/%d - %d (%d): %s as %s\n", $foldernr, $filenr, $file->{index}, $unk1, $file->{name}, $filename) if ($g_verbose);
            $file->{saved_as}= GetUniqueName($savedir, $filename);
            SaveFile($file->{saved_as}, $filedata);
        }
    }
}
sub SaveFile {
    my $fn= shift;
    my $data= shift;

    my $fh= IO::File->new($fn, "w+") or die "$fn: $!\n";
    binmode $fh;
    $fh->print($data);
    $fh->close();
}


sub GetCabFileData {
    my $data= shift;
    my ($folders, $foldernr, $filenr, $datareserved)= @_;

    my $folder= $folders->[$foldernr];
    my $file= $folder->{files}[$filenr];

    if (!exists $decompressors{$folder->{compressed}}) {
        die sprintf("compression type %d unknown\n", $folder->{compressed});
    }
    my $decompress= $decompressors{$folder->{compressed}};

    my $filedata= "";

    my $blockofs= $folder->{coffData};
    my $dataofs= $file->{offset};
    my $remainingsize= $file->{size};
    my $ofs= 0;
    while (1) {
        my ($checksum, $compressedsize, $fullsize, $reserved)= unpack("Vvva*", substr($data, $blockofs, 8+$datareserved));
        #printf("chk=%08lx csize=%08lx fsize=%08lx res=%s\n", $checksum, $compressedsize, $fullsize, unpack("H*", $reserved));

        if ($dataofs <= $ofs) {
            #   d  o   f+o
            #printf("case1: d=%08lx o=%08lx\n", $dataofs, $ofs);
            my $compresseddata = substr($data, $blockofs+$datareserved+8, $compressedsize);
            my $chunklen= $remainingsize;
            if ($chunklen>= $fullsize) {
                $chunklen = $fullsize;
            }
            my $decdata= $decompress->($compresseddata);

            if (!defined $decdata || length($decdata)!=$fullsize) {
                printf("l(enc)=%08lx l(dec)=%08lx fs=%08lx do=%08lx, o=%08lx  do-o=%08lx, cl=%08lx\n", 
                    length($compresseddata), length($decdata), $fullsize, $dataofs, $ofs, $dataofs-$ofs, $chunklen);
                printf("...%s\n", unpack("H*", $compresseddata));
            }

            #printf("#1#fd=%08lx cl=%08lx\n", length($filedata), $chunklen);
            $filedata .= substr($decdata,0, $chunklen);
            #printf("#1#fd=%08lx\n", length($filedata));
            $remainingsize -= $chunklen;
        }
        elsif ($ofs < $dataofs && $dataofs < $ofs+$fullsize) {
            #   o  d   f+o
            #printf("case2: o=%08lx d=%08lx o+f=%08lx\n", $ofs, $dataofs, $ofs+$fullsize);
            my $compresseddata = substr($data, $blockofs+$datareserved+8, $compressedsize);
            my $chunklen= $remainingsize;
            if ($chunklen>= $fullsize-($dataofs-$ofs)) {
                $chunklen = $fullsize;
            }
            my $decdata= $decompress->($compresseddata);

            if (!defined $decdata || length($decdata)!=$fullsize) {
                printf("l(enc)=%08lx l(dec)=%08lx fs=%08lx do=%08lx, o=%08lx  do-o=%08lx, cl=%08lx\n", 
                    length($compresseddata), length($decdata), $fullsize, $dataofs, $ofs, $dataofs-$ofs, $chunklen);
                printf("...%s\n", unpack("H*", $compresseddata));
            }

            #printf("#2#fd=%08lx cl=%08lx  d=%08lx o=%08lx d-o=%08lx\n", length($filedata), $chunklen, $dataofs, $ofs, $dataofs-$ofs);
            $filedata .= substr($decdata,$dataofs-$ofs, $chunklen);
            #printf("#2#fd=%08lx\n", length($filedata));
            $remainingsize -= $chunklen;
        }
        else {
            # f+o  d
            #printf("case3: o=%08lx o+f=%08lx d=%08lx\n", $ofs, $ofs+$fullsize, $dataofs);
        }
        $ofs += $fullsize;

        last if ($remainingsize==0);

        $blockofs += 8+$datareserved+$compressedsize;
    }
    return $filedata;
}
##########################################
# process compiled inf file
sub ProcessInfFile {
    my $data= shift;

    my @fields= unpack("a4V11v6V6v6V", $data);
    my $magic= $fields[0];

    if ($magic ne "MSCE" && $magic ne "CE4+") {
        print "invalid magic: $magic\n";
        return;
    }
    my $filelength= $fields[2];

    my $nrstrs= $fields[12];
    my $nrfiledirs= $fields[13];
    my $nrfiles= $fields[14];
    my $nrregpaths= $fields[15];
    my $nrregvalues= $fields[16];
    my $nrshortcuts= $fields[17];

    my $strsoffset     = $fields[18];
    my $filedirsoffset = $fields[19];
    my $filesoffset    = $fields[20];
    my $regpathsoffset = $fields[21];
    my $regvaluesoffset= $fields[22];
    my $shortcutsoffset= $fields[23];

    my $processortype= $fields[5];
    my $versionmin= sprintf("%d.%02d.%04d", $fields[6], $fields[7], $fields[10]);
    my $versionmax= sprintf("%d.%02d.%04d", $fields[8], $fields[9], $fields[11]);

    my $appnameofs           = $fields[24];
    my $appnamelen           = $fields[25];
    my $provnameofs           = $fields[26];
    my $provnamelen           = $fields[27];
    my $unsupportedplatformsofs= $fields[28];
    my $unsupportedplatformslen= $fields[29];

    #printf("strings o=%04x n=%d\n", $strsoffset, $nrstrs);
    #printf("filedirs o=%04x n=%d\n", $filedirsoffset, $nrfiledirs);
    #printf("files o=%04x n=%d\n", $filesoffset, $nrfiles);
    #printf("regpaths o=%04x n=%d\n", $regpathsoffset, $nrregpaths);
    #printf("regvalues o=%04x n=%d\n", $regvaluesoffset, $nrregvalues);
    #printf("shortcuts o=%04x n=%d\n", $shortcutsoffset, $nrshortcuts);
    #printf("app o=%04x l=%d\n", $appnameofs, $appnamelen);
    #printf("prov o=%04x l=%d\n", $provnameofs, $provnamelen);
    #printf("platforms: o=%04x l=%d\n", $unsupportedplatformsofs, $unsupportedplatformslen);

    my $strings=   parse_strs($data, $strsoffset, $nrstrs);
    my $filedirs=  parse_filedirs($data, $filedirsoffset,  $nrfiledirs,   $strings);
    my $files=     parse_files($data, $filesoffset, $nrfiles,             $filedirs);
    my $regpaths=  parse_regpaths($data, $regpathsoffset, $nrregpaths,    $strings);
    my $regvalues= parse_regvalues($data, $regvaluesoffset, $nrregvalues, $regpaths);
    my $shortcuts= parse_shortcuts($data, $shortcutsoffset, $nrshortcuts, $filedirs, $files, $strings);
    my $application= substr($data, $appnameofs, $appnamelen-1);
    $application =~ s/\x00+//;
    my $provider= substr($data, $provnameofs, $provnamelen-1);
    $provider =~ s/\x00+//;
    my @platforms= split /\x00/, substr($data, $unsupportedplatformsofs, $unsupportedplatformslen);

    return {
        processortype=>$processortype,
        versionmin=>  $versionmin,
        versionmax=>  $versionmax,
        application=>  $application,
        provider=>     $provider,
        platforms=>    \@platforms,
        strings=>      $strings,
        filedirs=>     $filedirs,
        files=>        $files,
        regpaths=>     $regpaths,
        regvalues=>    $regvalues,
        shortcuts=>    $shortcuts,
        unknown=>      [ @fields[1, 3, 4, 30] ],
    };
}
sub parse_strs {
    my $data= shift;
    my ($ofs, $nr)= @_;

    my %strings;

    for (0..$nr-1) {
        my ($id, $strlen)= unpack("vv", substr($data, $ofs, 4));
        my $string = substr($data, $ofs+4, $strlen-1);
        $string =~ s/\x00+$//;
        $strings{$id}= $string;
        #printf("str-%2d: %2d: %s\n", $_, $id, $strings{$id});
        $ofs += 4+$strlen;
    }
    return \%strings;
}

sub parse_filedirs {
    my $data= shift; 
    my ($ofs, $nr, $strings)= @_;

    my %filedirs;
    for (0..$nr-1) {
        my ($id, $len)= unpack("vv", substr($data, $ofs, 4));
        my @elements= unpack("v*", substr($data, $ofs+4, $len-2));
        $filedirs{$id}= join "\\", map { $strings->{$_} } @elements;

        #printf("dir-%2d: %2d: %s\n", $_, $id, $filedirs{$id});
        $ofs += 4+$len;
    }

    return \%filedirs;
}

sub parse_files {
    my $data= shift;
    my ($ofs, $nr, $filedirs)= @_;

    my %files;
    for (0..$nr-1) {
        my ($id, $dstpathid, $cabextnr, $flags, $len)= unpack("vvvVv", substr($data, $ofs, 12));
        my $filename= substr($data, $ofs+12, $len-1);
        $filename =~ s/\x00+//;
        $files{$id}= { 
            dstpath=>$filedirs->{$dstpathid} || "_unknownpath_",
            cabextnr=>$cabextnr,
            flags=>$flags,
            name=>$filename,
        };
# flags:
# 0x80000000  this file is a reference-counting shared file. It is not deleted at uninstall time unless its reference count is 0.
# 0x40000000  ignore file date (stored in the cabinet file) and always overwrite target (on CE device). Mutually exclusive with bit 29.
# 0x20000000  do not overwrite target if target is newer. Mutually exclusive with bit 30.
# 0x00000400  do not copy this file to the target unless the target already exists. Mutually exclusive with bit 4.
# 0x00000010  do not overwrite target if it already exists. Mutually exclusive with bit 10.
# 0x00000002  do not skip this file.
# 0x00000001  warn the user if this file is skipped.

        #printf("fil-%2d: %2d: dst=%d name=%s\n", $_, $id, $dstpathid, $filename);
        $ofs += 12 + $len;
    }
    return \%files;
}

sub parse_regpaths {
    my $data= shift;
    my ($ofs, $nr, $strings)= @_;

    my %regpaths;
    for (0..$nr-1) {
        my ($id, $hive, $len)= unpack("vVv", substr($data, $ofs, 8));
        my @elements= unpack("v*", substr($data, $ofs+8, $len-2));
        my $regpath= join "\\", map { $strings->{$_} } @elements;
        $regpaths{$id}= {hive=>$hive, name=>$regpath};
        $ofs += 8 + $len;
    }
    return \%regpaths;
}

sub parse_regvalues {
    my $data= shift;
    my ($ofs, $nr, $regpaths)= @_;

    my %regvalues;
    for (0..$nr-1) {
        my ($id, $dstpath_id, $unkflag, $regtype, $len)= unpack("vvvVv", substr($data, $ofs, 12));
        my $keyval= substr($data, $ofs+12, $len);

        # remove noclobber flag from regtype.
        my $noclobber= $regtype&2;
        $regtype &= ~2;

        my ($name, $value);
        if ($regtype==0) {
            if ($keyval =~ /^(.*?)\x00(.*?)\x00$/s) {
                ($name, $value)= ($1, $2);
            }
            else {
                die sprintf("unknown reg string format %s\n", unpack("H*", $keyval));
            }
        }
        elsif ($regtype==0x10001) {
            if ($keyval =~ /^(.*?)\x00(.*)$/s) {
                ($name, $value)= ($1, unpack("V", $2));
            }
            else {
                die "unknown reg dword format\n";
            }
        }
        elsif ($regtype==0x10000) {
            if ($keyval =~ /^(.*?)\x00(.*)\x00$/s) {
                ($name, $value)= ($1, [split /\x00/, $2]);
            }
            else {
                die "unknown reg multisz format\n";
            }
        }
        elsif ($regtype==1) {
            if ($keyval =~ /^(.*?)\x00(.*)$/s) {
                ($name, $value)= ($1, $2);
            }
            else {
                die sprintf("unknown reg binary format %s\n", unpack("H*", $keyval));
            }
        }
        else {
            die sprintf("unknown reg format %08lx: %s\n", $regtype, unpack("H*", $keyval));
        }

        $regvalues{$id}= {
            dst=>$regpaths->{$dstpath_id} || "_unknownpath_",
            unkflag=>$unkflag, regtype=>$regtype,
            noclobber=>$noclobber,
            name=>$name, value=>$value };

        $ofs += 12 + $len;
    }
    return \%regvalues;
}
sub parse_shortcuts {
    my $data= shift;
    my ($ofs, $nr, $filedirs, $files, $strings)= @_;

    my %shortcuts;
    for (0..$nr-1) {
        my ($id, $dstpathid, $cedirid, $targetid, $isfilelink, $unk3, $nameid)= unpack("vvvvvvv", substr($data, $ofs, 14));
        $shortcuts{$id}= { 
            dstpath=>$filedirs->{$dstpathid} || ($cedirid?"%CE$cedirid%" : sprintf("_unknownpath_%d", $dstpathid)), 
            cedirid=>$cedirid, isfilelink=>$isfilelink, unk3=>$unk3, 
            linktarget=>($isfilelink?$files->{$targetid}:$filedirs->{$targetid}),
            linkname=>$strings->{$nameid} ||  sprintf("_unknownname_%d", $nameid)
        };
        #printf("sc-%2d: %2d: dst=%d tgt=%d name=%d\n", $_, $id, $dstpathid, $targetid, $nameid);
        $ofs += 14;
    }
    return \%shortcuts;
}


#################################
#  inf format output
sub txtinf_write_header {
    my ($info, $cabinfo)= @_;
    print <<__EOF__;
[Version]
Signature = "\$Windows NT\$"
Provider = "$info->{provider}"
CESignature = "\$Windows CE\$"

[CEStrings]
AppName   = "$info->{application}"
InstallDir   = "$info->{strings}{1}"

[CEDevice]
ProcessorType = $info->{processortype}
UnsupportedPlatforms = @{[join ",", map { sprintf(qq("%s"), $_); } @{$info->{platforms}}]}
VersionMin = $info->{versionmin}
VersionMax = $info->{versionmax}

__EOF__
}
sub txtinf_write_default_install {
    my ($info, $cabinfo, $filetargets, $shortcuttargets)= @_;
    # todo: figure out what the setup.dll is.
    print <<__EOF__;
[DefaultInstall]
Copyfiles=@{[join ",", keys %$filetargets]}
AddReg=RegSettings
CEShortcuts=@{[join ",", keys %$shortcuttargets]}
__EOF__
    if ($cabinfo) {
        my ($setupdll)= grep { $_->{name} =~ /\.999/ } @{$cabinfo->{folders}[0]{files}};
        if ($setupdll) {
            #todo: change .999 extension in .dll  ( also in sourcefile section )
            print "CESetupDLL=$setupdll->{name}\n";
        }
        my @selfregister= grep {$_->{flags}&0x10000000} values %{$info->{files}};
        print "CESelfRegister=", join(",",map { $_->{name} } @selfregister), "\n" if (@selfregister);
    }

    print "\n";
}
sub txtinf_write_source_files {
    my ($files)= @_;
    my $disknr= 1;
    # todo: is it called 'files'
    print <<__EOF__;
[SourceDisksNames]
$disknr = ,"All Files",,cabfiles

[SourceDisksFiles]
__EOF__
    for (values %$files) {
        printf("\"%s\"=%d\n", $_->{saved_as}||$_->{name}, $disknr);
    }
    print "\n";
}
sub txtinf_write_destinations {
    my ($info, $filetargets, $shortcuttargets)= @_;

    print "[DestinationDirs]\n";
    for (keys %$filetargets) {
        printf("%s= 0, \"%s\"\n", $_, $filetargets->{$_}{targetdir});
    }
    for (keys %$shortcuttargets) {
        printf("%s= 0, \"%s\"\n", $_, $shortcuttargets->{$_}{targetdir});
    }

    print "\n";
}
sub txtinf_write_file_target {
    my ($info, $name, $files)= @_;

    print "[$name]\n";
    for (@$files) {
        #todo: ... find cabfilename
        my $cabfilename= $_->{saved_as}||$_->{name};
        $cabfilename= ""  if ($cabfilename eq $_->{name});

        printf("\"%s\",%s,%s\n", 
            $_->{name}, 
            $cabfilename?"\"$cabfilename\"":"", 
            $_->{flags}?sprintf(",0x%08lx", $_->{flags}):"");
    }
    print "\n";
}
sub txtinf_write_shortcut_target {
    my ($info, $name, $shortcuts)= @_;

    print "[$name]\n";
    for (@$shortcuts) {
        ( my $name= $_->{linkname} ) =~ s/\.lnk//;
        printf("\"%s\",%d,\"%s\"\n", $name, 1-$_->{isfilelink}, $_->{isfilelink}?$_->{linktarget}{name}:$_->{linktarget});
    }
    print "\n";
}
sub txtinf_write_reg_settings {
    my ($regvalues)= @_;

    print "[RegSettings]\n";

    for (values %$regvalues) {
        my $flags= $_->{regtype} | ($_->{noclobber}?2:0);

        printf("%s,\"%s\",\"%s\",0x%x,%s\n",
            hivename($_->{dst}{hive}),
            $_->{dst}{name},
            $_->{name},
            $flags, txtinf_regvaluestring($_));
    }
    print "\n";
}
sub txtinf_regvaluestring {
    my ($re)= @_;
    if ($re->{regtype}==0x10001) {
        return $re->{value}<10 ? $re->{value} : sprintf("0x%x", $re->{value});
    }
    elsif ($re->{regtype}==0x10000) {
        return join(', ', map { sprintf("\"%s\"", $_); } @{$re->{value}});
    }
    elsif ($re->{regtype}==0) {
        return sprintf("\"%s\"", $re->{value});
    }
    elsif ($re->{regtype}==1) {
        return join(',', map { sprintf("%02x", $_); } unpack("C*", $re->{value}));
    }
    return sprintf("unknown: %08lx %s", $re->{regtype}, unpack("H*", $re->{value}));

}
sub txtinf_MakeUniqueKey {
    my ($hash, $basename, $prefix)= @_;

    $basename =~ s/\W//g;

    my $key= "$prefix$basename";
    my $i= 0;
    while (exists $hash->{$key}) {
        $key= "$prefix$basename$i"; $i++;
    }
    return $key;
}
sub txtinf_get_filetargets {
    my ($files)= @_;

    my %dirs;
    for (values %$files) {
        my $dirname= $_->{dstpath};
        $dirs{lc($dirname)}{targetdir}= $dirname;
        push @{$dirs{lc($dirname)}{files}}, $_;
    }
    my %targets;
    for (values %dirs) {
        $targets{txtinf_MakeUniqueKey(\%targets, $_->{targetdir}, "CopyTo")}= $_;
    }

    return \%targets;
}
sub txtinf_get_shortcuttargets {
    my ($shortcuts)= @_;

    my %dirs;
    for (values %$shortcuts) {
        my $dirname= $_->{dstpath};
        $dirs{lc($dirname)}{targetdir}= $dirname;
        push @{$dirs{lc($dirname)}{shortcuts}}, $_;
    }
    my %targets;
    for (values %dirs) {
        $targets{txtinf_MakeUniqueKey(\%targets, $_->{targetdir}, "ShortcutsIn")}= $_;
    }

    return \%targets;
}
sub txtinf_write_file {
    my ($info, $cabinfo)= @_;

    txtinf_write_header($info);

    #todo: write [Strings] section
    #todo: change '%CE[0-9]+%' strings in friendly names in labels.
    #todo: shortcuts sections are optional.

    my $filetargets= txtinf_get_filetargets($info->{files});
    my $shortcuttargets= txtinf_get_shortcuttargets($info->{shortcuts});

    txtinf_write_default_install($info, $cabinfo, $filetargets, $shortcuttargets);

    for (keys %$filetargets) {
        txtinf_write_file_target($info, $_, $filetargets->{$_}{files});
    }
    for (keys %$shortcuttargets) {
        txtinf_write_shortcut_target($info, $_, $shortcuttargets->{$_}{shortcuts});
    }
    txtinf_write_reg_settings($info->{regvalues});
    txtinf_write_source_files($info->{files});

    txtinf_write_destinations($info, $filetargets, $shortcuttargets);
}
#################################
#  human readable output
sub print_info {
    my ($info)= @_;
    printf("processor=%d  versions: %s .. %s\n", 
        $info->{processortype}, $info->{versionmin}, $info->{versionmax});
    printf("application=%s  provider=%s\nunsupported platforms: %s\n", 
        $info->{application}, $info->{provider}, join(", ", @{$info->{platforms}}));
    print "unknown: ", join(", ", @{$info->{unknown}}), "\n";
    print "\n[files]\n";
    write_files($info->{files}, $info->{cabfilenames});
    print "\n[registry]\n";
    write_regvalues($info->{regvalues});
    print "\n[shortcuts]\n";
    write_shortcuts($info->{shortcuts});
}

sub write_files {
    my ($files, $cabfilenames)= @_;

    for (sort {$a<=>$b} keys %$files) {
        my $f= $files->{$_};
        printf("%2d: %2d %08x %s %s\\%s\n", $_, 
            $f->{cabextnr}, $f->{flags},
            $cabfilenames?(grep { $_ =~ sprintf("\.%03d", $f->{cabextnr}) } @$cabfilenames):"",
            $f->{dstpath}, $f->{name});
    }
}
sub write_regvalues {
    my ($regvalues)= @_;
    for (sort {$a<=>$b} keys %$regvalues) {
        my $re= $regvalues->{$_};
        printf("%2d: %d [%s\\%s] %s %s=%s\n",
            $_, $re->{unkflag}, 
            hivename($re->{dst}{hive}), $re->{dst}{name},
            $re->{noclobber}?"NC":"",
            $re->{name}, regvaluestring($re));
    }
}
sub hivename {
    my ($hive)= @_;
    if (exists $hivename{$hive}) {
        return $hivename{$hive};
    }
    else {
        return sprintf("unknownhive_%d", $hive);
    }
}
sub regvaluestring {
    my ($re)= @_;
    if ($re->{regtype}==0x10001) {
        return sprintf("dword:%08lx", $re->{value});
    }
    elsif ($re->{regtype}==0x10000) {
        return sprintf("multisz:%s", join(', ', map { sprintf("'%s'", $_); } @{$re->{value}}));
    }
    elsif ($re->{regtype}==0) {
        return sprintf("'%s'", $re->{value});
    }
    elsif ($re->{regtype}==1) {
        return sprintf("hex:%s", unpack("H*", $re->{value}));
    }
    return sprintf("unknown: %08lx %s", $re->{regtype}, unpack("H*", $re->{value}));
}
sub write_shortcuts {
    my ($shortcuts)= @_;
    for (sort {$a<=>$b} keys %$shortcuts) {
        my $sc= $shortcuts->{$_};
        printf("%2d: %d %d %d %s\\%s = %s\n", $_, 
            $sc->{cedirid}, $sc->{isfilelink}, $sc->{unk3}, 
            $sc->{dstpath}, $sc->{linkname}, 
            $sc->{linktarget}?($sc->{isfilelink}?sprintf("%s\\%s", $sc->{linktarget}{dstpath}, $sc->{linktarget}{name}):$sc->{linktarget}):"_unknowntarget_");
    }
}