#!/usr/bin/perl -w

##  Copyright 2003 Rien Croonenborghs, Yoshinori Takesako
##
##    This file is part of lcabperl.pl.
##    lcabperl.pl is free software; you can redistribute it and/or modify
##    it under the terms of the GNU General Public License as published by
##    the Free Software Foundation; either version 2 of the License, or
##    (at your option) any later version.
##    lcabperl.pl is distributed in the hope that it will be useful,
##    but WITHOUT ANY WARRANTY; without even the implied warranty of
##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##    GNU General Public License for more details.
##    You should have received a copy of the GNU General Public License
##    along with lcabperl; if not, write to the Free Software
##    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use strict;
use Getopt::Std;

## CONSTANTS
my $BLOCKSIZE	= 32768;
my $FILEOFFSET = 44; #(0x2c)
my $LINSEP = '/';
my $WINSEP = '\\';
## settings
my %cabheader = (	'sig' => "MSCF",		## signature
			'res1' => 0,
			'size' => 0,			## total size of cab file
			'res2' => 0,
			'offset' => $FILEOFFSET,	## offset of files
			'res3' => 0,
			'vmaj' => 1,			## 1
			'vmin' => 3,			## 3
			'numfolders' => 1,		## 0 (not supported)
			'numfiles' => 0,		## number of files in cab file
			'flags' => 0,
			'setid' => 1234,		## set ID (not supported)
			'cabid' => 0		);	## cab ID (not supported)
my %cabfolder = (	'offset' => 0,			## offset of data
			'numblocks' => 0,   		## number of blocks
			'typecmp' => 0		);	## 0 = no compression
my @cabblocks = ();
my @cabfiles = ();  

## options
my %opts;
my $opts_string = "hvsuno:";
getopts( "$opts_string", \%opts ) || usage();
## check the options
if( !%opts || !defined($opts{o}) || defined($opts{h}) || $#ARGV == -1 ) { usage(); }

## get all the input files
my @filelist = GetFileList( @ARGV );
## get filesize
my $totalfilesize = GetTotalFileSize( \@filelist );
## number of files and datablocks
my $numfiles = $#filelist + 1;
my $numblocks =  int $totalfilesize/$BLOCKSIZE + 1;
Debug( "$numfiles files, $totalfilesize bytes, $numblocks blocks" );


## 1. HEADER -------------------------------------------------------------------
##
## 1.1 number of files
$cabheader{'numfiles'} = $numfiles;
## 1.2 header size part 1
my $headersize = $FILEOFFSET + $numfiles * 16; 	## 1st part of cfile struct = 16 bytes
for( my $i=0; $i<$numfiles; ++$i )
{
	my $file = $filelist[$i]->{'path'};
	if( $opts{s} ) ## strip or change
	{
		$file = StripPath( $file );
	}
	else
	{
		$file = MakeWinPath( $file );
	}
	$headersize += length( $file ) + 1; ## + 1 for \0 !
}
$headersize += $numblocks * 8;		## 1st part cdata struct = 8 bytes


## 2. FOLDER -------------------------------------------------------------------
## 2.1 number of blocks
$cabfolder{'numblocks'} = $numblocks;
## 2.2 calculate and set data offset
my $dataoffset = 0;
for( my $i=0; $i<$numfiles; ++$i )
{
	my $file = $filelist[$i]->{'path'};
	if( $opts{s} ) ## strip or change
	{
		$file = StripPath( $file );
	}
	else
	{
		$file = MakeWinPath( $file );
	}
	$dataoffset += 16 + length( $file ) + 1;
}
$cabfolder{'offset'} = $FILEOFFSET + $dataoffset;


## 3. DATABLOCKS ---------------------------------------------------------------
## 3.1 get total filesize
my $totalfilesize2 = $totalfilesize;
## 3.2 setup the datablocks
if( $totalfilesize2 < $BLOCKSIZE ) ## just one block
{
	my %newcabblock = (	'header' => 0,				## to be used while writing, 0: write the header, 1: don't
				'checksum' => 0,			## datablock's checksum
				'numcbytes' => $totalfilesize2,		## number of compressed bytes (not supported, = numubytes )
				'numubytes' => $totalfilesize2	);	## number of uncompressed bytes
	$cabblocks[ $#cabblocks+1 ] = \%newcabblock;
	$headersize += $totalfilesize2;	## 1.2 header size part 1
}
else ## more than 1 block
{
	for( my $i=0; $i<$numblocks; ++$i )
	{
		if( $i != $numblocks-1 ) ## not the last block
		{
			my %newcabblock = (	'header' => 0,
						'checksum' => 0,
						'numcbytes' => $BLOCKSIZE,
						'numubytes' => $BLOCKSIZE	);
			$cabblocks[ $#cabblocks+1 ] = \%newcabblock;
			$headersize += $BLOCKSIZE;	## 1.2 header size part 1
		}
		else ## the last block
		{
			$totalfilesize2 -= $BLOCKSIZE * ($numblocks-1);
			my %newcabblock = (	'header' => 0,
						'checksum' => 0,
						'numcbytes' => $totalfilesize2,
						'numubytes' => $totalfilesize2	);
			$cabblocks[ $#cabblocks+1 ] = \%newcabblock;
			$headersize += $totalfilesize2;	## 1.2 header size part 1
		}
	}
}


## 1.3 header size part 2
$cabheader{'size'} = $headersize;


## 4. FILES --------------------------------------------------------------------
for( my $i=0; $i<$numfiles; ++$i )
{
	my $rhfile = $filelist[$i];
	## 4.1 new file
	my %newcabfile = (	'size' => 0,		## filesize
				'offset' => 0,		## offset of file in folder
				'index' => 0,		## 0 (not supported)
				'date' => 0,		## file date
				'time' => 0,		## file time
				'fileattr' => 0,	## file attributes
				'name' => ""		);
	## 4.1.1 file size
	$newcabfile{'size'} = $rhfile->{'size'};

	## 4.1.2 file name
	my $filename = $rhfile->{'path'};
	if( $opts{s} )
	{
		$filename = StripPath( $filename );
	}
	else
	{
		$filename = MakeWinPath( $filename );
	}
	$newcabfile{'name'} = $filename;
	$newcabfile{'name'} .= "\0";

	## 4.1.3 offset 1st cfile = 0, 2nd = offset 1st + filesize 1st, etc..
	if( $i==0 ) { $newcabfile{'offset'} = 0; }
	else
	{
		my $prevnewcabfile = $cabfiles[$i-1];
		my $prevrhfile = $filelist[$i-1];
		$newcabfile{'offset'} = $prevnewcabfile->{'offset'} + $prevrhfile->{'size'};
	}

	## 4.1.4 set file's date and time
	$newcabfile{'date'} = MakeCabFileDate( $rhfile );
	$newcabfile{'time'} = MakeCabFileTime( $rhfile );

	## 4.1.5 set file attributes
	# attribute of this file, as in DOS command ATTRIB
	# see Microsoft's CAB SDK for details
	# TODO: fileattr 0x80 bit should be set if:
	#     1) when a filename containing Unicode characters larger than 0x007F
	# and 2) when -n is not used.
	# otherwise this bit should be unset;
	$newcabfile{'fileattr'} = $opts{n} ? 0x00 : 0x80;

	$cabfiles[ $#cabfiles+1 ] = \%newcabfile;
}


## 5. WRITING -------------------------------------------------------------------
my $res = open( FP, ">$opts{o}" );
if( !defined($res) )
{
	Error( "Could not write to $opts{o}" );
	exit 0;
}
binmode( FP );
Debug( "Writing header" );		WriteHeader( \%cabheader );
Debug( "Writing folder" );		WriteFolder( \%cabfolder );
Debug( "Writing files" );		WriteFiles( \@cabfiles );
Debug( "Writing data" );		WriteData( \@filelist, \@cabblocks  );
close( FP );




################# USAGE #################
## print the usage for lcabperl
sub usage
{
	print "usage: $0 [-h] [-v] [-s] -o file.cab input [input...]\n";
	print "       $0 create a Cabinet File from a set of input files\n";
	print "       example: lcabperl.pl -v -o mail.cab ./Mail/ \n";
	print " -h: this help\n";
	print " -v: be verbose\n";
	print " -u: use unicode for filenames in CAB archive. enabled by default.\n";
	print "     if enabled, convert filenames to UTF-8 when necessary.\n";
	print " -n: do not convert filenames to unicode.\n";
	print " -s: strip the path\n";
	print " -o: output file\n";
	print " input can be file(s) or directory(ies)\n";
	exit;
}

################# FILE RELATED #################
## get the list with input files
#@ loop thru arguments:
## if arg is file, add
## if arg is dir -> loop recursive trhu dir
sub GetFileList
{
	my (@files) = @_;
	my @filelist = ();

	for( my $i=0; $i<=$#files; ++$i )
	{
		if( -f $files[$i] )
		{
			my %newfile = ( 'path' => $files[$i] );
			GetFileSpecs( \%newfile );
			$filelist[ $#filelist+1 ] = \%newfile;
			# TODO: here we should convert path to UTF-8 if
			#	1) $opt{n} is not set and 
			#	2) current locale is not UTF-8
			# $filelist[ $#filelist+1 ] -> {'path'}
		}
		elsif( -d $ARGV[$i] )
		{
			GetDirList( \@filelist, $files[$i] );
		}
	}

	return @filelist;

	sub GetDirList
	{
		my ($ralist,$path) = @_;

		foreach my $f( <$path/*> )
		{
			if( -d $f )
			{
				GetDirList( $ralist, $f );
			}
			elsif( -f $f )
			{
				my %newfile = ( 'path' => $f );
				GetFileSpecs( \%newfile );
				$$ralist[ $#$ralist+1 ] = \%newfile;
			}
		}
	}
}

## get filespecs
## filesize
## last modified time
sub GetFileSpecs
{
	my ($rhfile) = @_;
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat( $rhfile->{'path'} );
	$rhfile->{'size'} = $size;
	$rhfile->{'mtime'} = $mtime;
}


## make cabinet file date from certain file
sub MakeCabFileDate
{
	my ($rhfile) = @_;
	my $seconds = $rhfile->{'mtime'};
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($seconds);
	my $res = ( (($year+1900) - 1980 ) << 9 ) + ( ($mon+1) << 5 ) + $mday;
	return $res;
}

## make cabinet file date
sub MakeCabFileTime
{
	my ($rhfile) = @_;
	my $seconds = $rhfile->{'mtime'};
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($seconds);
	my $res = ( $hour << 11 ) + ( $min << 5 ) + ( $sec / 2 );
	return $res;
}

## get total filesize
sub GetTotalFileSize
{
	my ($ralist) = @_;
	my $sum = 0;
	foreach my $rhfile( @$ralist )
	{
		$sum += $rhfile->{'size'};
	}
	return $sum;
}

## strip the path
sub StripPath
{
	my ($path) = @_;
	$path = substr( $path, rindex($path,$LINSEP)+1 );
	return $path;
}

## make win path
sub MakeWinPath
{
	my ($path) = @_;
	$path =~ s/$LINSEP/$WINSEP/g;
	return $path;
}

################# DEBUG/ERROR MESSAGING #################
## Debug
sub Debug
{
	my ($msg) = @_;
	print STDOUT "[Debug] $msg\n" if( $opts{v} );
}
## Error
sub Error
{
	my ($msg) = @_;
	print STDOUT "[Error] $msg\n";
}

################# WRITING #################
## write the header
sub WriteHeader
{
	my ($rhcabheader) = @_;

	WriteByteBuffer( $rhcabheader->{'sig'} );
	WriteDword( $rhcabheader->{'res1'} );
	WriteDword( $rhcabheader->{'size'} );
	WriteDword( $rhcabheader->{'res2'} );
	WriteDword( $rhcabheader->{'offset'} );
	WriteDword( $rhcabheader->{'res3'} );
	WriteByte( $rhcabheader->{'vmin'} );
	WriteByte( $rhcabheader->{'vmaj'} );
	WriteWord( $rhcabheader->{'numfolders'} );
	WriteWord( $rhcabheader->{'numfiles'} );
	WriteWord( $rhcabheader->{'flags'} );
	WriteWord( $rhcabheader->{'setid'} );
	WriteWord( $rhcabheader->{'cabid'} );
}

## write the folder
sub WriteFolder
{
	my ($rhcabfolder) = @_;

	WriteDword( $rhcabfolder->{'offset'} );
	WriteWord( $rhcabfolder->{'numblocks'} );
	WriteWord( $rhcabfolder->{'typecmp'} );
}

## write the files
sub WriteFiles
{
	my ($racabfiles) = @_;

	foreach my $rhcabfile( @$racabfiles )
	{
		WriteDword( $rhcabfile->{'size'} );
		WriteDword( $rhcabfile->{'offset'} );
		WriteWord( $rhcabfile->{'index'} );
		WriteWord( $rhcabfile->{'date'} );
		WriteWord( $rhcabfile->{'time'} );
		WriteWord( $rhcabfile->{'fileattr'} );
		WriteByteBuffer( $rhcabfile->{'name'} );
	}
}

## write the actual data
sub WriteData
{
	my ($ralist,$racabblocks) = @_;

	my $block = 0;				## which block to use
	my $blockremaining = $BLOCKSIZE;	## keep track of bytes, in a block, that remain to be written,
						## before proceeding to the next block

	foreach my $rhfile( @$ralist )
	{
		my $rhcabblock = $$racabblocks[ $block ];
		my $buffer;					## read data
		my $bytesread = 0;				## bytes read per loop

		## open input file
		my $res = open( FP2, "<$rhfile->{'path'}" );
		if( !defined($res) )
		{
			Error( "Could not open file $rhfile->{'path'}" );
			exit;
		}
		binmode( FP2 );
		## try to read full blocks
		while( ($bytesread = read(FP2,$buffer,$blockremaining)) > 0 )
		{
			## write
			if( !$rhcabblock->{'header'} )
			{
				WriteDword( $rhcabblock->{'checksum'} );
				WriteWord( $rhcabblock->{'numcbytes'} );
				WriteWord( $rhcabblock->{'numubytes'} );
				$rhcabblock->{'header'} = 1;
			}
			WriteByteBuffer( $buffer );

			## could read full block
			if( $bytesread == $BLOCKSIZE )
			{
				## next block
				++$block;
				$rhcabblock = $$racabblocks[ $block ];
				$blockremaining = $BLOCKSIZE;
			}
			## could *not* read full block (either to complete a block or when eof)
			else
			{
				$blockremaining -= $bytesread;

				## next block if block is complete
				if( $blockremaining == 0 )
				{
					++$block;
					$rhcabblock = $$racabblocks[ $block ];
					$blockremaining = $BLOCKSIZE;
				}
			}

		}
		## close input file
		close( FP2 );
	}
}

## write (unsigned char) single byte with pack;
sub WriteByte
{
	my ($scalar) = @_;
	syswrite( FP, pack("C",$scalar) );
}

## write sequential (unsigned char) byte;
sub WriteByteBuffer
{
	my ($scalar) = @_;
	syswrite( FP, $scalar );
}

## write (unsigned short int) word;
sub WriteWord
{
	my ($scalar) = @_;
	if( $scalar =~ /[\0\/a-zA-Z]/ )
	{
		my @f = ();
		for(my $i=0; $i<length($scalar); ++$i )
		{
			$f[$#f+1] = ord( substr($scalar,$i,1) );
		}
		my $fmt = "S".length($scalar);
		syswrite( FP, pack( "$fmt", @f ) );
		return;
	}
	syswrite( FP, pack("S",$scalar) );
}

## write (unsigned long int) dword;
sub WriteDword
{
	my ($scalar) = @_;
	if( $scalar =~ /[\0\/a-zA-Z]/ )
	{
		my @f = ();
		for(my $i=0; $i<length($scalar); ++$i )
		{
			$f[$#f+1] = ord( substr($scalar,$i,1) );
		}
		my $fmt = "L".length($scalar);
		syswrite( FP, pack( "$fmt", @f ) );
		return;
	}
	syswrite( FP, pack("L",$scalar) );
}

## make (unsigned long int) CHECKSUM;
sub WriteChecksum
{
	my ($scalar) = @_;
	WriteDword($scalar);
}