« back to all changes in this revision
Viewing changes to .pc/03-zip_file_recognition.patch/atool
- browse files at revision 13
- compare with another revision
- download diff
- download tarball
- view history from revision 13
- Committer: Bazaar Package Importer
- Author(s): Francois Marier
- Date: 2011-08-17 07:51:06 UTC
- mfrom: (1.1.6 upstream)
- Revision ID: james.westby@ubuntu.com-20110817075106-8gd3c7fczf342nif
Tags: 0.38.0-1
* New upstream release:
- remove all Debian patches (they have been applied upstream)
* Add empty build-arch and build-indep targets in debian/rules
- remove all Debian patches (they have been applied upstream)
* Add empty build-arch and build-indep targets in debian/rules
- files removed:
- .pc
- .pc/01-manpage_typos.patch
- .pc/02-manpage_hyphen.patch
- .pc/03-zip_file_recognition.patch
- .pc/04-7zip_detection.patch
- debian/patches
- files modified:
- COPYING
added
removed
.pc/03-zip_file_recognition.patch/atool
1
#!/usr/bin/perl -w
2
#
3
# atool - A script for managing file archives of various types.
4
#
5
# Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008,
6
# 2009 Oskar Liljeblad
7
#
8
# This program is free software; you can redistribute it and/or modify
9
# it under the terms of the GNU General Public License as published by
10
# the Free Software Foundation; either version 2 of the License, or
11
# (at your option) any later version.
12
#
13
# This program is distributed in the hope that it will be useful,
14
# but WITHOUT ANY WARRANTY; without even the implied warranty of
15
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
# GNU General Public License for more details.
17
#
18
# You should have received a copy of the GNU General Public License along
19
# with this program; if not, write to the Free Software Foundation,
20
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
21
#
22
# See the atool(1) manual page for usage details.
23
#
24
# This file uses tab stops with a length of two.
25
#
26
27
# XXX: We could use -CLSDA but 5.10.0 has a bug which prevents us from
28
# specifying this with shebang. Thanks to some helpful dude on #perl
29
# FreeNode.
30
if (${^UTF8LOCALE}) {
31
use Encode qw(decode_utf8);
32
binmode($_, ':encoding(UTF-8)') for \*STDIN, \*STDOUT, \*STDERR;
33
$_ = decode_utf8($_) for @ARGV, values %ENV;
34
}
35
36
use File::Basename;
37
use File::Spec;
38
use Getopt::Long;
39
use POSIX;
40
use locale;
41
use strict;
42
43
# Subroutine prototypes (needed for perl 5.6)
44
sub runcmds($$$;@);
45
sub getmode();
46
sub multiarchivecmd($$$$@);
47
sub singlearchivecmd($$$$$@);
48
sub maketarcmd($$$$@);
49
sub cmdexec($@);
50
sub parsefmt($$);
51
sub makeoutdir();
52
sub makeoutfile($);
53
sub explain($);
54
sub extract(@);
55
sub shquotemeta($);
56
sub tailslash($);
57
sub de($);
58
sub makespec(@);
59
sub backticks(@);
60
sub readconfig($$);
61
sub formatext($);
62
sub stripext($);
63
sub findformat($$);
64
sub unlink_directory($);
65
sub find_comparable_file($);
66
sub makeabsolute($);
67
sub quote($);
68
sub shell_execute(@);
69
sub save_outdir($);
70
sub handle_empty_add(@);
71
sub issingleformat($);
72
sub repack_archive($$$$);
73
sub set_config_option($$$);
74
75
$::SYSCONFDIR = '/usr/local/etc'; # This line is automatically updated by make
76
$::PACKAGE = 'atool'; # This line is automatically updated by make
77
$::VERSION = '0.37.0'; # This line is automatically updated by make
78
$::BUG_EMAIL = 'oskar@osk.mine.nu'; # This line is automatically updated by make
79
$::PROGRAM = $::PACKAGE;
80
81
# Configuration options and their built-in defaults
82
$::cfg_args_diff = '-ru'; # arguments to pass to diff program
83
$::cfg_decompress_to_cwd = 1; # decompress to current directory
84
$::cfg_default_verbosity = 1; # default verbosity level
85
$::cfg_extract_deb_control = 1; # extract DEBIAN control dir from .deb packages?
86
$::cfg_keep_compressed = 1; # keep compressed file after pack/unpack
87
$::cfg_path_7z = '7z'; # 7z program
88
$::cfg_path_ar = 'ar'; # ar program
89
$::cfg_path_arc = 'arc'; # arc program
90
$::cfg_path_arj = 'arj'; # arj program
91
$::cfg_path_bzip = 'bzip'; # bzip program
92
$::cfg_path_bzip2 = 'bzip2'; # bzip2 program
93
$::cfg_path_cabextract = 'cabextract'; # cabextract program
94
$::cfg_path_cat = 'cat'; # cat program
95
$::cfg_path_compress = 'compress'; # compress program
96
$::cfg_path_cpio = 'cpio'; # cpio program
97
$::cfg_path_diff = 'diff'; # diff program
98
$::cfg_path_dpkg_deb = 'dpkg-deb'; # dpkg-deb program
99
$::cfg_path_file = 'file'; # file program
100
$::cfg_path_find = 'find'; # find program
101
$::cfg_path_gzip = 'gzip'; # gzip program
102
$::cfg_path_jar = 'jar'; # jar program
103
$::cfg_path_lha = 'lha'; # lha program
104
$::cfg_path_lrzip = 'lrzip'; # lrzip program
105
$::cfg_path_lzip = 'lzip'; # lzip program
106
$::cfg_path_lzma = 'lzma'; # lzma program
107
$::cfg_path_lzop = 'lzop'; # lzop program
108
$::cfg_path_nomarch = 'nomarch'; # nomarch program
109
$::cfg_path_pager = 'pager'; # pager program
110
$::cfg_path_pbzip2 = 'pbzip2'; # pbzip2 program
111
$::cfg_path_rar = 'rar'; # rar program
112
$::cfg_path_rpm = 'rpm'; # rpm program
113
$::cfg_path_rpm2cpio = 'rpm2cpio'; # rpm2cpio program
114
$::cfg_path_rzip = 'rzip'; # rzip program
115
$::cfg_path_syscfg = File::Spec->catfile($::SYSCONFDIR, $::PROGRAM.'.conf'); # system-wide configuration file
116
$::cfg_path_tar = 'tar'; # tar program
117
$::cfg_path_unace = 'unace'; # unace program
118
$::cfg_path_unalz = 'unalz'; # unalz program
119
$::cfg_path_unarj = 'unarj'; # unarj program
120
$::cfg_path_unrar = 'unrar'; # unrar program
121
$::cfg_path_unzip = 'unzip'; # unzip program
122
$::cfg_path_usercfg = '.'.$::PROGRAM.'rc'; # user configuration file
123
$::cfg_path_xargs = 'xargs'; # xargs program
124
$::cfg_path_xz = 'xz'; # xz program
125
$::cfg_path_zip = 'zip'; # zip program
126
$::cfg_show_extracted = 1; # always show extracted file/directory
127
$::cfg_strip_unknown_ext = 1; # strip unknown extensions
128
$::cfg_tmpdir_name = 'Unpack-%04d'; # extraction directory name
129
$::cfg_tmpfile_name = 'Pack-%04d'; # temporary file used during packing
130
$::cfg_use_arc_for_unpack = 0; # use arc to unpack arc files?
131
$::cfg_use_arj_for_unpack = 0; # use arj to unpack arj files?
132
$::cfg_use_file = 1; # use file(1) for unknown extensions?
133
$::cfg_use_file_always = 0; # always use file to identify archives (ignore extension)
134
$::cfg_use_find_cpio_print0 = 1; # use -print0/-0 find/cpio options?
135
$::cfg_use_gzip_for_z = 1; # use gzip to decompress .Z files?
136
$::cfg_use_jar = 0; # use jar or zip for .jar archives?
137
$::cfg_use_pbzip2 = 0; # use pbzip2 instead of bzip2
138
$::cfg_use_rar_for_unpack = 0; # use rar to unpack rar files?
139
$::cfg_use_tar_bzip2_option = 1; # does tar support --bzip2?
140
$::cfg_use_tar_lzma_option = 1; # does tar support --lzma?
141
$::cfg_use_tar_lzop_option = 0; # does tar support --lzop?
142
$::cfg_use_tar_xv_option = 0; # does tar support --xv?
143
$::cfg_use_tar_z_option = 1; # does tar support -z?
144
145
# Global variables
146
$::basename = quote(File::Basename::basename($0));
147
@::rmdirs = ();
148
$::up = File::Spec->updir();
149
$::cur = File::Spec->curdir();
150
@::opt_options = ();
151
152
# Parse arguments
153
Getopt::Long::config('bundling');
154
Getopt::Long::GetOptions(
155
'l|list' => \$::opt_cmd_list,
156
'x|extract' => \$::opt_cmd_extract,
157
'X|extract-to=s' => \$::opt_cmd_extract_to,
158
'a|add' => \$::opt_cmd_add,
159
'c|cat' => \$::opt_cmd_cat,
160
'd|diff' => \$::opt_cmd_diff,
161
'r|repack' => \$::opt_cmd_repack,
162
'q|quiet' => sub { $::opt_verbosity--; },
163
'v|verbose' => sub { $::opt_verbosity++; },
164
'V|verbosity=i' => \$::opt_verbosity,
165
'config=s' => \$::opt_config,
166
'o|option=s' => sub { push @::opt_options, $_[1] },
167
'help' => \$::opt_cmd_help,
168
'version' => \$::opt_cmd_version,
169
'F|format=s' => \$::opt_format,
170
'f|force' => \$::opt_force,
171
'p|page' => \$::opt_use_pager,
172
'e|each' => \$::opt_each,
173
'E|explain' => \$::opt_explain,
174
'S|simulate' => \$::opt_simulate,
175
'save-outdir=s' => \$::opt_save_outdir,
176
'D|subdir' => \$::opt_extract_subdir,
177
'0|null' => \$::opt_null,
178
) or exit 1;
179
180
# Display --version
181
if ($::opt_cmd_version) {
182
print $::PACKAGE.' '.$::VERSION."\
183
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008 Oskar Liljeblad\
184
This is free software. You may redistribute copies of it under the terms of
185
the GNU General Public License <http://www.gnu.org/licenses/gpl.html>.
186
There is NO WARRANTY, to the extent permitted by law.
187
188
Written by Oskar Liljeblad.\n";
189
exit;
190
}
191
192
# Display --help
193
if ($::opt_cmd_help) {
194
print "Usage: $::PROGRAM [OPTION]... ARCHIVE [FILE]...\n";
195
print " $::PROGRAM -e [OPTION]... [ARCHIVE]...\n";
196
print "Manage file archives of various types.\
197
\
198
Commands:\
199
-l, --list list files in archive (als)\
200
-x, --extract extract files from archive (aunpack)\
201
-X, --extract-to=PATH extract archive to specified directory\
202
-a, --add create archive (apack)\
203
-c, --cat extract file to standard out (acat)\
204
-d, --diff generate a diff between two archives (adiff)\
205
-r, --repack repack archives to a different format (arepack)\
206
--help display this help and exit\
207
--version output version information and exit\
208
\
209
Options:\
210
-e, --each execute command above for each file specified
211
-F, --format=EXT override archive format (see below)\
212
-D, --subdir always create subdirectory when extracting\
213
-f, --force allow overwriting of local files\
214
-q, --quiet decrease verbosity level by one\
215
-v, --verbose increase verbosity level by one\
216
-V, --verbosity=LEVEL specify verbosity (0, 1 or 2)\
217
-p, --page send output through pager\
218
-0, --null filenames from standard in are null-byte separated\
219
-E, --explain explain what is being done by ".$::PROGRAM."\
220
-S, --simulate simulation mode - no filesystem changes are made\
221
-o, --option=KEY=VALUE override a configuration option\
222
--config=FILE load configuration defaults from file\
223
\
224
Archive format (for --format) may be specified either as a\
225
file extension (\"tar.gz\") or as \"tar+gzip\".\
226
\
227
Report bugs to Oskar Liljeblad <".$::BUG_EMAIL.">.\
228
";
229
exit;
230
}
231
232
# Read configuration files
233
if (defined $::opt_config) {
234
readconfig($::opt_config, 0);
235
} else {
236
readconfig($::cfg_path_syscfg, 1);
237
if ($::cfg_path_usercfg !~ /^\//) {
238
readconfig(File::Spec->catfile($ENV{HOME}, $::cfg_path_usercfg), 1);
239
} else {
240
readconfig($::cfg_path_usercfg, 1);
241
}
242
}
243
foreach my $opt (@::opt_options) {
244
my ($var,$val) = ($opt =~ /^([^=]+)=(.*)$/);
245
die "$::basename: invalid value for --option: $opt\n" if !defined $val;
246
set_config_option($var, $val, '');
247
}
248
249
# Verify option integrity
250
$::opt_verbosity += $::cfg_default_verbosity;
251
if ($::opt_explain && $::opt_simulate) {
252
die "$::basename: --explain and --simulate options are mutually exclusive\n"; #OK
253
}
254
255
my $mode = getmode();
256
257
if (defined $::opt_save_outdir && $mode eq 'extract-to') {
258
die "$::basename: --save-outdir cannot be used in extract-to mode\n";
259
}
260
if ($::opt_extract_subdir && $mode ne 'extract') {
261
die "$::basename: --subdir can only be used in extract mode\n";
262
}
263
264
if ($mode eq 'diff') {
265
die "$::basename: missing archive argument\n" if (@ARGV < 2); #OK
266
my $use_pager = $::opt_use_pager;
267
$::opt_verbosity--;
268
$::opt_use_pager = 0;
269
270
my $outfile1 = makeoutdir() || exit 1;
271
my $outfile2 = makeoutdir() || exit 1;
272
$::opt_cmd_extract_to = $outfile1;
273
$::opt_cmd_extract_to_type = 'f';
274
exit 1 if (!runcmds('extract-to', undef, $ARGV[0]));
275
$::opt_cmd_extract_to = $outfile2;
276
$::opt_cmd_extract_to_type = 'f';
277
exit 1 if (!runcmds('extract-to', undef, $ARGV[1]));
278
279
my $match1 = find_comparable_file($outfile1);
280
my $match2 = find_comparable_file($outfile2);
281
282
my @cmd = ($::cfg_path_diff, split(/ /, $::cfg_args_diff), $match1, $match2);
283
push @cmd, ['|'], get_pager_program() if $use_pager;
284
my $allok = cmdexec(1, @cmd);
285
286
foreach my $file ($outfile1,$outfile2) {
287
warn 'rm -r ',quote($file),"\n" if $::opt_simulate;
288
if (-e $file && -d $file) {
289
#if (-e $file) {
290
#print "$::basename: remove `$file'? ";
291
#select((select(STDOUT), $| = 1)[0]);
292
#my $line = <STDIN>;
293
#if (defined $line && $line =~ /^y/) {
294
#if (-d $file) {
295
warn 'rm -r ',quote($file),"\n" if $::opt_explain;
296
unlink_directory($file) if !$::opt_simulate;
297
#} else {
298
#unlink $file;
299
#}
300
#}
301
}
302
}
303
304
exit ($allok ? 0 : 1);
305
}
306
elsif ($mode eq 'repack') {
307
if ($::opt_each) {
308
my $totaldiff = 0;
309
if (!defined $::opt_format) {
310
die "$::basename: specify a format with -F when using --each in repack mode\n";
311
}
312
my $fmt2 = findformat($::opt_format, 1);
313
for (my $c = 0; $c < @ARGV; $c++) {
314
my $fmt1 = findformat($ARGV[$c], 0);
315
if (!issingleformat($fmt1) && issingleformat($fmt2)) {
316
warn "$::basename: format $fmt1 is cannot be repacked into format $fmt2\n";
317
warn "skipping ", quote($ARGV[$c]), "\n";
318
next;
319
}
320
if ($fmt1 eq $fmt2) {
321
warn "$::basename: will not repack to same archive type\n";
322
warn "skipping ", quote($ARGV[$c]), "\n";
323
next;
324
}
325
my $newname = stripext($ARGV[$c]).formatext($fmt2);
326
if (-e $newname) {
327
warn "$::basename: ".quote($newname).": destination file exists\n";
328
warn "skipping ", quote($ARGV[$c]), "\n";
329
next;
330
}
331
repack_archive($ARGV[$c], $newname, $fmt1, $fmt2);
332
my $diff = ($::opt_simulate ? 0 : -s $ARGV[$c] - -s $newname);
333
$totaldiff += $diff;
334
if ($::opt_verbosity >= 1) {
335
print quote($newname), ': ',
336
($diff >= 0 ? 'saved '.$diff : 'grew '.-$diff),' ',
337
($diff == 1 ? 'byte':'bytes'), "\n";
338
}
339
}
340
if ($::opt_verbosity >= 1) {
341
print $totaldiff >= 0 ? 'saved '.$totaldiff : 'grew '.-$totaldiff, ' ',
342
$totaldiff == 1 ? 'byte':'bytes', " in total\n";
343
}
344
} else {
345
die "$::basename: missing archive arguments\n" if (@ARGV < 1); #OK
346
die "$::basename: missing archive argument\n" if (@ARGV < 2); #OK
347
die "$::basename: will not repack to same archive file\n"
348
if ($ARGV[0] eq $ARGV[1] || File::Spec->canonpath($ARGV[0]) eq File::Spec->canonpath($ARGV[1]));
349
die "$::basename: ".quote($ARGV[1]).": destination file exists\n" if -e $ARGV[1];
350
my $fmt1 = findformat($ARGV[0], 0);
351
my $fmt2 = findformat($ARGV[1], 0);
352
die "$::basename: format $fmt1 is cannot be repacked into format $fmt1\n"
353
if (!issingleformat($fmt1) && issingleformat($fmt2));
354
die "$::basename: will not repack to same archive type\n" if $fmt1 eq $fmt2;
355
repack_archive($ARGV[0], $ARGV[1], $fmt1, $fmt2);
356
my $diff = ($::opt_simulate ? 0 : (-s $ARGV[0]) - (-s $ARGV[1]));
357
if ($::opt_verbosity >= 1) {
358
print quote($ARGV[1]), ': ',
359
($diff >= 0 ? 'saved '.$diff : 'grew '.-$diff),' ',
360
($diff == 1 ? 'byte':'bytes'), "\n";
361
}
362
}
363
}
364
elsif ($::opt_each) {
365
my $allok = 1;
366
if ($mode eq 'cat') {
367
die "$::basename: --each can not be used with cat or add command\n"; #OK
368
}
369
if ($mode eq 'add') {
370
if (!defined $::opt_format) {
371
die "$::basename: specify a format with -F when using --each in add mode\n";
372
}
373
my $format = findformat($::opt_format, 1);
374
for (my $c = 0; $c < @ARGV; $c++) {
375
my $archive = File::Spec->canonpath($ARGV[$c]) . formatext($format);
376
warn quote($archive).":\n" if $::opt_verbosity > 1;
377
runcmds('add', $format, $archive, $ARGV[$c]) or $allok = 0;
378
}
379
} else {
380
for (my $c = 0; $c < @ARGV; $c++) {
381
warn quote($ARGV[$c]).":\n" if $::opt_verbosity > 1;
382
runcmds($mode, undef, $ARGV[$c]) or $allok = 0;
383
}
384
}
385
exit ($allok ? 0 : 1);
386
}
387
else {
388
die "$::basename: missing archive argument\n" if (@ARGV == 0); #OK
389
runcmds($mode, undef, shift @ARGV, @ARGV) || exit 1;
390
}
391
392
# runcmds(mode, format, archive, args)
393
# Execute an atool command. This is where it all happens.
394
# If mode is 'extract', returns the directory (or only file)
395
# which was extracted.
396
# If forceformat is undef, the format will be detected from
397
# $::opt_format or the filename.
398
sub runcmds($$$;@) {
399
my ($mode, $format, $archive, @args) = @_;
400
401
if (!defined $format) {
402
if (defined $::opt_format) {
403
$format = findformat($::opt_format, 1);
404
} else {
405
$format = findformat($archive, 0);
406
}
407
return undef if !defined $format;
408
}
409
410
my @cmd;
411
my $outdir;
412
if ($format eq 'tar+bzip2') {
413
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
414
if ($::cfg_use_tar_bzip2_option) {
415
push @cmd, maketarcmd($archive, $outdir, $mode, 'f', '--bzip2'), @args;
416
} elsif ($::cfg_use_pbzip2) {
417
if ($mode eq 'add') {
418
# Unfortunately pbzip2 cannot read from standard in
419
my $tmpname = makeoutfile($::cfg_tmpfile_name);
420
push @cmd, maketarcmd($tmpname, $outdir, $mode, 'f'), @args;
421
push @cmd, [';'], $::cfg_path_pbzip2, '-c', $tmpname, ['>'], $archive;
422
push @cmd, [';'], 'rm', $tmpname;
423
} else {
424
push @cmd, $::cfg_path_pbzip2, '-cd', $archive, ['|'];
425
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
426
}
427
} else {
428
push @cmd, $::cfg_path_bzip2, '-cd', $archive, ['|'] if $mode ne 'add';
429
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
430
push @cmd, ['|'], $::cfg_path_bzip2, '-c', ['>'], $archive if $mode eq 'add';
431
}
432
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
433
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
434
}
435
elsif ($format eq 'tar+gzip') {
436
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
437
if ($::cfg_use_tar_z_option) {
438
push @cmd, maketarcmd($archive, $outdir, $mode, 'zf'), @args;
439
} else {
440
push @cmd, $::cfg_path_gzip, '-cd', $archive, ['|'] if $mode ne 'add';
441
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
442
push @cmd, ['|'], $::cfg_path_gzip, '-c', ['>'], $archive if $mode eq 'add';
443
}
444
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
445
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
446
}
447
elsif ($format eq 'tar+bzip') {
448
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
449
push @cmd, $::cfg_path_bzip, '-cd', $archive, ['|'] if $mode ne 'add';
450
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
451
push @cmd, ['|'], $::cfg_path_bzip, '-c', ['>'], $archive if $mode eq 'add';
452
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
453
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
454
}
455
elsif ($format eq 'tar+compress') {
456
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
457
if ($::cfg_use_gzip_for_z) {
458
push @cmd, $::cfg_path_gzip, '-cd', $archive, ['|'] if $mode ne 'add';
459
} else {
460
push @cmd, $::cfg_path_compress, '-cd', $archive, ['|'] if $mode ne 'add';
461
}
462
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
463
push @cmd, ['|'], $::cfg_path_compress, '-c', ['>'], $archive if $mode eq 'add';
464
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
465
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
466
}
467
elsif ($format eq 'tar+lzop') {
468
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
469
if ($::cfg_use_tar_lzop_option) {
470
push @cmd, maketarcmd($archive, $outdir, $mode, 'f', '--lzop'), @args;
471
} else {
472
push @cmd, $::cfg_path_lzop, '-cd', $archive, ['|'] if $mode ne 'add';
473
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
474
push @cmd, ['|'], $::cfg_path_lzop, '-c', ['>'], $archive if $mode eq 'add';
475
}
476
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
477
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
478
}
479
elsif ($format eq 'tar+lzip') {
480
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
481
push @cmd, $::cfg_path_lzip, '-cd', $archive, ['|'] if $mode ne 'add';
482
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
483
push @cmd, ['|'], $::cfg_path_lzip, '-c', ['>'], $archive if $mode eq 'add';
484
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
485
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
486
}
487
elsif ($format eq 'tar+xz') {
488
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
489
if ($::cfg_use_tar_xv_option) {
490
push @cmd, maketarcmd($archive, $outdir, $mode, 'f', '--xv'), @args;
491
} else {
492
push @cmd, $::cfg_path_xz, '-cd', $archive, ['|'] if $mode ne 'add';
493
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
494
push @cmd, ['|'], $::cfg_path_xz, '-c', ['>'], $archive if $mode eq 'add';
495
}
496
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
497
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
498
}
499
elsif ($format eq 'tar+7z') {
500
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
501
push @cmd, $::cfg_path_7z, 'x', '-so', $archive, ['|'] if $mode ne 'add';
502
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
503
push @cmd, ['|'], $::cfg_path_7z, 'a', '-si', $archive if $mode eq 'add';
504
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
505
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
506
}
507
elsif ($format eq 'tar+lzma') {
508
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
509
if ($::cfg_use_tar_lzma_option) {
510
push @cmd, maketarcmd($archive, $outdir, $mode, 'f', '--lzma'), @args;
511
} else {
512
push @cmd, $::cfg_path_lzma, '-cd', $archive, ['|'] if $mode ne 'add';
513
push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
514
push @cmd, ['|'], $::cfg_path_lzma, '-c', ['>'], $archive if $mode eq 'add';
515
}
516
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
517
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
518
}
519
elsif ($format eq 'tar') {
520
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
521
push @cmd, maketarcmd($archive, $outdir, $mode, 'f'), @args;
522
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
523
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
524
}
525
elsif ($format eq 'jar' && $::cfg_use_jar) {
526
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
527
my $opts = '';
528
if ($mode eq 'add') {
529
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
530
return undef;
531
}
532
$opts .= 'v' if $::opt_verbosity >= 1;
533
push @cmd, $::cfg_path_jar;
534
push @cmd, "x$opts", '-C', $outdir if $mode eq 'extract';
535
push @cmd, "x$opts", '-C', $::opt_cmd_extract_to if $mode eq 'extract-to';
536
push @cmd, "t$opts" if $mode eq 'list';
537
push @cmd, "c$opts" if $mode eq 'add';
538
push @cmd, $archive, @args;
539
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
540
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
541
}
542
elsif ($format eq 'jar' || $format eq 'zip') {
543
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
544
if ($mode eq 'add') {
545
push @cmd, $::cfg_path_zip, '-r';
546
} else {
547
push @cmd, $::cfg_path_unzip;
548
push @cmd, '-p' if $mode eq 'cat';
549
push @cmd, '-l' if $mode eq 'list';
550
push @cmd, '-d', $outdir if $mode eq 'extract';
551
push @cmd, '-d', $::opt_cmd_extract_to if $mode eq 'extract-to';
552
}
553
push @cmd, '-v' if $::opt_verbosity > 1;
554
push @cmd, '-qq' if $::opt_verbosity < 0;
555
push @cmd, '-q' if $::opt_verbosity == 0;
556
push @cmd, $archive, @args;
557
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
558
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
559
}
560
elsif ($format eq 'rar') {
561
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
562
if ($mode eq 'add' || $::cfg_use_rar_for_unpack) {
563
push @cmd, $::cfg_path_rar;
564
} else {
565
push @cmd, $::cfg_path_unrar;
566
}
567
push @cmd, 'a' if $mode eq 'add';
568
push @cmd, 'vt' if $mode eq 'list' && $::opt_verbosity >= 3;
569
push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity == 2;
570
push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity <= 1;
571
push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
572
push @cmd, '-ierr', 'p' if $mode eq 'cat';
573
push @cmd, '-r0' if ($mode eq 'add');
574
push @cmd, $archive, @args;
575
push @cmd, tailslash($outdir) if $mode eq 'extract';
576
push @cmd, tailslash($::opt_cmd_extract_to) if $mode eq 'extract-to';
577
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
578
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
579
}
580
elsif ($format eq '7z') {
581
# 7z has the -so option for writing data to stdout, but it doesn't
582
# write data to terminal even if the file is designed to be
583
# read in a terminal...
584
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
585
#if ($mode eq 'cat') {
586
# warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
587
# return undef;
588
#}
589
push @cmd, $::cfg_path_7z;
590
push @cmd, 'a' if $mode eq 'add';
591
push @cmd, 'l' if $mode eq 'list';
592
push @cmd, 'x', '-so' if $mode eq 'cat';
593
push @cmd, 'x', '-o'.$outdir if $mode eq 'extract';
594
push @cmd, 'x', '-o'.$::opt_cmd_extract_to if $mode eq 'extract-to';
595
push @cmd, $archive, @args;
596
return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
597
}
598
elsif ($format eq 'cab') {
599
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
600
if ($mode eq 'add') {
601
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
602
return undef;
603
}
604
push @cmd, $::cfg_path_cabextract;
605
push @cmd, '--single';
606
push @cmd, '--directory', $outdir if $mode eq 'extract';
607
push @cmd, '--directory', $::opt_cmd_extract_to if $mode eq 'extract-to';
608
push @cmd, '--pipe' if $mode eq 'cat';
609
push @cmd, '--list' if $mode eq 'list';
610
push @cmd, $archive;
611
push @cmd, '--filter';
612
push @cmd, @args;
613
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
614
}
615
elsif ($format eq 'alzip') {
616
if ($mode eq 'cat' || $mode eq 'add' || $mode eq 'list') {
617
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
618
return undef;
619
}
620
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
621
push @cmd, $::cfg_path_unalz;
622
push @cmd, $archive;
623
push @cmd, $outdir if $mode eq 'extract';
624
push @cmd, $::opt_cmd_extract_to if $mode eq 'extract-to';
625
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
626
}
627
elsif ($format eq 'lha') {
628
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
629
push @cmd, $::cfg_path_lha;
630
push @cmd, 'a' if $mode eq 'add';
631
push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity >= 3;
632
push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity == 2;
633
push @cmd, 'lq' if $mode eq 'list' && $::opt_verbosity <= 1;
634
push @cmd, 'xw='.tailslash($outdir) if $mode eq 'extract';
635
push @cmd, 'xw='.tailslash($::opt_cmd_extract_to) if $mode eq 'extract-to';
636
push @cmd, 'p' if $mode eq 'cat';
637
push @cmd, $archive, @args;
638
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
639
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
640
}
641
elsif ($format eq 'ace') {
642
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
643
push @cmd, $::cfg_path_unace;
644
if ($mode eq 'add' || $mode eq 'cat') {
645
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
646
return undef;
647
}
648
push @cmd, 'v', '-c' if $mode eq 'list' && $::opt_verbosity >= 3;
649
push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity == 2;
650
push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity <= 1;
651
push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
652
push @cmd, $archive, @args;
653
push @cmd, tailslash($outdir) if $mode eq 'extract';
654
push @cmd, tailslash($::opt_cmd_extract_to) if $mode eq 'extract-to';
655
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
656
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
657
}
658
elsif ($format eq 'arj') {
659
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
660
if ($mode eq 'cat') {
661
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
662
return undef;
663
}
664
if ($mode eq 'add' || $::cfg_use_arj_for_unpack) {
665
push @cmd, $::cfg_path_arj;
666
push @cmd, 'a' if $mode eq 'add';
667
push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity == 2;
668
push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity <= 1;
669
push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
670
push @cmd, $archive, @args;
671
push @cmd, tailslash($outdir) if $mode eq 'extract';
672
push @cmd, tailslash($::opt_cmd_extract_to) if $mode eq 'extract-to';
673
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
674
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
675
} else {
676
push @cmd, $::cfg_path_unarj;
677
# XXX: cat mode might work for arj archives, but it extract to stderr!
678
push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity == 2;
679
push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity <= 1;
680
push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
681
push @cmd, $archive if ($mode ne 'extract' && $mode ne 'extract-to');;
682
# we call makeabsolute here because needcwd=1 to the multiarchivecmd call
683
push @cmd, makeabsolute($archive) if ($mode eq 'extract' || $mode eq 'extract-to');
684
push @cmd, @args;
685
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
686
return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
687
}
688
}
689
elsif ($format eq 'arc') {
690
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
691
if ($mode eq 'add' || $::cfg_use_arc_for_unpack) {
692
push @cmd, $::cfg_path_arc;
693
push @cmd, 'a' if $mode eq 'add';
694
push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity >= 3;
695
push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity == 2;
696
push @cmd, 'ln' if $mode eq 'list' && $::opt_verbosity <= 1;
697
push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
698
push @cmd, 'p' if $mode eq 'cat';
699
} else {
700
push @cmd, $::cfg_path_nomarch;
701
push @cmd, '-lvU' if $mode eq 'list' && $::opt_verbosity >= 2;
702
push @cmd, '-lU' if $mode eq 'list' && $::opt_verbosity <= 1;
703
push @cmd, '-p' if $mode eq 'cat';
704
}
705
push @cmd, $archive if ($mode ne 'extract' && $mode ne 'extract-to');
706
# we call makeabsolute here because needcwd=1 to the multiarchivecmd call
707
push @cmd, makeabsolute($archive) if ($mode eq 'extract' || $mode eq 'extract-to');
708
push @cmd, @args;
709
@cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
710
return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
711
}
712
elsif ($format eq 'rpm') {
713
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
714
if ($mode eq 'list') {
715
push @cmd, $::cfg_path_rpm;
716
push @cmd, '-qlp';
717
push @cmd, '-v' if $::opt_verbosity >= 1;
718
push @cmd, $archive, @args;
719
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
720
}
721
elsif ($mode eq 'extract' || $mode eq 'extract-to') {
722
push @cmd, $::cfg_path_rpm2cpio;
723
push @cmd, makeabsolute($archive);
724
push @cmd, ['|'];
725
push @cmd, $::cfg_path_cpio, '-imd', '--quiet', @args;
726
return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
727
}
728
else { # add and cat
729
# FIXME: I guess cat could work too, but it would require that we
730
# extracted to a temporary dir, read and printed it, then removed it.
731
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
732
return undef;
733
}
734
}
735
elsif ($format eq 'deb') {
736
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
737
if ($mode eq 'cat') {
738
push @cmd, $::cfg_path_dpkg_deb, '--fsys-tarfile', makeabsolute($archive), ['|'];
739
push @cmd, $::cfg_path_tar, '-xO', @args;
740
} elsif ($mode eq 'list' || $mode eq 'extract' || $mode eq 'extract-to') {
741
push @cmd, $::cfg_path_dpkg_deb;
742
push @cmd, '--contents' if $mode eq 'list';
743
if ($mode eq 'extract' || $mode eq 'extract-to') {
744
push @cmd, '--extract' if $::opt_verbosity <= 0;
745
push @cmd, '--vextract' if $::opt_verbosity > 0;
746
}
747
push @cmd, $archive;
748
push @cmd, $outdir if $mode eq 'extract';
749
push @cmd, $::opt_cmd_extract_to if $mode eq 'extract-to';
750
push @cmd, @args;
751
if ($::cfg_extract_deb_control && ($mode eq 'extract' || $mode eq 'extract-to')) {
752
push @cmd, [';'];
753
push @cmd, $::cfg_path_dpkg_deb;
754
push @cmd, '--control';
755
push @cmd, $archive;
756
push @cmd, File::Spec->catdir($outdir, 'DEBIAN') if $mode eq 'extract';
757
push @cmd, File::Spec->catdir($::opt_cmd_extract_to, 'DEBIAN') if $mode eq 'extract-to';
758
}
759
}
760
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
761
}
762
elsif ($format eq 'ar') {
763
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
764
my $v = ($::opt_verbosity >= 1 ? 'v' : '');
765
push @cmd, $::cfg_path_ar;
766
push @cmd, 'rc'.$v if $mode eq 'add';
767
push @cmd, 'x'.$v if ($mode eq 'extract' || $mode eq 'extract-to');
768
push @cmd, 't'.$v if $mode eq 'list';
769
# Don't use v(erbose) with cat command because ar would add "\n<member data>\n\n" to output
770
push @cmd, 'p' if $mode eq 'cat';
771
push @cmd, makeabsolute($archive), @args;
772
return multiarchivecmd($archive, $outdir, $mode, 1, 1, \@args, @cmd);
773
}
774
elsif ($format eq 'cpio') {
775
return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
776
if ($mode eq 'list') {
777
push @cmd, $::cfg_path_cat, $archive, ['|'];
778
push @cmd, $::cfg_path_cpio, '-t';
779
push @cmd, '-v' if $::opt_verbosity >= 1;
780
return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
781
}
782
elsif ($mode eq 'extract' || $mode eq 'extract-to') {
783
push @cmd, $::cfg_path_cat, makeabsolute($archive), ['|'];
784
push @cmd, $::cfg_path_cpio, '-i';
785
push @cmd, '-v' if $::opt_verbosity >= 1;
786
return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
787
}
788
elsif ($mode eq 'add') {
789
if (@args == 0) {
790
push @cmd, $::cfg_path_cpio;
791
push @cmd, '-0' if $::opt_null;
792
push @cmd, '-o';
793
push @cmd, '-v' if $::opt_verbosity >= 1;
794
push @cmd, ['>'], $archive;
795
} else {
796
push @cmd, $::cfg_path_find, @args;
797
push @cmd, '-print0' if $::cfg_use_find_cpio_print0;
798
push @cmd, ['|'], $::cfg_path_cpio;
799
push @cmd, '-0' if $::cfg_use_find_cpio_print0;
800
push @cmd, '-o';
801
push @cmd, '-v' if $::opt_verbosity >= 1;
802
push @cmd, ['>'], $archive;
803
}
804
return multiarchivecmd($archive, $outdir, $mode, 1, 1, \@args, @cmd);
805
}
806
else { # cat
807
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
808
return undef;
809
}
810
}
811
elsif ($format eq 'bzip2') {
812
return singlearchivecmd($archive, $::cfg_use_pbzip2 ? $::cfg_path_pbzip2 : $::cfg_path_bzip2, $format, $mode, 1, @args);
813
}
814
elsif ($format eq 'bzip') {
815
return singlearchivecmd($archive, $::cfg_path_bzip, $format, $mode, 1, @args);
816
}
817
elsif ($format eq 'gzip') {
818
return singlearchivecmd($archive, $::cfg_path_gzip, $format, $mode, 1, @args);
819
}
820
elsif ($format eq 'compress') {
821
if ($::cfg_use_gzip_for_z && $mode ne 'add') {
822
return singlearchivecmd($archive, $::cfg_path_gzip, $format, $mode, 1, @args);
823
} else {
824
return singlearchivecmd($archive, $::cfg_path_compress, $format, $mode, 1, @args);
825
}
826
}
827
elsif ($format eq 'lzma') {
828
return singlearchivecmd($archive, $::cfg_path_lzma, $format, $mode, 1, @args);
829
}
830
elsif ($format eq 'lzop') {
831
return singlearchivecmd($archive, $::cfg_path_lzop, $format, $mode, 0, @args);
832
}
833
elsif ($format eq 'lzip') {
834
return singlearchivecmd($archive, $::cfg_path_lzip, $format, $mode, 1, @args);
835
}
836
elsif ($format eq 'xz') {
837
return singlearchivecmd($archive, $::cfg_path_xz, $format, $mode, 1, @args);
838
}
839
elsif ($format eq 'rzip') {
840
return singlearchivecmd($archive, $::cfg_path_rzip, $format, $mode, 0, @args);
841
}
842
elsif ($format eq 'lrzip') {
843
return singlearchivecmd($archive, $::cfg_path_lrzip, $format, $mode, 0, @args);
844
}
845
846
return undef;
847
}
848
849
# de(value):
850
# Return 1 if value defined and is non-zero, 0 otherwise.
851
sub de($) {
852
my ($value) = @_;
853
return defined $value && $value ? 1 : 0;
854
}
855
856
# getmode()
857
# Identify the execution mode, and return it.
858
# Possible modes are 'cat', 'extract', 'list', 'add' or 'extract-to'.
859
sub getmode() {
860
my $mode;
861
if (de($::opt_cmd_list)
862
+ de($::opt_cmd_cat)
863
+ de($::opt_cmd_extract)
864
+ de($::opt_cmd_add)
865
+ de($::opt_cmd_extract_to)
866
+ de($::opt_cmd_diff)
867
+ de($::opt_cmd_repack) > 1) {
868
die "$::basename: only one command may be specified\n"; #OK
869
}
870
$mode = 'cat' if ($::basename eq 'acat');
871
$mode = 'extract' if ($::basename eq 'aunpack');
872
$mode = 'list' if ($::basename eq 'als');
873
$mode = 'add' if ($::basename eq 'apack');
874
$mode = 'diff' if ($::basename eq 'adiff');
875
$mode = 'repack' if ($::basename eq 'arepack');
876
$mode = 'add' if ($::opt_cmd_add);
877
$mode = 'cat' if ($::opt_cmd_cat);
878
$mode = 'list' if ($::opt_cmd_list);
879
$mode = 'extract' if ($::opt_cmd_extract);
880
$mode = 'extract-to' if ($::opt_cmd_extract_to);
881
$mode = 'diff' if ($::opt_cmd_diff);
882
$mode = 'repack' if ($::opt_cmd_repack);
883
if (!defined $mode) {
884
die "$::basename: no command specified\nTry `$::basename --help' for more information.\n"; #OK
885
}
886
return $mode;
887
}
888
889
# singlearchivecmd(archive, command, format, mode, args)
890
# Execute a command for single-file archives.
891
# The command parameter specifies what command to execute.
892
# If mode is 'extract-to', returns the directory (or only file)
893
# which was extracted.
894
sub singlearchivecmd($$$$$@) {
895
my ($archive, $cmd, $format, $mode, $can_do_c, @args) = @_;
896
my $outfile;
897
my $reason;
898
my @cmd;
899
push @cmd, $cmd;
900
push @cmd, '-v' if $::opt_verbosity > 1;
901
902
if ($mode eq 'list') {
903
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
904
return undef;
905
}
906
elsif ($mode eq 'cat') {
907
if (!$can_do_c) {
908
warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
909
return undef;
910
}
911
push @cmd, '-c', '-d', $archive, @args;
912
$outfile = $archive; # Just so that we don't return undef
913
}
914
elsif ($mode eq 'add') {
915
if (@args > 1) {
916
warn "$::basename: cannot add more than one file with this format\n";
917
return undef;
918
}
919
if (!$::opt_force && (-e $archive || -l $archive)) {
920
warn "$::basename: ".quote($archive).": refusing to overwrite existing file\n";
921
return undef;
922
}
923
#if (!$::cfg_keep_compressed && stripext($archive) ne $args[0]) {
924
# warn "$::basename: ".quote($archive).": cannot create a $format archive with this name (use -X)\n";
925
# return;
926
#}
927
if ($can_do_c) {
928
push @cmd, '-c', @args, ['>'], $archive;
929
} else {
930
push @cmd, '-o', $archive, @args;
931
}
932
$outfile = $archive; # Just so that we don't return undef
933
}
934
elsif ($mode eq 'extract') {
935
$outfile = stripext($archive);
936
if ($::cfg_decompress_to_cwd) {
937
$outfile = basename($outfile);
938
}
939
if (-e $outfile) {
940
$outfile = makeoutfile($::cfg_tmpdir_name);
941
$reason = 'local file exists';
942
}
943
if ($can_do_c) {
944
push @cmd, '-c', '-d', $archive, @args, ['>'], $outfile;
945
} else {
946
push @cmd, '-o', $outfile, '-d', $archive, @args;
947
}
948
}
949
elsif ($mode eq 'extract-to') {
950
$outfile = $::opt_cmd_extract_to;
951
if ($::opt_simulate ? $::opt_cmd_extract_to_type eq 'd' : -d $outfile) {
952
my $base = File::Basename::basename($archive);
953
$outfile = File::Spec->catfile($outfile, stripext($base));
954
}
955
if ($can_do_c) {
956
push @cmd, '-c', '-d', $archive, @args, ['>'], $outfile;
957
} else {
958
push @cmd, '-o', $outfile, '-d', $archive, @args;
959
}
960
}
961
962
push @cmd, ['|'], get_pager_program() if $::opt_use_pager;
963
cmdexec(0, @cmd) || return undef;
964
965
if ($mode eq 'extract' || $mode eq 'extract-to') {
966
if ($::cfg_show_extracted && !$::opt_simulate) {
967
my $archivebase = File::Basename::basename($archive);
968
my $rmsg = defined $reason ? " ($reason)" : '';
969
warn quote($archivebase).": extracted to `".quote($outfile)."'$rmsg\n";
970
}
971
}
972
973
if (!$::cfg_keep_compressed) {
974
if ($mode eq 'extract') {
975
warn 'unlink ', quote($archive), "\n" if ($::opt_explain || $::opt_simulate);
976
if (!$::opt_simulate) {
977
unlink($archive) || warn "$::basename: ".quote($archive).": cannot remove - $!\n";
978
}
979
}
980
elsif ($mode eq 'add') {
981
warn 'unlink ', quote($args[0]), "\n" if ($::opt_explain || $::opt_simulate);
982
if (!$::opt_simulate) {
983
unlink($args[0]) || warn "$::basename: ".quote($args[0]).": cannot remove - $!\n";
984
}
985
}
986
}
987
988
return $outfile;
989
}
990
991
# maketarcmd(opts):
992
# Create (partial) command line arguments for a tar command.
993
# The parameter opts specifies additional arguments to add.
994
sub maketarcmd($$$$@) {
995
my ($archive, $outdir, $mode, $opts, @rest) = @_;
996
$opts = 'v'.$opts if $::opt_verbosity >= 1;
997
my @cmd = ($::cfg_path_tar);
998
push @cmd, "xO$opts" if $mode eq 'cat';
999
push @cmd, "x$opts" if ($mode eq 'extract' || $mode eq 'extract-to');
1000
push @cmd, "t$opts" if $mode eq 'list';
1001
push @cmd, "c$opts" if $mode eq 'add';
1002
push @cmd, $archive if defined $archive;
1003
push @cmd, '-C', $outdir if $mode eq 'extract';
1004
push @cmd, '-C', $::opt_cmd_extract_to if $mode eq 'extract-to';
1005
push @cmd, @rest;
1006
return @cmd;
1007
}
1008
1009
# cmdexec(ignore_return, cmdspec)
1010
# Execute a command specification.
1011
# The cmdspec parameter is a list of string arguments building
1012
# the command line. If there's a list reference instead of a
1013
# string, it is a shell meta character/string which shouldn't
1014
# be quoted.
1015
sub cmdexec($@) {
1016
my ($ignret, @cmd) = @_;
1017
1018
if ($::opt_explain || $::opt_simulate) {
1019
my $spec = join(' ', map { ref $_ ? @{$_} : shquotemeta $_ } @cmd);
1020
explain quote($spec)."\n";
1021
return 1 if ($::opt_simulate);
1022
}
1023
1024
my $cmds = makespec(@cmd);
1025
if (!shell_execute(@cmd)) {
1026
warn "$::basename: ".quote($cmds).": cannot execute - $::errmsg\n";
1027
return 0;
1028
}
1029
1030
if ($? & 0xFF != 0) {
1031
warn "$::basename: ".quote($cmds).": abnormal exit (exit code $?)\n";
1032
return 0;
1033
}
1034
1035
if (!$ignret && $? >> 8 != 0) {
1036
warn "$::basename: ".quote($cmds).": non-zero return-code\n";
1037
return 0;
1038
}
1039
1040
return 1;
1041
}
1042
1043
# makespec(@)
1044
# Make a command specification when printing errors.
1045
sub makespec(@) {
1046
my (@cmd) = @_;
1047
my $spec = $cmd[0].' ...';
1048
my $lastref = 0;
1049
foreach (@cmd, '') {
1050
if ($lastref) {
1051
$spec .= " | $_ ...";
1052
$lastref = 0;
1053
}
1054
$lastref = 1 if (ref);
1055
}
1056
return $spec;
1057
}
1058
1059
# makeoutfile(template)
1060
# Make a unique output file for extraction command.
1061
sub makeoutfile($) {
1062
my ($template) = @_;
1063
my $file;
1064
do {
1065
$file = sprintf $template, int rand 10000;
1066
} while (-e $file);
1067
return $file;
1068
}
1069
1070
# makeoutdir()
1071
# Make a temporary (unique) output directory for extraction command.
1072
sub makeoutdir() {
1073
my $dir;
1074
do {
1075
$dir = sprintf $::cfg_tmpdir_name, int rand 10000;
1076
} while (-e $dir);
1077
1078
warn 'mkdir ', $dir, "\n" if $::opt_simulate || $::opt_explain;
1079
if (!$::opt_simulate) {
1080
if (!mkdir($dir, 0700)) {
1081
warn "$::basename: ".quote($dir).": cannot create directory - $!\n";
1082
return undef;
1083
}
1084
push @::rmdirs, $dir;
1085
}
1086
return $dir;
1087
}
1088
1089
# explain($)
1090
# Print on screen if $::opt_explain is true.
1091
sub explain($) {
1092
my ($msg) = @_;
1093
print STDERR $msg if ($::opt_explain || $::opt_simulate);
1094
}
1095
1096
# tailslash($)
1097
# If specified filename does not end with a slash,
1098
# add one and return the new filename.
1099
sub tailslash($) {
1100
my ($file) = @_;
1101
return ($file =~ /\/$/ ? $file : "$file/");
1102
}
1103
1104
# shquotemeta($)
1105
# A more sophisticated quotemeta for bourne shells.
1106
# (This should be used for printing only.)
1107
sub shquotemeta($) {
1108
my ($str) = @_;
1109
$str =~ s/([^A-Za-z0-9_.+,\/:=@%^-])/\\$1/g;
1110
return $str;
1111
}
1112
1113
# multiarchivecmd(archive, outdir, mode, create, needcwd, argref, cmdspec)
1114
# Execute a command for multi-file archives.
1115
# The `create' argument controls whether the archive
1116
# will be created (1) or just added to (0) if mode is "add".
1117
# If mode is 'extract', returns the directory (or only file)
1118
# which was extracted.
1119
# If needcwd is true, the outdir must be changed to.
1120
sub multiarchivecmd($$$$@) {
1121
my ($archive, $outdir, $mode, $create, $needcwd, $argref, @cmd) = @_;
1122
my @args = @{$argref};
1123
1124
if ($mode eq 'cat' && @args == 0) {
1125
die "$::basename: missing file argument\n"; #OK
1126
}
1127
1128
if ($mode eq 'add' && $create && !$::opt_force && (-e $archive || -l $archive)) {
1129
warn "$::basename: ".quote($archive).": refusing to overwrite existing file\n";
1130
return undef;
1131
}
1132
1133
push @cmd, ['|'], get_pager_program() if $::opt_use_pager;
1134
1135
my $olddir = undef;
1136
if ($needcwd) {
1137
$olddir = getcwd();
1138
if ($mode eq 'extract') {
1139
warn "cd ", quote($outdir), "\n" if $::opt_explain || $::opt_simulate;
1140
if (!$::opt_simulate && !chdir($outdir)) {
1141
warn "$::basename: ".quote($outdir).": cannot change to - $!\n";
1142
return undef;
1143
}
1144
}
1145
if ($mode eq 'extract-to') {
1146
warn "cd ", quote($::opt_cmd_extract_to), "\n" if $::opt_explain || $::opt_simulate;
1147
if (!$::opt_simulate && !chdir($::opt_cmd_extract_to)) {
1148
warn "$::basename: ".quote($::opt_cmd_extract_to).": cannot change to - $!\n";
1149
return undef;
1150
}
1151
}
1152
}
1153
1154
if ($mode ne 'extract') {
1155
cmdexec(0, @cmd) || return undef;
1156
if (defined $olddir) {
1157
warn "cd ", quote($olddir), "\n" if $::opt_explain || $::opt_simulate;
1158
if (!$::opt_simulate && !chdir($olddir)) {
1159
warn "$::basename: ".quote($olddir).": cannot change to - $!\n";
1160
return undef;
1161
}
1162
}
1163
# XXX: can't save outdir with extract-to.
1164
return 1;
1165
}
1166
1167
if (!cmdexec(0, @cmd)) {
1168
if (defined $olddir) {
1169
warn "cd ", quote($olddir), "\n" if $::opt_explain || $::opt_simulate;
1170
if (!$::opt_simulate && !chdir($olddir)) {
1171
warn "$::basename: ".quote($olddir).": cannot change to - $!\n";
1172
}
1173
}
1174
return undef;
1175
}
1176
1177
if (defined $olddir) {
1178
warn "cd ", quote($olddir), "\n" if $::opt_explain || $::opt_simulate;
1179
if (!$::opt_simulate && !chdir($olddir)) {
1180
warn "$::basename: ".quote($olddir).": cannot change to - $!\n";
1181
return undef;
1182
}
1183
}
1184
1185
return undef if $::opt_simulate;
1186
1187
if (!opendir(DIR, $outdir)) {
1188
warn "$::basename: ".quote($outdir).": cannot list - $!\n";
1189
return undef;
1190
}
1191
my @files = grep !/^\.\.?$/, readdir DIR;
1192
closedir DIR;
1193
1194
my $archivebase = File::Basename::basename($archive);
1195
my $reason;
1196
my $adddir = 0;
1197
if (@files == 0) {
1198
warn quote($archivebase).": archive is empty\n";
1199
rmdir $outdir;
1200
return undef;
1201
} elsif ($::opt_extract_subdir) {
1202
$reason = 'forced';
1203
} elsif (@files == 1) {
1204
my $fromfile = File::Spec->catfile($outdir, $files[0]);
1205
if ($::opt_force || (!-l $files[0] && !-e $files[0])) {
1206
1207
# If the file is a directory, it can only be moved if writable
1208
my $oldmode = undef;
1209
if (!-l $fromfile && -d $fromfile) {
1210
my @statinfo = stat($fromfile);
1211
if (!@statinfo) {
1212
warn quote($fromfile).": cannot get file info - $!\n";
1213
return undef;
1214
}
1215
$oldmode = $statinfo[2];
1216
if (!chmod(0700, $fromfile)) {
1217
warn quote($fromfile).": cannot change mode - $!\n";
1218
return undef;
1219
}
1220
}
1221
1222
if (!rename $fromfile, $files[0]) {
1223
warn quote($fromfile).": cannot rename - $!\n";
1224
return undef;
1225
}
1226
rmdir $outdir;
1227
1228
# If we changed mode previously, restore that mode now
1229
if (defined $oldmode) {
1230
if (!chmod($oldmode, $files[0])) {
1231
warn quote($files[0]).": cannot change mode - $!\n";
1232
return undef;
1233
}
1234
}
1235
1236
if ($::cfg_show_extracted) {
1237
my $file = ($files[0] =~ /\// ? dirname($files[0]) : $files[0]);
1238
warn quote($archivebase).": extracted to `".quote($file)."'\n" ;
1239
}
1240
1241
save_outdir($files[0]);
1242
return $files[0];
1243
}
1244
$reason = 'local file exists';
1245
$adddir = 1 if (!-l $files[0] && -d $files[0]);
1246
} else {
1247
$reason = 'multiple files in root';
1248
}
1249
1250
my $localoutdir = stripext($archivebase);
1251
if (!-e $localoutdir) {
1252
if (!rename $outdir, $localoutdir) {
1253
warn quote($outdir).": cannot rename - $!\n";
1254
return undef;
1255
}
1256
$outdir = $localoutdir;
1257
}
1258
1259
warn quote($archivebase).": extracted to `".quote($outdir)."' ($reason)\n";
1260
save_outdir($adddir ? File::Spec->catfile($outdir, $files[0]) : $outdir);
1261
return $outdir;
1262
}
1263
1264
# stripext(file)
1265
# Strip extension from the specified file.
1266
sub stripext($) {
1267
my ($file) = @_;
1268
return $file if ($file =~ s/(\.tar\.bz2|\.tbz2)$//);
1269
return $file if ($file =~ s/(\.tar\.bz|\.tbz)$//);
1270
return $file if ($file =~ s/(\.tar\.gz|\.tgz)$//);
1271
return $file if ($file =~ s/(\.tar\.Z|\.tZ)$//);
1272
return $file if ($file =~ s/(\.tar\.7z|\.t7z)$//);
1273
return $file if ($file =~ s/(\.tar\.lzma|\.tlzma)$//);
1274
return $file if ($file =~ s/(\.tar\.lzo|\.lzo)$//);
1275
return $file if ($file =~ s/(\.tar\.lz|\.lz)$//);
1276
return $file if ($file =~ s/\.tar$//);
1277
return $file if ($file =~ s/\.bz2$//);
1278
return $file if ($file =~ s/\.bz$//);
1279
return $file if ($file =~ s/\.lz$//);
1280
return $file if ($file =~ s/\.gz$//);
1281
return $file if ($file =~ s/\.zip$//);
1282
return $file if ($file =~ s/\.7z$//);
1283
return $file if ($file =~ s/\.alz$//);
1284
return $file if ($file =~ s/\.jar$//);
1285
return $file if ($file =~ s/\.war$//);
1286
return $file if ($file =~ s/\.Z$//);
1287
return $file if ($file =~ s/\.rar$//);
1288
return $file if ($file =~ s/\.(lha|lzh)$//);
1289
return $file if ($file =~ s/\.ace$//);
1290
return $file if ($file =~ s/\.arj$//);
1291
return $file if ($file =~ s/\.a$//);
1292
return $file if ($file =~ s/\.lzma$//);
1293
return $file if ($file =~ s/\.rpm$//);
1294
return $file if ($file =~ s/\.deb$//);
1295
return $file if ($file =~ s/\.cpio$//);
1296
return $file if ($file =~ s/\.cab$//);
1297
return $file if ($::cfg_strip_unknown_ext && $file =~ s/\.[^.]+$//);
1298
return $file;
1299
}
1300
1301
# formatext(format)
1302
# Return the usual extension for the specified file format
1303
sub formatext($) {
1304
my ($format) = @_;
1305
return '.tar.bz2' if $format eq 'tar+bzip2';
1306
return '.tar.gz' if $format eq 'tar+gzip';
1307
return '.tar.bz' if $format eq 'tar+bzip';
1308
return '.tar.7z' if $format eq 'tar+7z';
1309
return '.tar.lzo' if $format eq 'tar+lzop';
1310
return '.tar.lzma' if $format eq 'tar+lzma';
1311
return '.tar.lz' if $format eq 'tar+lzip';
1312
return '.tar.xz' if $format eq 'tar+xz';
1313
return '.tar.Z' if $format eq 'tar+compress';
1314
return '.tar' if $format eq 'tar';
1315
return '.bz2' if $format eq 'bzip2';
1316
return '.lzma' if $format eq 'lzma';
1317
return '.7z' if $format eq '7z';
1318
return '.alz' if $format eq 'alzip';
1319
return '.bz' if $format eq 'bzip';
1320
return '.gz' if $format eq 'gzip';
1321
return '.lzo' if $format eq 'lzop';
1322
return '.lz' if $format eq 'lzip';
1323
return '.xz' if $format eq 'xzip';
1324
return '.rz' if $format eq 'rzip';
1325
return '.lrz' if $format eq 'lrzip';
1326
return '.zip' if $format eq 'zip';
1327
return '.jar' if $format eq 'jar';
1328
return '.Z' if $format eq 'compress';
1329
return '.rar' if $format eq 'rar';
1330
return '.ace' if $format eq 'ace';
1331
return '.a' if $format eq 'ar';
1332
return '.arj' if $format eq 'arj';
1333
return '.lha' if $format eq 'lha';
1334
return '.rpm' if $format eq 'rpm';
1335
return '.deb' if $format eq 'deb';
1336
return '.cpio' if $format eq 'cpio';
1337
return '.cab' if $format eq 'cab';
1338
die "$::basename: ".quote($format).": don't know file extension for format\n";
1339
}
1340
1341
# issingleformat(fmt)
1342
# fmt is a file specification as returned by findformat.
1343
# This function returns true if fmt is a single file archive (gzip etc)
1344
# for certain. This means that 7zip is not a single file archive format,
1345
# although it can be used in this way.
1346
sub issingleformat($) {
1347
my ($fmt) = @_;
1348
return 1 if $fmt eq 'bzip2';
1349
return 1 if $fmt eq 'gzip';
1350
return 1 if $fmt eq 'bzip';
1351
return 1 if $fmt eq 'compress';
1352
return 1 if $fmt eq 'lzma';
1353
return 1 if $fmt eq 'lzop';
1354
return 1 if $fmt eq 'lzip';
1355
return 1 if $fmt eq 'xz';
1356
return 1 if $fmt eq 'rzip';
1357
return 1 if $fmt eq 'lrzip';
1358
return 0;
1359
}
1360
1361
# findformat(spec, manual)
1362
# Figure out format from specified file/string.
1363
# If manual is 0, spec is a filename, otherwise
1364
# it is a format description string.
1365
sub findformat($$) {
1366
my ($file, $manual) = @_;
1367
my $spec = lc $file;
1368
my @fileoutput = (
1369
['tar+bzip2', qr/^(GNU|POSIX) tar archive \(bzip2 compressed data(\W|$)/],
1370
['tar+gzip', qr/^(GNU|POSIX) tar archive \(gzip compressed data(\W|$)/],
1371
['tar+bzip', qr/^(GNU|POSIX) tar archive \(bzip compressed data(\W|$)/],
1372
['tar+compress', qr/^(GNU|POSIX) tar archive \(compress'd data(\W|$)/],
1373
['tar', qr/^(GNU|POSIX) tar archive(\W|$)/],
1374
['zip', qr/ \(Zip archive data[^)]+\)$/],
1375
['zip', qr/^Zip archive data(\W|$)/],
1376
['zip', qr/^MS-DOS executable (.*), ZIP self-extracting archive(\W|$)/],
1377
['rar', qr/^RAR archive data(\W|$)/],
1378
['lha', qr/^LHa \(2\.x\) archive data /],
1379
['lha', qr/^LHa 2\.x\? archive data /],
1380
['lha', qr/^LHarc 1\.x archive data /],
1381
['lha', qr/^MS-DOS executable .*, LHA's SFX$/],
1382
['7z', qr/^7z archive data, version .*$/],
1383
['ar', qr/^current ar archive(\W|$)/],
1384
['arj', qr/^ARJ archive data(\W|$)/],
1385
['arc', qr/^ARC archive data(\W|$)/],
1386
['cpio', qr/^cpio archive$/],
1387
['cpio', qr/^ASCII cpio archive /],
1388
['rpm', qr/^RPM v/],
1389
['cab', qr/^Microsoft Cabinet archive data\W/],
1390
['cab', qr/^PE executable for MS Windows /],
1391
['deb', qr/^Debian binary package(\W|$)/],
1392
['bzip2', qr/ \(bzip2 compressed data(\W|$)/],
1393
['bzip', qr/ \(bzip compressed data(\W|$)/],
1394
['gzip', qr/ \(gzip compressed data(\W|$)/],
1395
['compress', qr/ \(compress'd data(\W|$)/],
1396
['lzma', qr/^lzma compressed data /], # Not in my magic
1397
['lzop', qr/^lzop compressed data /],
1398
['lzip', qr/^lzip compressed data /], # Not in my magic
1399
['xz', qr/^xz compressed data /], # Not in my magic
1400
['rzip', qr/^rzip compressed data /],
1401
['lrzip', qr/^lrzip compressed data /], # Not in my magic
1402
['bzip2', qr/^bzip2 compressed data(\W|$)/],
1403
['bzip', qr/^bzip compressed data(\W|$)/],
1404
['gzip', qr/^gzip compressed data(\W|$)/],
1405
['compress', qr/^compress'd data(\W|$)/],
1406
);
1407
my @fileextensions = (
1408
['tar+7z', qr/(\.tar\.7z|\.t7z)$/],
1409
['tar+bzip', qr/(\.tar\.bz|\.tbz)$/],
1410
['tar+bzip2', qr/(\.tar\.bz2|\.tbz2)$/],
1411
['tar+compress', qr/(\.tar\.[zZ]|\.t[zZ])$/],
1412
['tar+gzip', qr/(\.tar\.gz|\.tgz)$/],
1413
['tar+lzip', qr/(\.tar\.lz|\.tlz)$/],
1414
['tar+lzma', qr/(\.tar\.lzma|\.tlzma)$/],
1415
['tar+lzop', qr/(\.tar\.lzo|\.tzo)$/],
1416
['tar+xz', qr/(\.tar\.xz|\.txz)$/],
1417
1418
['7z', qr/\.7z$/],
1419
['ace', qr/\.ace$/],
1420
['alzip', qr/\.alz$/],
1421
['ar', qr/\.a$/],
1422
['arc', qr/\.arc$/],
1423
['arj', qr/\.arj$/],
1424
['bzip', qr/\.bz$/],
1425
['bzip2', qr/\.bz2$/],
1426
['cab', qr/\.cab$/],
1427
['compress', qr/\.[zZ]$/],
1428
['cpio', qr/\.cpio$/],
1429
['deb', qr/\.deb$/],
1430
['gzip', qr/\.gz$/],
1431
['jar', qr/\.(jar|war)$/],
1432
['lha', qr/\.(lha|lzh)$/],
1433
['lrzip', qr/\.lrz$/],
1434
['lzip', qr/\.lz$/],
1435
['lzma', qr/\.lzma$/],
1436
['lzop', qr/\.lzo$/],
1437
['rar', qr/\.rar$/],
1438
['rpm', qr/\.rpm$/],
1439
['rzip', qr/\.rz$/],
1440
['tar', qr/\.tar$/],
1441
['xz', qr/\.xz$/],
1442
['zip', qr/\.zip$/],
1443
);
1444
1445
if ($manual) {
1446
$spec =~ tr/+/./;
1447
$spec =~ s/^\.*/\./;
1448
$spec =~ s/lzop/lzo/;
1449
$spec =~ s/lzip/lz/;
1450
$spec =~ s/rzip/rz/;
1451
$spec =~ s/lrzip/lrz/;
1452
$spec =~ s/bzip2/bz2/;
1453
$spec =~ s/bzip/bz/;
1454
$spec =~ s/gzip/gz/;
1455
$spec =~ s/7zip/7z/;
1456
$spec =~ s/alzip/alz/;
1457
$spec =~ s/compress/Z/;
1458
$spec =~ s/^ar$/a/;
1459
}
1460
if (!$::cfg_use_file_always) {
1461
foreach my $formatinfo (@fileextensions) {
1462
my ($format, $regex) = @{$formatinfo};
1463
return $format if ($spec =~ $regex);
1464
}
1465
}
1466
if (!$manual && $::cfg_use_file) {
1467
if (!-e $file) {
1468
warn "$::basename: ".quote($file).": no such file and cannot identify format from extension\n";
1469
return;
1470
}
1471
if (!sysopen(TMP, $file, O_RDONLY)) {
1472
warn "$::basename: ".quote($file).": cannot open - $!\n";
1473
return;
1474
}
1475
close TMP;
1476
if (!-f $file) {
1477
warn "$::basename: ".quote($file).": not a regular file\n";
1478
return;
1479
}
1480
if ($::opt_verbosity >= 1) {
1481
if ($::cfg_use_file_always) {
1482
warn "$::basename: ".quote($file).": identifying format using file\n";
1483
} else {
1484
warn "$::basename: ".quote($file).": format not known, identifying using file\n";
1485
}
1486
}
1487
my @cmd = ($::cfg_path_file, '-b', '-L', '-z', '--', $file);
1488
$spec = backticks(@cmd);
1489
if (!defined $spec) {
1490
warn "$::basename: $::errmsg\n";
1491
return;
1492
}
1493
if ($? & 0xFF != 0) {
1494
warn "$::basename: ".quote($::cfg_path_file).": abnormal exit\n";
1495
return;
1496
}
1497
if ($? >> 8 != 0) {
1498
warn "$::basename: ".quote($file).": unknown file format\n";
1499
return;
1500
}
1501
chomp $spec;
1502
foreach my $formatinfo (@fileoutput) {
1503
my ($format, $regex) = @{$formatinfo};
1504
if ($spec =~ $regex) {
1505
warn "$::basename: ".quote($file).": format is `$format'\n" if $::opt_verbosity >= 1;
1506
return $format;
1507
}
1508
}
1509
warn "$::basename: ".quote($file).": unsupported file format `$spec'\n";
1510
return;
1511
}
1512
warn "$::basename: ".quote($file).": unrecognized file format\n";
1513
return;
1514
}
1515
1516
# backticks(cmdargs, ..)
1517
# An implementation of the backtick (qx//) operator.
1518
# The difference is that command STDERR output will still
1519
# be printed on STDERR, and the shell isn't used to parse
1520
# the command line.
1521
sub backticks(@) {
1522
if (!pipe(IN,OUT)) {
1523
$::errmsg = "pipe failed - $!";
1524
return;
1525
}
1526
my $child = fork;
1527
if (!defined $child) {
1528
$::errmsg = "fork failed - $!";
1529
return;
1530
}
1531
if ($child == 0) {
1532
close IN || exit 1;
1533
close STDOUT || exit 1;
1534
open(STDOUT, '>&OUT') || exit 1;
1535
close OUT || exit 1;
1536
$SIG{__WARN__} = sub {};
1537
exec(@_) || exit 1;
1538
}
1539
close OUT;
1540
my $text = join('', <IN>);
1541
close IN;
1542
if (waitpid($child,0) != $child && $^O ne 'MSWin32') {
1543
$::errmsg = "waitpid failed - $!";
1544
return;
1545
}
1546
return $text;
1547
}
1548
1549
# set_config_option(variable, value)
1550
# Set a configuration option.
1551
sub set_config_option($$$) {
1552
my ($var, $val, $context) = @_;
1553
my %optionmap = (
1554
'args_diff' => [ 'option', \$::cfg_args_diff, qr/.*/ ],
1555
'decompress_to_cwd' => [ 'option', \$::cfg_decompress_to_cwd, qr/^(0|1)$/ ],
1556
'default_verbosity' => [ 'option', \$::cfg_default_verbosity, qr/^\d+$/ ],
1557
'extract_deb_control' => [ 'option', \$::cfg_extract_deb_control, qr/^(0|1)$/ ],
1558
'keep_compressed' => [ 'option', \$::cfg_keep_compressed, qr/^(0|1)$/ ],
1559
'path_7z' => [ 'option', \$::cfg_path_7z, qr/.*/ ],
1560
'path_ar' => [ 'option', \$::cfg_path_ar, qr/.*/ ],
1561
'path_arc' => [ 'option', \$::cfg_path_arc, qr/.*/ ],
1562
'path_arj' => [ 'option', \$::cfg_path_arj, qr/.*/ ],
1563
'path_bzip' => [ 'option', \$::cfg_path_bzip, qr/.*/ ],
1564
'path_bzip2' => [ 'option', \$::cfg_path_bzip2, qr/.*/ ],
1565
'path_cabextract' => [ 'option', \$::cfg_path_cabextract, qr/.*/ ],
1566
'path_cat' => [ 'option', \$::cfg_path_cat, qr/.*/ ],
1567
'path_compress' => [ 'option', \$::cfg_path_compress, qr/.*/ ],
1568
'path_cpio' => [ 'option', \$::cfg_path_cpio, qr/.*/ ],
1569
'path_diff' => [ 'option', \$::cfg_path_diff, qr/.*/ ],
1570
'path_dpkg_deb' => [ 'option', \$::cfg_path_dpkg_deb, qr/.*/ ],
1571
'path_file' => [ 'option', \$::cfg_path_file, qr/.*/ ],
1572
'path_find' => [ 'option', \$::cfg_path_find, qr/.*/ ],
1573
'path_gzip' => [ 'option', \$::cfg_path_gzip, qr/.*/ ],
1574
'path_jar' => [ 'option', \$::cfg_path_jar, qr/.*/ ],
1575
'path_lha' => [ 'option', \$::cfg_path_lha, qr/.*/ ],
1576
'path_lrzip' => [ 'option', \$::cfg_path_lrzip, qr/.*/ ],
1577
'path_lzip' => [ 'option', \$::cfg_path_lzip, qr/.*/ ],
1578
'path_lzma' => [ 'option', \$::cfg_path_lzma, qr/.*/ ],
1579
'path_lzop' => [ 'option', \$::cfg_path_lzop, qr/.*/ ],
1580
'path_nomarch' => [ 'option', \$::cfg_path_nomarch, qr/.*/ ],
1581
'path_pager' => [ 'option', \$::cfg_path_pager, qr/.*/ ],
1582
'path_pbzip2' => [ 'option', \$::cfg_path_pbzip2, qr/.*/ ],
1583
'path_rar' => [ 'option', \$::cfg_path_rar, qr/.*/ ],
1584
'path_rpm' => [ 'option', \$::cfg_path_rpm, qr/.*/ ],
1585
'path_rpm2cpio' => [ 'option', \$::cfg_path_rpm2cpio, qr/.*/ ],
1586
'path_rzip' => [ 'option', \$::cfg_path_rzip, qr/.*/ ],
1587
'path_tar' => [ 'option', \$::cfg_path_tar, qr/.*/ ],
1588
'path_unace' => [ 'option', \$::cfg_path_unace, qr/.*/ ],
1589
'path_unalz' => [ 'option', \$::cfg_path_unalz, qr/.*/ ],
1590
'path_unarj' => [ 'option', \$::cfg_path_unarj, qr/.*/ ],
1591
'path_unrar' => [ 'option', \$::cfg_path_unrar, qr/.*/ ],
1592
'path_unzip' => [ 'option', \$::cfg_path_unzip, qr/.*/ ],
1593
'path_usercfg' => [ 'option', \$::cfg_path_usercfg, qr/.*/ ],
1594
'path_xargs' => [ 'option', \$::cfg_path_xargs, qr/.*/ ],
1595
'path_xz' => [ 'option', \$::cfg_path_xz, qr/.*/ ],
1596
'path_zip' => [ 'option', \$::cfg_path_zip, qr/.*/ ],
1597
'show_extracted' => [ 'option', \$::cfg_show_extracted, qr/^(0|1)$/ ],
1598
'strip_unknown_ext' => [ 'option', \$::cfg_strip_unknown_ext, qr/^(0|1)$/ ],
1599
'tmpdir_name' => [ 'option', \$::cfg_tmpdir_name, qr/.*/ ],
1600
'tmpfile_name' => [ 'option', \$::cfg_tmpfile_name, qr/.*/ ],
1601
'use_arc_for_unpack' => [ 'option', \$::cfg_use_arc_for_unpack, qr/^(0|1)$/ ],
1602
'use_arj_for_unpack' => [ 'option', \$::cfg_use_arj_for_unpack, qr/^(0|1)$/ ],
1603
'use_file' => [ 'option', \$::cfg_use_file, qr/^(0|1)$/ ],
1604
'use_file_always' => [ 'option', \$::cfg_use_file_always, qr/^(0|1)$/ ],
1605
'use_find_cpio_print0' => [ 'option', \$::cfg_use_find_cpio_print0, qr/^(0|1)$/ ],
1606
'use_gzip_for_z' => [ 'option', \$::cfg_use_gzip_for_z, qr/^(0|1)$/ ],
1607
'use_jar' => [ 'option', \$::cfg_use_jar, qr/^(0|1)$/ ],
1608
'use_pbzip2' => [ 'option', \$::cfg_use_pbzip2, qr/^(0|1)$/ ],
1609
'use_rar_for_unpack' => [ 'option', \$::cfg_use_rar_for_unpack, qr/^(0|1)$/ ],
1610
'use_rar_for_unrar' => [ 'obsolete', 'use_rar_for_unpack' ],
1611
'use_tar_bzip2_option' => [ 'option', \$::cfg_use_tar_bzip2_option, qr/^(0|1)$/ ],
1612
'use_tar_lzma_option' => [ 'option', \$::cfg_use_tar_lzma_option, qr/^(0|1)$/ ],
1613
'use_tar_lzop_option' => [ 'option', \$::cfg_use_tar_lzop_option, qr/^(0|1)$/ ],
1614
'use_tar_xv_option' => [ 'option', \$::cfg_use_tar_xv_option, qr/^(0|1)$/ ],
1615
'use_tar_j_option' => [ 'obsolete', 'use_tar_bzip2_option' ],
1616
'use_tar_z_option' => [ 'option', \$::cfg_use_tar_z_option, qr/^(0|1)$/ ],
1617
);
1618
die $::basename,': ',$context,'unrecognized directive `',$var,"'\n" if !exists $optionmap{$var};
1619
return 0 if !exists $optionmap{$var};
1620
my ($type) = @{$optionmap{$var}};
1621
if ($type eq 'obsolete') {
1622
warn $context.$var.' is obsolete - use '.$optionmap{$var}->[1].')'."\n";
1623
$var = $optionmap{$var}->[1];
1624
}
1625
my ($varref,$check) = @{$optionmap{$var}}[1,2];
1626
die $::basename,': ',$context,'invalid value for `',$var,"'\n" if $val !~ $check;
1627
${$varref} = $val;
1628
return 1;
1629
}
1630
1631
# readconfig(file)
1632
# Read and parse the specified configuration file.
1633
# If the file does not exist, just return.
1634
# If there is an error in the configuration file,
1635
# the program will be terminated. This could be a
1636
# problem when there are errors in the system-wide
1637
# configuration file.
1638
sub readconfig($$) {
1639
my ($file, $failok) = @_;
1640
return if ($failok && !-e $file);
1641
sysopen(FILE, $file, O_RDONLY) || die "$::basename: ".quote($file).": cannot open for reading - $!\n"; #OK
1642
while (<FILE>) {
1643
chomp;
1644
next if /^\s*(#(.*))?$/;
1645
my ($var,$val) = /^(.*?)\s+([^\s].*)$/; # joe markup bug -> ]]
1646
set_config_option($var, $val, quote($file).':'.$..': ');
1647
}
1648
close(FILE);
1649
}
1650
1651
# Remove a directory recursively. This function used to change
1652
# the mode on the directories is traverses, but I now consider
1653
# that to be unsafe (what if there's a bug in atool and it
1654
# removes a file it shouldn't?).
1655
sub unlink_directory($) {
1656
my ($dir) = @_;
1657
die "$::basename: internal error 1 - please report this bug\n"
1658
if ($dir eq '/' || $dir eq $ENV{HOME});
1659
# chmod 0700, $dir || die "$::basename: cannot chmod `".quote($dir)."': $!\n";
1660
chdir $dir || die "$::basename: ".quote($dir).": cannot change to - $!\n";
1661
opendir(DIR, $::cur) || die "$::basename: ".quote($dir).": cannot list - $!\n";
1662
my @files = readdir(DIR);
1663
closedir(DIR);
1664
foreach my $file (@files) {
1665
next if $file eq $::cur || $file eq $::up;
1666
if (-d $file && !-l $file) {
1667
unlink_directory($file);
1668
} else {
1669
unlink $file || die "$::basename: ".quote($file).": cannot remove - $!\n";
1670
}
1671
}
1672
chdir $::up || die "$::basename: $::up: cannot change to - $!\n";
1673
rmdir $dir || die "$::basename: ".quote($dir).": cannot remove - $!\n";
1674
}
1675
1676
# find_comparable_file(dir)
1677
# Assuming that the contents of some archive has been extracted to dir,
1678
# this function will determine the main file or directory in this
1679
# archive - the file or directory which will be compared when this
1680
# archive is compared to some other.
1681
sub find_comparable_file($) {
1682
my ($dir) = @_;
1683
my $result = $dir;
1684
if (opendir(my $dh, $dir)) {
1685
my @files;
1686
for (0..3) {
1687
my $file = readdir($dh);
1688
last if !defined $file;
1689
next if $file eq '.' || $file eq '..';
1690
push @files, $file;
1691
}
1692
closedir($dh);
1693
$result = File::Spec->catfile($dir, $files[0]) if @files == 1;
1694
}
1695
return $result;
1696
}
1697
1698
# makeabsolute(file)
1699
# Return the absolute version of file.
1700
sub makeabsolute($) {
1701
my ($file) = @_;
1702
return $file if (substr($file, 0, 1) eq '/');
1703
return File::Spec->catfile(getcwd(), $file);
1704
}
1705
1706
# quote(string)
1707
# Quote a style like the GNU fileutils would do (`locale'
1708
# quoting style).
1709
sub quote($) {
1710
my ($in) = @_;
1711
my $out = '';
1712
for (my $c = 0; $c < length($in); $c++) {
1713
my $ch = substr($in, $c, 1);
1714
if ($ch eq "\b") {
1715
$out .= "\\b";
1716
} elsif ($ch eq "\f") {
1717
$out .= "\\f";
1718
} elsif ($ch eq "\n") {
1719
$out .= "\\n";
1720
} elsif ($ch eq "\r") {
1721
$out .= "\\r";
1722
} elsif ($ch eq "\t") {
1723
$out .= "\\t";
1724
} elsif (ord($ch) == 11) { # Vertical Tab, \v
1725
$out .= "\\v";
1726
} elsif ($ch eq "\\") {
1727
$out .= "\\\\";
1728
} elsif ($ch eq "'") {
1729
$out .= "\\'";
1730
} elsif ($ch !~ /[[:print:]]/) {
1731
$out .= sprintf('\\%03o', ord($ch));
1732
} else {
1733
$out .= $ch;
1734
}
1735
}
1736
return $out;
1737
}
1738
1739
# shell_execute(@)
1740
# Execute a command with pipes and output redirection like the
1741
# shell does. Only difference is we do it without the shell.
1742
# This reason for this is because we don't have to quote
1743
# meta-characters - some meta-characters like LF and DEL are
1744
# unquotable!
1745
sub shell_execute(@) {
1746
my @cmdspec = @_;
1747
my $start = 0;
1748
my $c;
1749
for ($c = 0; $c < @cmdspec; $c++) {
1750
if (ref $cmdspec[$c] && ${$cmdspec[$c]}[0] eq ';') {
1751
return 0 if !shell_execute_single_statement(@cmdspec[$start..$c-1]);
1752
$start = $c+1;
1753
}
1754
}
1755
if ($start != $c) {
1756
return 0 if !shell_execute_single_statement(@cmdspec[$start..$c-1]);
1757
}
1758
return 1;
1759
}
1760
1761
sub shell_execute_single_statement(@) {
1762
my (@cmdspec) = @_;
1763
1764
while (@cmdspec > 0) {
1765
my @cmds = ();
1766
my $start = 0;
1767
my $redir_out = undef;
1768
#my $more_cmds = 0;
1769
my $c;
1770
for ($c = 0; $c < @cmdspec; $c++) {
1771
if (ref $cmdspec[$c]) {
1772
push @cmds, [ @cmdspec[$start..$c-1] ];
1773
if (${$cmdspec[$c]}[0] eq '>') {
1774
$redir_out = $cmdspec[$c+1];
1775
$start = $c+2;
1776
$c++;
1777
#} elsif (${$cmdspec[$c]}[0] eq ';') {
1778
#$more_cmds = 1;
1779
# $start = $c+1;
1780
# $c++;
1781
# last;
1782
} elsif (${$cmdspec[$c]}[0] eq '|') {
1783
$start = $c+1;
1784
}
1785
}
1786
}
1787
push @cmds, [ @cmdspec[$start..$c-1] ] if $start < $c;
1788
#for (my $x = 0; $x < @cmds; $x++) {
1789
# print $x, ': ', join(':',@{$cmds[$x]}), "\n";
1790
#}
1791
splice @cmdspec,0,$c;
1792
1793
$SIG{INT} = 'IGNORE';
1794
1795
my @ip = ();
1796
my @op = ();
1797
my @children = ();
1798
for (my $c = 0; $c <= $#cmds; $c++) {
1799
if ($c != $#cmds) {
1800
@op = reverse POSIX::pipe();
1801
if (!@op || !defined $op[0] || !defined $op[1]) {
1802
$::errmsg = "pipe failed - $!";
1803
return 0;
1804
}
1805
}
1806
if ($c == $#cmds && defined $redir_out) {
1807
@_ = (); # XXX: necessary to overcome POSIX autoload bug!
1808
@op = (POSIX::open($redir_out, &POSIX::O_WRONLY | &POSIX::O_CREAT));
1809
if (!@op || !defined $op[0]) {
1810
$::errmsg = quote($redir_out).": cannot open for writing - $!";
1811
return 0;
1812
}
1813
}
1814
my $pid = fork();
1815
die "fork failed - $!\n" if !defined $pid;
1816
if ($pid == 0) {
1817
$SIG{INT} = '';
1818
if (@ip) {
1819
die "dup2 failed - $!\n" if POSIX::dup2($ip[1], 0) < 0;
1820
POSIX::close($_) foreach (@ip);
1821
}
1822
if (@op) {
1823
die "dup2 failed - $!\n" if POSIX::dup2($op[0], 1) < 0;
1824
POSIX::close($_) foreach (@op);
1825
}
1826
exec(@{$cmds[$c]}) || die ${$cmds[$c]}[0].": cannot execute - $!\n";
1827
}
1828
POSIX::close($op[0]) if ($c == $#cmds && defined $redir_out);
1829
POSIX::close($_) foreach (@ip);
1830
@ip = @op;
1831
@op = ();
1832
push @children, $pid;
1833
}
1834
1835
foreach (@children) {
1836
if (waitpid($_,0) < 0 && $^O ne 'MSWin32') {
1837
$::errmsg = "waitpid failed - $!";
1838
return 0;
1839
}
1840
}
1841
$SIG{INT} = '';
1842
}
1843
1844
return 1;
1845
}
1846
1847
# Write dir to file indicated by $::opt_save_outdir.
1848
#
1849
sub save_outdir($) {
1850
my ($dir) = @_;
1851
if (defined $::opt_save_outdir && !-l $dir && -d $dir) {
1852
if (!sysopen(TMP, $::opt_save_outdir, O_WRONLY)) {
1853
warn die "$::basename: ".quote($::opt_save_outdir).": cannot open for writing - $!\n";
1854
} else {
1855
print TMP $dir, "\n";
1856
close(TMP);
1857
}
1858
}
1859
}
1860
1861
# Somewhat stupid subroutine to add xargs to the command line.
1862
#
1863
sub handle_empty_add(@) {
1864
my @cmd = @_;
1865
unshift @cmd, '--';
1866
unshift @cmd, '-0' if ($::opt_null);
1867
unshift @cmd, $::cfg_path_xargs;
1868
return @cmd;
1869
}
1870
1871
# Return a suitable pager command
1872
#
1873
sub get_pager_program {
1874
return $ENV{PAGER} if (exists $ENV{PAGER});
1875
return $::cfg_path_pager;
1876
}
1877
1878
# repack_archive(srcfile,dstfile,srcfmt,dstfmt)
1879
# Repack an archive from a file to another (that shouldn't exist).
1880
sub repack_archive($$$$) {
1881
my ($file1,$file2,$fmt1,$fmt2) = @_;
1882
1883
# Special cases for tar-based archives (single file archives).
1884
if ($fmt1 =~ /^tar\+/ && $fmt2 =~ /^tar$/) {
1885
$fmt1 =~ s/^tar\+//;
1886
$::opt_cmd_extract_to = $file2; # XXX: would like to get rid of these
1887
$::opt_cmd_extract_to_type = 'f'; # XXX: would like to get rid of these
1888
exit 1 if (!runcmds('extract-to', $fmt1, $file1));
1889
return;
1890
} elsif ($fmt1 =~ /^tar$/ && $fmt2 =~ /^tar\+/) {
1891
$fmt2 =~ s/^tar\+//;
1892
exit 1 if (!runcmds('add', $fmt2, $file2, $file1));
1893
return;
1894
}
1895
1896
if ($fmt1 =~ /^tar\+/ && $fmt2 =~ /^tar\+/) {
1897
$fmt1 =~ s/^tar\+//;
1898
$fmt2 =~ s/^tar\+//;
1899
}
1900
1901
my $newarchive;
1902
if (File::Spec->file_name_is_absolute($file2)) {
1903
$newarchive = $file2;
1904
} else {
1905
$newarchive = File::Spec->catdir($::up, $file2);
1906
}
1907
1908
my $outdir;
1909
$outdir = makeoutdir() || exit 1;
1910
$::opt_cmd_extract_to = $outdir;
1911
$::opt_cmd_extract_to_type = 'd';
1912
exit 1 if !runcmds('extract-to', $fmt1, $file1);
1913
warn 'cd ',quote($outdir),"\n" if $::opt_explain || $::opt_simulate;
1914
if (!$::opt_simulate) {
1915
chdir($outdir) || die "$::basename: ".quote($outdir).": cannot change to - $!\n";
1916
}
1917
if (issingleformat($fmt2)) {
1918
# Preferrably we would like to find out what file it was
1919
# extracted to from the above execute-to command.
1920
#my $oldfile = stripext_exactly(basename($file1), $fmt1);
1921
my $oldfile = find_comparable_file($::cur); # FIXME: won't work in simulate mode
1922
exit 1 if !runcmds('add', $fmt2, $newarchive, $oldfile);
1923
} else {
1924
exit 1 if !runcmds('add', $fmt2, $newarchive, $::cur);
1925
}
1926
warn 'cd ',quote($::up),"\n" if $::opt_explain || $::opt_simulate;
1927
if (!$::opt_simulate) {
1928
chdir($::up) || die "$::basename: ".$::up.": cannot change to - $!\n"; #OK?????
1929
}
1930
warn 'rm -r ',quote($outdir),"\n" if $::opt_explain || $::opt_simulate;
1931
if (!$::opt_simulate) {
1932
unlink_directory($outdir);
1933
}
1934
}
1935
1936
sub END {
1937
map (rmdir, @::rmdirs) if !$::opt_simulate; # Errors are ignored
1938
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1