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 ".&quoteshell($resfile). " -x $cmd";
215
216	# make icotool extraction parameters
217	my ($out);
218	$out = &quoteshell($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