#!/usr/local/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 = )) { # 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; }