#!/usr/bin/perl -w
# this is complementary to the wince_cab_format.html file,
# which gives a full description of all components
use strict;

my %arch = (
 '0',     'none',
 '103',   'SHx SH3',
 '104',   'SHx SH4',
 '386',   'Intel 386',
 '486',   'Intel 486',
 '586',   'Intel Pentium',
 '601',   'PowerPC 601',
 '603',   'PowerPC 603',
 '604',   'PowerPC 604',
 '620',   'PowerPC 620',
 '821',   'Motorola 821',
 '1824',  'ARM 720',
 '2080',  'ARM 820',
 '2336',  'ARM 920',
 '2577',  'StrongARM',
 '4000',  'MIPS R4000',
 '10003', 'Hitachi SH3',
 '10004', 'Hitachi SH3E',
 '10005', 'Hitachi SH4',
 '21064', 'Alpha 21064',
 '70001', 'ARM 7TDMI'
);

my @ce = (
  undef,
  '\Program Files',
  '\Windows',
  '\Windows\Desktop',
  '\Windows\StartUp',
  '\My Documents',
  '\Program Files\Accessories',
  '\Program Files\Communications',
  '\Program Files\Games',
  '\Program Files\Pocket Outlook',
  '\Program Files\Office',
  '\Windows\Programs',
  '\Windows\Programs\Accessories',
  '\Windows\Programs\Communications',
  '\Windows\Programs\Games',
  '\Windows\Fonts',
  '\Windows\Recent',
  '\Windows\Favorites'
);

my @hkeys = (
  undef,
  'HKEY_CLASSES_ROOT',
  'HKEY_CURRENT_USER',
  'HKEY_LOCAL_MACHINE',
  'HKEY_USERS'
);

sub hexdump($$) {
  my $id  = $_[0];
  my $dat = $_[1];
  my $row = 12;
  for my $pos (0 .. (length($dat)/$row)) {
    my $seg = substr $dat, $pos * $row, $row;
    my $hex = join ' ', map { sprintf '%02x', $_ } unpack 'c*', $seg;
    $seg =~ s/[\000-\037\200-\377]/./g;
    printf '%s %-'.int($row*3)."s  %s\n", $id, $hex, $seg;
  }
}

for my $hdrfile (@ARGV) {
  if (open FH, "<$hdrfile") {
    my $x;
    # read fixed-size header
    read FH, $x, 100;
    my @hdr = unpack 'V12v6V6v8', $x;

    if ($hdr[0] == 0x4543534D) {
      # HEADER section
      print "$hdrfile HEADER\n";
      print "  length       = $hdr[2] bytes\n";
      print "  architecture = ".($arch{$hdr[5]} || 'unknown')." ($hdr[5])\n";
      print "  counts       = " . join(',', @hdr[12..17]) . "\n";
      print "  offsets      = " . join(',', @hdr[18..23]) . "\n";
      print "  strings      = " . join(',', @hdr[24..29]) . "\n";
      print "  unknowns     = " . join(',',($hdr[1],@hdr[3..4],@hdr[30..31]))
                                . "\n";
      print "  min WinCE v. = $hdr[6].$hdr[7]";
      print " [build $hdr[10]]" if $hdr[10] > 0; print "\n";
      print "  max WinCE v. = $hdr[8].$hdr[9]";
      print " [build $hdr[11]]" if $hdr[11] > 0; print "\n";

      # header STRINGS
      seek FH, $hdr[24], 0;
      read FH, $x, $hdr[25]; chop $x;
      print "  app name     = $x\n";

      seek FH, $hdr[26], 0;
      read FH, $x, $hdr[27]; chop $x;
      print "  provider     = $x\n";

      if ($hdr[29] > 0) {
	seek FH, $hdr[28], 0;
	read FH, $x, $hdr[29]; chop $x; chop $x;
	print "  unsupported  = ".join(',', split /\000/, $x)."\n";
      }

      # STRINGS section
      print "$hdrfile STRINGS\n";
      my @strings;
      seek FH, $hdr[18], 0;
      for (1 .. $hdr[12]) {
	read FH, $x, 4;
	my ($id, $len) = unpack 'vv', $x;
	read FH, $strings[$id], $len;
	chop $strings[$id];
	printf "  s%02d: %s\n", $id, $strings[$id];
      }

      # DIRS section
      print "$hdrfile DIRS\n";
      my @dirs;
      seek FH, $hdr[19], 0;
      for (1 .. $hdr[13]) {
	read FH, $x, 4;
	my ($id, $len) = unpack 'vv', $x;
	read FH, $x, $len; chop $x; chop $x;
	$dirs[$id] = join '\\', map {$strings[$_]} unpack 'v*', $x;
	$dirs[$id] =~ s/%CE(\d+)%/$ce[$1]/eg;
	printf "  d%02d: %s\n", $id, $dirs[$id];
      }

      # FILES section
      print "$hdrfile FILES\n";
      my @files;
      seek FH, $hdr[20], 0;
      for (1 .. $hdr[14]) {
	read FH, $x, 12;
	my ($id, $dirid, $unk, $flags, $len) = unpack 'vvvVv', $x;
	read FH, $x, $len; chop $x;
	$files[$id] = join '\\', ($dirs[$dirid], $x);
	printf "  f%02d: %s\n", $id, $files[$id];
	printf "       unknown=%d flags=0x%08x\n", $unk, $flags;
      }

      # REGHIVES section
      print "$hdrfile REGHIVES\n";
      my @reghives;
      seek FH, $hdr[21], 0;
      for (1 .. $hdr[15]) {
	read FH, $x, 8;
	my ($id, $root, $unk, $len) = unpack 'vvvv', $x;
	read FH, $x, $len; chop $x; chop $x;
	$reghives[$id] = join '\\',
	  ($hkeys[$root], (map {$strings[$_]} unpack 'v*', $x));
	printf "  h%02d: %s\n", $id, $reghives[$id], $unk;
      }

      # REGKEYS section
      print "$hdrfile REGKEYS\n";
      seek FH, $hdr[22], 0;
      for (1 .. $hdr[16]) {
	read FH, $x, 12;
	my ($id, $hive, $unk, $flags, $len) = unpack 'vvvVv', $x;
	read FH, $x, $len;
	my $name = (split /\000/, $x)[0] || '';
	my $data = substr $x, length($name) + 1;

	printf "  k%02d: hive=%s\n", $id, $reghives[$hive];
	printf "       name=<<%s>> subst=%d flags=0x%08x\n", $name, $unk, $flags;

	if (($flags & 0x10001) == 0x10001) {
	  $x = unpack 'V', $data; printf "       [DWORD] %08x (%d)\n", $x, $x;
	}
	elsif (($flags & 0x10001) == 0x10000) {
	  for (split /\000/, $data) {printf "       [MULTI_SZ] <<%s>>\n", $_}
	}
	elsif (($flags & 0x10001) == 0x00001) {
	  printf "       [BINARY] (%d bytes hexdump follows)\n", length($data);
	  hexdump("      ", $data);
	}
	else {
	  chop $data; printf "       [SZ] %s\n", $data;
	}
      }

      # LINKS section
      print "$hdrfile LINKS\n";
      my @links;
      seek FH, $hdr[23], 0;
      for (1 .. $hdr[17]) {
	read FH, $x, 12;
	my ($id, $unk, $dir, $fid, $type, $len) = unpack 'vvvvvv', $x;
	read FH, $x, $len;
	my $name = join '\\', map {$strings[$_]} unpack 'v*', $x;
	$name = '%InstallDir%\\'.$name if $dir == 0;
	$name = $ce[$dir].'\\'.$name   if $dir > 0;
	if ($type == 0) {
	  $fid = ($fid == 0) ? '%InstallDir%' : $dirs[$fid];
	}
	else {
	  $fid = $files[$fid];
	}
	printf "  l%02d: src=<<%s>>\n", $id, $fid;
	printf "       dest=<<%s>>  (unk=%d)\n", $name, $unk;
      }

      print "\n";
    }
    else {
      print "$hdrfile: not a Windows CE install cabinet header\n";
    }
    close FH;
  }
  else {
    print "$hdrfile: $!\n";
  }
}
