icoutils 0.31.0-2+deb8u3 / usr / bin / extresso

#! /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 <frank.richter@gmail.com>', "\n";
	exit;
}
if ($arg_version) {
	print "$PROGRAM (icoutils) 0.31.0\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;
}