#! /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 "."eshell($resfile). " -x $cmd";
# make icotool extraction parameters
my ($out);
$out = "eshell($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;
}