#! /usr/bin/perl -w

#

# extresso - Extract and convert resources using resource scripts

#

# Copyright (C) 1998-2005 Oskar Liljeblad

#

# This program 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.

#

# This program 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 this program; if not, write to the Free Software Foundation,

# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.

#

use Getopt::Long;

use File::Spec;

use File::Basename;

use Term::ReadLine;

use LWP::Simple;

use HTTP::Status;

# global stuff

$PROGRAM = 'extresso';

$path_icotool = &path_or('icotool','../icotool/icotool');

$path_w32rtool = &path_or('wrestool','../wrestool/wrestool');

$path_tmpfile = 'extresso.fetch.tmp';

$tmpfile_exists = 0;

# initialize options

$arg_output = '.';

$arg_format = undef;

$arg_base = undef;

$arg_match = undef;

$arg_interactive = 0;

$arg_verbose = 0;

$arg_help = $arg_version = 0;

# get options

exit 1 if (!GetOptions("o|output=s"		=> \$arg_output,

                       "format=s"   		=> \$arg_format,

		       "b|base=s"   		=> \$arg_base,

                       "m|match=s"  		=> \$arg_match,

                       "i|interactive"	=> \$arg_interactive,

         	       "v|verbose"     => \$arg_verbose,

                       "help"          => \$arg_help,

                       "version"       => \$arg_version));

# deal with standard options

if ($arg_help) {

	print "Usage: extresso [OPTION]... [FILE]...\n";

	print "Extract and convert resources using resource scripts.\n";

	print "\n";

	print " -o, --output=DIR     where to place extracted files (default `.')\n";

	print "     --format=FORMAT  extraction format of icon resources (see icotool)\n";

	print " -b, --base=DIR       base directory of local files in scripts\n";

#	print " -m, --match=REGEXP   extract only from binaries whose name match this\n";

	print " -i, --interactive    prompt before extraction\n";

	print " -v, --verbose        explain what is being done\n";

	print "     --help           display this help and exit\n";

	print "     --version        output version information and exit\n";

  print "\n";

	print 'Report bugs to <@PACKAGE_BUGREPORT@>', "\n";

	exit;

}

if ($arg_version) {

	print "$PROGRAM (@PACKAGE@) @VERSION@\n";

	print "Written by Oskar Liljeblad.\n\n";

	print "Copyright (C) 1998-2005 Oskar Liljeblad.\n";

	print "This is free software; see the source for copying conditions.  There is NO\n";

	print "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n";

	exit;

}

# got no arguments?

if ($#ARGV == -1) {

	print STDERR "$PROGRAM: missing file argument\n";

	print STDERR "Try `$PROGRAM --help' for more information.\n"

}

# initialize objects if necessary

$obj_term = new Term::ReadLine 'extresso' if ($arg_interactive);

# process each non-option argument

for ($c = 0 ; $c <= $#ARGV ; $c++) {

	print STDERR "Processing $ARGV[$c]\n" if $arg_verbose;

	&process_script($ARGV[$c]);

}

#

# Subroutines

#

sub process_script {

	my ($file) = @_;

	# open the file

	die "$PROGRAM: $file: $!\n" if (!open(FH, $file));

	# variable initializations

	my ($line, $keyword, $param);

	my ($current_file) = undef;							# name of current resource achive

	my ($process_file) = 1;									# how to process resource archives

	my ($always_process_file) = undef;			# true if process_file should not be changed

	my ($process_resource) = 1;							# how to process a resource

	my ($always_process_resource) = undef;	# true if process_resource should not be changed

	# read each line

	while (defined ($line = <FH>)) {

		# strip leading and trailing whitespace

		$line =~ s/^\s*(\S?.*?\S?)\s*$/$1/;

		# skip empty lines and comments

		next if ($line eq '' || $line =~ /^#/);

		# split line into keyword and parameters

		($keyword,$param) = ($line =~ /^(\S*)\s*(.*)?$/);

		next if (!defined $keyword || $keyword eq '');

		# check parameter

		next if &check_missing($file, $keyword, $param);

		# version keyword

		if ($keyword eq 'version') {

			if ($param > 1) {

				warn "$file: resource script version `$param' not supported\n";

				return;

			}

		}

		# archive keyword

		elsif ($keyword eq 'file') {

			$current_file = $param;

			# if interactive, ask if we are to process this archive

			if (!$always_process_file) {

				if ($arg_interactive) {

					print "line ${.}: $keyword $param\n";

					my $res = &ask_interaction("Process resources in `$param'", 'yin');

					$always_process_file = 1 if (lc $res ne $res);

					$process_file = 0 if (lc $res eq 'n');

					$process_file = 1 if (lc $res eq 'y');

					$process_file = 2 if (lc $res eq 'i');

				} else {

					$process_file = 1;

				}

			}

			# get the file (local or remote)

			if ($tmpfile_exists) {

			    unlink $path_tmpfile;

			    $tmpfile_exists = 0;

			}

			$current_file = &fetch_file($current_file);

			return if (!defined $current_file);

			# check if the file actually exists

			if (!-e $current_file) {

				warn "$current_file: No such file or directory\n";

				return;

			}

		}

		# resource keyword

		elsif ($keyword eq 'resource' && $process_file) {

			($type, $name, $language, $dest_file)

			  = ($param =~ /^([^,]*?)\s*(?:,\s*([^,]*))?\s*(?:,\s*([^,]*))?\s*:\s*(.*)$/);

			# check for missing items

			next if &check_missing($file, $keyword, $type);

			next if &check_missing($file, $keyword, $name);

			next if &check_missing($file, $keyword, $dest_file);

			# if interactive

			if (!$always_process_resource) {

				if ($process_file == 2) {

					print "line ${.}: $keyword $param\n";

					my $res = &ask_interaction("Process resource type `$type' name `$name'", 'yn');

					$always_process_resource = 1 if (lc $res ne $res);

					$process_resource = 0 if (lc $res eq 'n');

					$process_resource = 1 if (lc $res eq 'y');

				} else {

					$process_resource = 1;

				}

			}

			next if !$process_resource;

			warn "Extracting $type resource $name to $dest_file\n" if $arg_verbose;

			&process_resource($current_file, $dest_file, $type, $name, $language);

		}

    # other keywords

    elsif ($keyword ne '') {

    	warn "$file: invalid keyword `$keyword' in line $.\n";

    }

	}

	# finally, close it

	close(FH);

}

sub process_resource {

	my ($resfile, $destfile, $type, $name, $language) = @_;

	# make w32rtool extraction parameters

	my ($cmd);

	$cmd = "-t$type -n$name";

	$cmd .= " -L$language" if (defined $language && $language ne '');

	$cmd = "$path_w32rtool ".&quoteshell($resfile). " -x $cmd";

	# make icotool extraction parameters

	my ($out);

	$out = &quoteshell($destfile);

	$out = File::Spec->catdir($arg_output, $out) if (defined $arg_output && $arg_output ne '');

	&make_directories(File::Basename::dirname($out));

	if (&is_icotool_type($type)) {

		$cmd .= " | $path_icotool -x -o " . $out . " -";

	} else {

		$cmd .= " -o$out";

	}

	# execute the command

#	print $cmd, "\n" if ($arg_verbose);

	system $cmd;

	return $path_icotool;

}

sub is_icotool_type {

	my ($type) = @_;

	$type = lc $type;

	return TRUE if (substr($type,0,1) eq '+' &&

		(substr($type,1) eq 'group_icon' || substr($type,1) eq 'group_cursor'));

	return TRUE if (substr($type,0,1) eq '-' &&

		(substr($type,1) == 12 || substr($type,1) == 14));

	return TRUE if ($type eq 'group_icon' || $type eq 'group_cursor'

		|| $type == 12 || $type == 14);

	return FALSE;

}

sub check_missing {

	my ($file, $keyword, $var) = @_;

	if (!defined $var || $var eq '') {

		warn "$file: missing parameter in `$keyword' statement in line ${.}.\n";

		return 1;

	}

	return 0;

}

# quote shell characters

sub quoteshell {

	my ($str) = @_;

	$str =~ s/([^-\w_.\/])/\\$1/g;

	return $str;

}

sub ask_interaction {

	my ($msg, $ch) = @_;

	# lowercase choices and put '/' between characters

	$ch = lc $ch;

	$ch =~ s/(.)(?=.)/$1\//g;

	my $in;

	do {

		$in = $obj_term->readline($msg . " ($ch)? ");

	} while (length($in) != 1 || $in eq '/' || index($ch,lc $in) == -1);

	return $in;

}

sub make_directories {

	my (@comp) = split(/\//, $_[0]);

	my ($check) = undef;

	foreach my $dir (@comp) {

		$check = File::Spec->catdir($check, $dir) if (defined $check);

		$check = $dir if (!defined $check);

		mkdir($check, 0777) if (!-e $check);

	}

}

sub fetch_file {

	my ($file) = @_;

	# if file is local, return it

	return $file if (-e $file);

	# try with --base argument 

  if (defined $arg_base) {

		my $tfile = File::Spec->catfile($arg_base, $file);

		return $tfile if (-e $tfile);

	}

	# absolutely not a file address

	return $file if (substr($file, 0, 1) eq '/');

	# get remote file

	print STDERR "Getting `$file'... ";

	my $rc = LWP::Simple::mirror($file, $path_tmpfile);

	if ($rc != RC_OK) {

		warn "failed!\n";

		warn "$file: " . HTTP::Status::status_message($rc) . "\n";

		return undef;

	}

	warn "done.\n";

	$tmpfile_exists = 1;

	return $path_tmpfile;

}

sub extract_file {

	my ($file, $archive) = @_;

	return "blah";

}

sub path_or {

	my ($cmd,$def) = @_;

	my $real = `which $cmd`;

  return $def if !defined $real;

  chop $real;

  return $def if ($real eq '');

	return $real;

}

sub END {

  unlink $path_tmpfile if $tmpfile_exists;

}