#!/usr/bin/perl -w # Build an installable Pocket PC cabinet file. # Copyright 2006 Shaun Jackman use strict; use Getopt::Long; use Pod::Usage; use Text::ParseWords; use MIME::Base64; # Constants. my $architecture = 0; my @version_requirements = (4, 0, 6, 99, 0, -536870912); # 4.0.0 to 6.99.0xE0000000 (-536870912) my $verbose = 0; # Strings. my $string_count = 0; my %string_ids; # Directories. my $directory_count = 0; my %directory_ids; my @directories; # Files. my $file_count = 0; my %file_ids; my %file_dirs; my @files; # RegHives. my $reghive_count = 0; my %reghive_ids; my @reghive_roots; my @reghives; # RegKeys. my $regkey_count = 0; my %regkey_ids; my @regkey_hives; my @regkey_keys; my @regkey_names; my @regkey_values; my @regkey_xmlvalues; my @regkey_types; my @regkey_typeids; # Links. my $links_count = 0; my %links; my %link_targets; my %link_dirs; # Returns the ID of the specified string. sub get_string_id($) { my $string = shift; my $id = $string_ids{$string}; if( defined $id) { return $id; } else { $id = ++$string_count; $string_ids{$string} = $id; return $id; } } # Returns the ID of the specified directory. sub get_directory_id($) { my $directory = shift; my $id = $directory_ids{$directory}; if( defined $id) { return $id; } else { $id = ++$directory_count; $directory_ids{$directory} = $id; my @strings = split '/', $directory; my @ids; foreach my $string (@strings) { next if length $string == 0; push @ids, get_string_id( $string); } push @ids, 0; $directories[$id] = \@ids; return $id; } } # Returns the ID of the specified registry key sub get_reghive_id($$) { my $root = shift; my $key = shift; my $hive_name = "$root/$key"; my $id = $reghive_ids{$hive_name}; if( defined $id) { return $id; } else { $id = ++$reghive_count; $reghive_ids{$hive_name} = $id; my @strings = split '/', $key; my @ids; foreach my $string (@strings) { next if length $string == 0; push @ids, get_string_id( $string); } push @ids, 0; $reghives[$id] = \@ids; $reghive_roots[$id] = $root; return $id; } } sub parseint($) { my $str = shift; if ($str =~ /^0x/i) { return hex($str); } elsif ($str =~ /^0b/i) { return oct($str); } else { return int($str); } } # Returns a list of keys sorted by value. sub get_value_sorted_keys(%) { my %hash = @_; return sort { $hash{$a} <=> $hash{$b} } keys %hash; } # Creates the files. sub parse_input($) { my $destdir = shift; while(<>) { my ($file, $directory, $linkname, $linkdir) = &shellwords($_); next if length $directory == 0; my $id = ++$file_count; $file_ids{$file} = $id; $file_dirs{$file} = "$destdir$directory"; $files[$id] = get_directory_id "$destdir$directory"; if (defined $linkdir) { $linkname .= '.lnk'; $link_targets{$linkname} = "$destdir$directory/$file"; $link_dirs{$linkname} = $linkdir; my $linknameid = get_string_id $linkname; my $dirid = 0; my $basedir = 0; if ($linkdir =~ /^%CE(\d+)%$/) { $basedir = $1; } else { $dirid = get_directory_id $linkdir; } my @strings = split '/', $linkname; my @stringids; foreach my $string (@strings) { next if length $string == 0; push @stringids, get_string_id $string; } my $fileid = $id; my $id = ++$links_count; my $type = 1; $links{$id} = [ $dirid, $basedir, $fileid, 1, [ @stringids ] ]; } } } sub parse_regfile($) { my $regfile = shift; open REGFILE, "<$regfile"; while() { my @line = &shellwords($_); my $root = shift @line; my $key = shift @line; my $name = shift @line; my $type = shift @line; my $value = shift @line; next if length $root == 0; $root = uc($root); my $rootid; if ($root eq "HKCR") { $rootid = 1; } elsif ($root eq "HKCU") { $rootid = 2; } elsif ($root eq "HKLM") { $rootid = 3; } elsif ($root eq "HKU") { $rootid = 4; } else { print STDERR "Unrecognised registry root $root\n"; next; } $type = lc($type); my $manifest_value = ''; my $xml_value = ''; my $typeid; if ($type eq "string") { $manifest_value = $value . "\0"; $xml_value = $value; $typeid = 0x00000000; $type = "string"; } elsif ($type eq "binary") { $manifest_value = ''; while (length $value > 0) { my $byte = hex(substr $value,0,2,''); $manifest_value .= pack 'C',$byte; } $xml_value = encode_base64($manifest_value); chomp $xml_value; $typeid = 0x00000001; $type = "binary"; } elsif ($type eq "integer" || $type eq "int" || $type eq "dword") { my $int = parseint($value); $manifest_value = pack 'V', $int; $xml_value = "$int"; $typeid = 0x00010001; $type = "integer"; } elsif ($type eq "multistring") { my @strings; push @strings, $value if defined $value; push @strings, @line; $manifest_value = ''; $xml_value = ''; foreach my $string (@strings) { $manifest_value .= $string . "\0"; $xml_value .= $string . "\xEF\x80\x80"; # separate using EF8080, which is 0xF000 encoded as utf8 } $manifest_value .= "\0"; $typeid = 0x00010000; $type = "multiplestring"; } else { print STDERR "Unrecognised registry type $type\n"; next; } my $id = ++$regkey_count; $regkey_ids{$id} = $id; $regkey_hives[$id] = get_reghive_id $rootid, $key; $regkey_keys[$id] = "$root/$key"; $regkey_names[$id] = $name; $regkey_values[$id] = $manifest_value; $regkey_xmlvalues[$id] = $xml_value; $regkey_typeids[$id] = $typeid; $regkey_types[$id] = $type; } close REGFILE; } # Returns the entire manifest. sub get_manifest($$) { my ($provider, $application) = @_; # Header. my $offset = 100; # Application. my $application_offset = $offset; $application .= "\0"; while ((length $application) % 4 != 0) { $application .= "\0"; } $offset += length $application; # Provider. my $provider_offset = $offset; $provider .= "\0"; while ((length $provider) % 4 != 0) { $provider .= "\0"; } $offset += length $provider; # Unsupported platforms. my $unsupported_offset = $offset; my $unsupported = ''; $offset += length $unsupported; # Strings. my $strings_offset = $offset; my $strings = ''; foreach my $string (get_value_sorted_keys %string_ids) { my $string_id = $string_ids{$string}; print "$string($string_id)\n" if $verbose; $string .= "\0"; while ((length $string) % 4 != 0) { $string .= "\0"; } $strings .= pack 'vv', $string_id, length $string; $strings .= $string; } $offset += length $strings; # Directories. my $directories_offset = $offset; my $directories = ''; foreach my $directory (get_value_sorted_keys %directory_ids) { my $directory_id = $directory_ids{$directory}; my @ids = @{$directories[$directory_id]}; print "$directory($directory_id): @ids\n" if $verbose; $directories .= pack 'vv', $directory_id, 2 * scalar @ids; foreach my $id (@ids) { $directories .= pack 'v', $id; } } $offset += length $directories; # Files. my $files_offset = $offset; my $files = ''; foreach my $path (get_value_sorted_keys %file_ids) { my $file_id = $file_ids{$path}; my $directory_id = $files[$file_id]; my $file = $path; $file =~ s/^.*\///; $file .= "\0"; while ((length $file) % 4 != 0) { $file .= "\0"; } print "$file($file_id): $directory_id\n" if $verbose; $files .= pack 'vvvVv', $file_id, $directory_id, $file_id, 0, length $file; $files .= $file; } $offset += length $files; # RegHives. my $reghives_offset = $offset; my $reghives = ''; foreach my $reghive (get_value_sorted_keys %reghive_ids) { my $reghive_id = $reghive_ids{$reghive}; my $reghive_root = $reghive_roots[$reghive_id]; my @ids = @{$reghives[$reghive_id]}; print "$reghive($reghive_id): @ids\n" if $verbose; $reghives .= pack 'vvvv', $reghive_id, $reghive_root, 0, 2 * scalar @ids; foreach my $id (@ids) { $reghives .= pack 'v', $id; } } $offset += length $reghives; # RegKeys. my $regkeys_offset = $offset; my $regkeys = ''; foreach my $regkey_id (get_value_sorted_keys %regkey_ids) { my $hive = $regkey_hives[$regkey_id]; my $name = $regkey_names[$regkey_id]; my $value = $regkey_values[$regkey_id]; my $len = length($value); my $typeid = $regkey_typeids[$regkey_id]; print "$name($regkey_id): \n" if $verbose; $regkeys .= pack 'vvvVv', $regkey_id, $hive, 0, $typeid, length($name) + 1 + length($value); $regkeys .= $name . "\0" . $value; } $offset += length $regkeys; # Links. my $links_offset = $offset; my $links = ''; foreach my $link_id (keys %links) { my @link = @{ $links{$link_id} }; my $dirid = $link[0]; my $basedir = $link[1]; my $fileid = $link[2]; my $type = $link[3]; my @stringids = @{ $link[4] }; my $length = 2 * scalar @stringids; $links .= pack 'vvvvvv', $link_id, $dirid, $basedir, $fileid, $type, $length; foreach my $id (@stringids) { $links .= pack 'v', $id; } } $offset += length $links; # Header. my $length = $offset; my @fields = ( 0, $length, 0, 1, $architecture, @version_requirements, $string_count, $directory_count, $file_count, $reghive_count, $regkey_count, $links_count, $strings_offset, $directories_offset, $files_offset, $reghives_offset, $regkeys_offset, $links_offset, $application_offset, length $application, $provider_offset, length $provider, $unsupported_offset, length $unsupported, 0, 0); my $header = 'MSCE'; $header .= pack 'V11 v6 V6 v8', @fields; return $header . $application . $provider . $unsupported . $strings . $directories . $files . $reghives . $regkeys . $links; } # Returns a munged version of the specified filename. # Removes the leading path. Removes the extension. Removes spaces. # Truncates to eight characters. Pads to eight characters with leading # zeros. Adds a numeric extension. sub munge_filename($$) { my $munged = shift; my $extension = shift; $munged =~ s/^.*\///; $munged =~ s/\..*$//; $munged =~ s/ //; $munged = substr $munged, 0, 8; $munged = sprintf '%08s.%03d', $munged, $extension; return $munged; } # Returns the _setup.xml file sub get_setupxml($$) { my ($provider, $application) = @_; my $output; $output .= "\n"; $output .= "\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; my @filenames = get_value_sorted_keys %file_ids; my $firstdir = $file_dirs{$filenames[0]}; $firstdir =~ s/\//\\/g; $output .= "\t\t\n"; my $dirs = scalar keys %directory_ids; my $files = scalar keys %file_ids; $output .= "\t\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; $output .= "\t\t\n"; my $shortcuts = scalar keys %links; $output .= "\t\t\n"; $output .= "\t\n"; $output .= "\t\n"; foreach my $path (get_value_sorted_keys %file_ids) { my $file_id = $file_ids{$path}; my $dir = $file_dirs{$path}; my $file = $path; $file =~ s/^.*\///g; $file =~ s/\//\\/g; $dir =~ s/\//\\/g; my $munged_file = munge_filename $file, $file_id; $output .= "\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\t\t\n"; $output .= "\t\t\t\t\t\n"; $output .= "\t\t\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\n"; } foreach my $link (get_value_sorted_keys %link_dirs) { my $link_dir = $link_dirs{$link}; my $link_target = $link_targets{$link}; $link =~ s/\//\\/g; $link_dir =~ s/\//\\/g; $link_target =~ s/\//\\/g; $output .= "\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\t\t\n"; $output .= "\t\t\t\t\t\n"; $output .= "\t\t\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\n"; } $output .= "\t\n"; $output .= "\t\n"; foreach my $regkey_id (get_value_sorted_keys %regkey_ids) { my $key = $regkey_keys[$regkey_id]; my $name = $regkey_names[$regkey_id]; my $type = $regkey_types[$regkey_id]; my $value = $regkey_xmlvalues[$regkey_id]; $key =~ s/\//\\/g; $output .= "\t\t\n"; $output .= "\t\t\t\n"; $output .= "\t\t\n"; } $output .= "\t\n"; $output .= "\n"; return $output; } # Prints the version message and exits. sub version() { print "pocketpc-cab 1.0.1\n" . "Written by Shaun Jackman .\n" . "\n" . "Copyright 2006 Shaun Jackman\n" . "This is free software; see the source for copying\n" . "conditions. There is NO warranty; not even for\n" . "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n"; exit 0; } # Main. sub main() { # Parse the command line. my $provider = 'Provider'; my $application = 'Application'; my $sourcedir = ''; my $destdir = ''; my $regfile; GetOptions( "provider=s" => \$provider, "application=s" => \$application, "source=s" => \$sourcedir, "dest=s" => \$destdir, "registry=s" => \$regfile, "verbose|v!" => \$verbose, "help|?" => sub { pod2usage( -exitstatus => 0, -verbose => 1) }, "man" => sub { pod2usage( -exitstatus => 0, -verbose => 2) }, "version" => \&version); $sourcedir .= '/' if length $sourcedir > 0; $destdir .= '/' if length $destdir > 0; if( scalar @ARGV < 1) { print "pocketpc-cab: missing file arguments\n" . "Try `pocketpc-cab --help' for more information.\n"; exit 1; } my $cab_filename = pop @ARGV; # Parse the input file. parse_input( $destdir); parse_regfile($regfile) if defined $regfile; # Create the manifest. my $manifest = "manifest.000"; open MANIFEST, ">$manifest"; binmode MANIFEST; print MANIFEST get_manifest( $provider, $application); close MANIFEST; # Create the _setup.xml my $setupxml = "_setup.xml"; open SETUPXML, ">$setupxml"; print SETUPXML get_setupxml( $provider, $application); close SETUPXML; # Copy the data files. my $munged_files = " $setupxml"; my $i = 0; foreach my $file (get_value_sorted_keys %file_ids) { my $munged_file = munge_filename $file, ++$i; print "$file: $munged_file\n" if $verbose; `cp "$sourcedir$file" "$munged_file"`; exit $? >> 8 if $? > 0; $munged_files = ' ' . $munged_file . $munged_files; } $munged_files = 'manifest.000' . $munged_files; # Create the cab. print "$cab_filename: $munged_files\n" if $verbose; my $lcab_output = `lcab $munged_files $cab_filename`; exit $? >> 8 if $? > 0; print $lcab_output if $verbose; `rm $munged_files`; } # Entry-point. main; __END__ =head1 NAME pocketpc-cab - build an installable Pocket PC cabinet file =head1 SYNOPSIS B [I