#!/usr/bin/perl -w
# Build an installable Pocket PC cabinet file.
# Copyright 2006 Shaun Jackman

use strict;
use Getopt::Long;
use Pod::Usage;


# Constants.
my $architecture = 2577; # StrongARM
my @version_requirements = (3, 0, 10, 0, 0, 0); # 3.0.0 to 10.0.0
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 @files;

# RegHives.
my $reghives_count = 0;

# RegKeys.
my $regkeys_count = 0;

# Links.
my $links_count = 0;


# 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 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(<>) {
		s/\\ /~/;
		my ($file, $directory) = split;
		$file =~ s/~/ /;
		$directory =~ s/~/ /;
		next if length $directory == 0;

		my $id = ++$file_count;
		$file_ids{$file} = $id;
		$files[$id] = get_directory_id "$destdir$directory";
	}
}


# Returns the entire manifest.
sub get_manifest($$)
{
	my ($provider, $application) = @_;

# Header.
	my $offset = 100;

# Application.
	my $application_offset = $offset;
	$application .= "\0";
	$offset += length $application;

# Provider.
	my $provider_offset = $offset;
	$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;
		$strings .= pack 'vv', $string_id, 1 + length $string;
		$strings .= "$string\0";
	}
	$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/^.*\///;
		print "$file($file_id): $directory_id\n" if $verbose;
		$files .= pack 'vvvVv', $file_id, $directory_id, $file_id,
			0, 1 + length $file;
		$files .= "$file\0";
	}
	$offset += length $files;

# RegHives.
	my $reghives_offset = $offset;
	my $reghives = '';
	$offset += length $reghives;

# RegKeys.
	my $regkeys_offset = $offset;
	my $regkeys = '';
	$offset += length $regkeys;

# Links.
	my $links_offset = $offset;
	my $links = '';
	$offset += length $links;

# Header.
	my $length = $offset;
	my @fields = (
		0, $length, 0, 1, $architecture,
		@version_requirements,
		$string_count, $directory_count, $file_count,
		$reghives_count, $regkeys_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;
}


# Prints the version message and exits.
sub version()
{
	print
		"pocketpc-cab 1.0.1\n" .
		"Written by Shaun Jackman <sjackman\@gmail.com>.\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 = '';

	GetOptions(
			"provider=s" => \$provider,
			"application=s" => \$application,
			"source=s" => \$sourcedir,
			"dest=s" => \$destdir,
			"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 `install-files --help' for more information.\n";
		exit 1;
	}
	my $cab_filename = pop @ARGV;

	# Parse the input file.
	parse_input( $destdir);

	# Create the manifest.
	my $manifest = "manifest.000";
	open MANIFEST, ">$manifest";
	binmode MANIFEST;
	print MANIFEST get_manifest( $provider, $application);
	close MANIFEST;

	# Copy the data files.
	my $munged_files = '';
	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<pocketpc-cab> [I<OPTION>]... I<INPUTFILE> I<CABINET>

=head1 DESCRIPTION
																	
Read the INPUTFILE, which is a list of filenames and destination
directories, and create CABINET, a cabinet file, that will install
those files into the specified directories.

=head1 OPTIONS

=over

=item B<-p, --provider>=I<PROVIDER>

set the provider name

=item B<-a, --application>=I<APPLICATION>

set the application name

=item B<-s, --source>=I<SOURCE>

set the source directory

=item B<-d, --dest>=I<DEST>

set the destination directory

=item B<-v, --verbose>

display verbose output

=item B<--help>

display a brief help message

=item B<--man>

display the full documentation

=back

=head1 EXAMPLES

 $ cat > foobar.files <<EOF
 foobar.exe /bin
 foobar.dll /windows
 EOF
 $ pocketpc-cab -p Fooware -a FooBar foobar.files foobar.cab

=head1 AUTHOR

Written by Shaun Jackman.

=head1 REPORTING BUGS

Report bugs to Shaun Jackman <sjackman@gmail.com>.

=head1 COPYRIGHT

Copyright 2006 Shaun Jackman

This is free software; see the source for copying conditions. There is
NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE.

=head1 SEE ALSO

=over

=item B<lcab>(1)

create cabinet archives

=item B</usr/share/doc/pocketpc-cab/wince_cab_format.html>

Windows CE installation cabinet file format

=back

=cut


ChangeLog

2006-04-06  Shaun Jackman  <sjackman@gmail.com>

	* Release version 1.0.1.
	* Fix the CAB for WinCE5 by putting the manifest.000 file first in
	the cabinet file.
	Thanks to Rouven Schürch <rouven.schuerch@tegonal.com>.

2004-09-17  Shaun Jackman  <sjackman@debian.org>

	* Initial release, version 1.0.0.
