1#!/usr/local/bin/perl -w 2# 3# extresso - Extract and convert resources using resource scripts 4# 5# Copyright (C) 1998-2005 Oskar Liljeblad 6# 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 2 of the License, or 10# (at your option) any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# You should have received a copy of the GNU General Public License 18# along with this program; if not, write to the Free Software Foundation, 19# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 20# 21 22use Getopt::Long; 23use File::Spec; 24use File::Basename; 25use Term::ReadLine; 26use LWP::Simple; 27use HTTP::Status; 28 29# global stuff 30$PROGRAM = 'extresso'; 31 32$path_icotool = &path_or('icotool','../icotool/icotool'); 33$path_w32rtool = &path_or('wrestool','../wrestool/wrestool'); 34$path_tmpfile = 'extresso.fetch.tmp'; 35$tmpfile_exists = 0; 36 37# initialize options 38$arg_output = '.'; 39$arg_format = undef; 40$arg_base = undef; 41$arg_match = undef; 42$arg_interactive = 0; 43$arg_verbose = 0; 44$arg_help = $arg_version = 0; 45 46# get options 47exit 1 if (!GetOptions("o|output=s" => \$arg_output, 48 "format=s" => \$arg_format, 49 "b|base=s" => \$arg_base, 50 "m|match=s" => \$arg_match, 51 "i|interactive" => \$arg_interactive, 52 "v|verbose" => \$arg_verbose, 53 "help" => \$arg_help, 54 "version" => \$arg_version)); 55 56# deal with standard options 57if ($arg_help) { 58 print "Usage: extresso [OPTION]... [FILE]...\n"; 59 print "Extract and convert resources using resource scripts.\n"; 60 print "\n"; 61 print " -o, --output=DIR where to place extracted files (default `.')\n"; 62 print " --format=FORMAT extraction format of icon resources (see icotool)\n"; 63 print " -b, --base=DIR base directory of local files in scripts\n"; 64# print " -m, --match=REGEXP extract only from binaries whose name match this\n"; 65 print " -i, --interactive prompt before extraction\n"; 66 print " -v, --verbose explain what is being done\n"; 67 print " --help display this help and exit\n"; 68 print " --version output version information and exit\n"; 69 print "\n"; 70 print 'Report bugs to <@PACKAGE_BUGREPORT@>', "\n"; 71 exit; 72} 73if ($arg_version) { 74 print "$PROGRAM (@PACKAGE@) @VERSION@\n"; 75 print "Written by Oskar Liljeblad.\n\n"; 76 print "Copyright (C) 1998-2005 Oskar Liljeblad.\n"; 77 print "This is free software; see the source for copying conditions. There is NO\n"; 78 print "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n"; 79 exit; 80} 81 82# got no arguments? 83if ($#ARGV == -1) { 84 print STDERR "$PROGRAM: missing file argument\n"; 85 print STDERR "Try `$PROGRAM --help' for more information.\n" 86} 87 88# initialize objects if necessary 89$obj_term = new Term::ReadLine 'extresso' if ($arg_interactive); 90 91# process each non-option argument 92for ($c = 0 ; $c <= $#ARGV ; $c++) { 93 print STDERR "Processing $ARGV[$c]\n" if $arg_verbose; 94 &process_script($ARGV[$c]); 95} 96 97# 98# Subroutines 99# 100sub process_script { 101 my ($file) = @_; 102 103 # open the file 104 die "$PROGRAM: $file: $!\n" if (!open(FH, $file)); 105 106 # variable initializations 107 my ($line, $keyword, $param); 108 109 my ($current_file) = undef; # name of current resource achive 110 my ($process_file) = 1; # how to process resource archives 111 my ($always_process_file) = undef; # true if process_file should not be changed 112 my ($process_resource) = 1; # how to process a resource 113 my ($always_process_resource) = undef; # true if process_resource should not be changed 114 115 # read each line 116 while (defined ($line = <FH>)) { 117 # strip leading and trailing whitespace 118 $line =~ s/^\s*(\S?.*?\S?)\s*$/$1/; 119 120 # skip empty lines and comments 121 next if ($line eq '' || $line =~ /^#/); 122 123 # split line into keyword and parameters 124 ($keyword,$param) = ($line =~ /^(\S*)\s*(.*)?$/); 125 next if (!defined $keyword || $keyword eq ''); 126 127 # check parameter 128 next if &check_missing($file, $keyword, $param); 129 130 # version keyword 131 if ($keyword eq 'version') { 132 if ($param > 1) { 133 warn "$file: resource script version `$param' not supported\n"; 134 return; 135 } 136 } 137 # archive keyword 138 elsif ($keyword eq 'file') { 139 $current_file = $param; 140 141 # if interactive, ask if we are to process this archive 142 if (!$always_process_file) { 143 if ($arg_interactive) { 144 print "line ${.}: $keyword $param\n"; 145 my $res = &ask_interaction("Process resources in `$param'", 'yin'); 146 $always_process_file = 1 if (lc $res ne $res); 147 $process_file = 0 if (lc $res eq 'n'); 148 $process_file = 1 if (lc $res eq 'y'); 149 $process_file = 2 if (lc $res eq 'i'); 150 } else { 151 $process_file = 1; 152 } 153 } 154 155 # get the file (local or remote) 156 if ($tmpfile_exists) { 157 unlink $path_tmpfile; 158 $tmpfile_exists = 0; 159 } 160 $current_file = &fetch_file($current_file); 161 return if (!defined $current_file); 162 163 # check if the file actually exists 164 if (!-e $current_file) { 165 warn "$current_file: No such file or directory\n"; 166 return; 167 } 168 } 169 # resource keyword 170 elsif ($keyword eq 'resource' && $process_file) { 171 ($type, $name, $language, $dest_file) 172 = ($param =~ /^([^,]*?)\s*(?:,\s*([^,]*))?\s*(?:,\s*([^,]*))?\s*:\s*(.*)$/); 173 174 # check for missing items 175 next if &check_missing($file, $keyword, $type); 176 next if &check_missing($file, $keyword, $name); 177 next if &check_missing($file, $keyword, $dest_file); 178 179 # if interactive 180 if (!$always_process_resource) { 181 if ($process_file == 2) { 182 print "line ${.}: $keyword $param\n"; 183 my $res = &ask_interaction("Process resource type `$type' name `$name'", 'yn'); 184 $always_process_resource = 1 if (lc $res ne $res); 185 $process_resource = 0 if (lc $res eq 'n'); 186 $process_resource = 1 if (lc $res eq 'y'); 187 } else { 188 $process_resource = 1; 189 } 190 } 191 next if !$process_resource; 192 193 warn "Extracting $type resource $name to $dest_file\n" if $arg_verbose; 194 195 &process_resource($current_file, $dest_file, $type, $name, $language); 196 } 197 # other keywords 198 elsif ($keyword ne '') { 199 warn "$file: invalid keyword `$keyword' in line $.\n"; 200 } 201 } 202 203 # finally, close it 204 close(FH); 205} 206 207sub process_resource { 208 my ($resfile, $destfile, $type, $name, $language) = @_; 209 210 # make w32rtool extraction parameters 211 my ($cmd); 212 $cmd = "-t$type -n$name"; 213 $cmd .= " -L$language" if (defined $language && $language ne ''); 214 $cmd = "$path_w32rtool "."eshell($resfile). " -x $cmd"; 215 216 # make icotool extraction parameters 217 my ($out); 218 $out = "eshell($destfile); 219 $out = File::Spec->catdir($arg_output, $out) if (defined $arg_output && $arg_output ne ''); 220 &make_directories(File::Basename::dirname($out)); 221 222 if (&is_icotool_type($type)) { 223 $cmd .= " | $path_icotool -x -o " . $out . " -"; 224 } else { 225 $cmd .= " -o$out"; 226 } 227 228 # execute the command 229# print $cmd, "\n" if ($arg_verbose); 230 system $cmd; 231 232 return $path_icotool; 233} 234 235sub is_icotool_type { 236 my ($type) = @_; 237 238 $type = lc $type; 239 return TRUE if (substr($type,0,1) eq '+' && 240 (substr($type,1) eq 'group_icon' || substr($type,1) eq 'group_cursor')); 241 242 return TRUE if (substr($type,0,1) eq '-' && 243 (substr($type,1) == 12 || substr($type,1) == 14)); 244 245 return TRUE if ($type eq 'group_icon' || $type eq 'group_cursor' 246 || $type == 12 || $type == 14); 247 248 return FALSE; 249} 250 251sub check_missing { 252 my ($file, $keyword, $var) = @_; 253 254 if (!defined $var || $var eq '') { 255 warn "$file: missing parameter in `$keyword' statement in line ${.}.\n"; 256 return 1; 257 } 258 259 return 0; 260} 261 262# quote shell characters 263sub quoteshell { 264 my ($str) = @_; 265 $str =~ s/([^-\w_.\/])/\\$1/g; 266 return $str; 267} 268 269sub ask_interaction { 270 my ($msg, $ch) = @_; 271 272 # lowercase choices and put '/' between characters 273 $ch = lc $ch; 274 $ch =~ s/(.)(?=.)/$1\//g; 275 276 my $in; 277 do { 278 $in = $obj_term->readline($msg . " ($ch)? "); 279 } while (length($in) != 1 || $in eq '/' || index($ch,lc $in) == -1); 280 281 return $in; 282} 283 284sub make_directories { 285 my (@comp) = split(/\//, $_[0]); 286 287 my ($check) = undef; 288 foreach my $dir (@comp) { 289 $check = File::Spec->catdir($check, $dir) if (defined $check); 290 $check = $dir if (!defined $check); 291 mkdir($check, 0777) if (!-e $check); 292 } 293} 294 295sub fetch_file { 296 my ($file) = @_; 297 298 # if file is local, return it 299 return $file if (-e $file); 300 301 # try with --base argument 302 if (defined $arg_base) { 303 my $tfile = File::Spec->catfile($arg_base, $file); 304 return $tfile if (-e $tfile); 305 } 306 307 # absolutely not a file address 308 return $file if (substr($file, 0, 1) eq '/'); 309 310 # get remote file 311 print STDERR "Getting `$file'... "; 312 my $rc = LWP::Simple::mirror($file, $path_tmpfile); 313 if ($rc != RC_OK) { 314 warn "failed!\n"; 315 warn "$file: " . HTTP::Status::status_message($rc) . "\n"; 316 return undef; 317 } 318 319 warn "done.\n"; 320 $tmpfile_exists = 1; 321 return $path_tmpfile; 322} 323 324sub extract_file { 325 my ($file, $archive) = @_; 326 327 return "blah"; 328} 329 330sub path_or { 331 my ($cmd,$def) = @_; 332 333 my $real = `which $cmd`; 334 return $def if !defined $real; 335 chop $real; 336 return $def if ($real eq ''); 337 338 return $real; 339} 340 341sub END { 342 unlink $path_tmpfile if $tmpfile_exists; 343} 344