3 # atool - A script for managing file archives of various types.
5 # Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008,
6 # 2009, 2011, 2012 Oskar Liljeblad
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.
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.
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.
22 # See the atool(1) manual page for usage details.
24 # This file uses tab stops with a length of two.
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
31 use Encode
qw(decode_utf8);
32 binmode($_, ':encoding(UTF-8)') for \
*STDIN
, \
*STDOUT
, \
*STDERR
;
33 $_ = decode_utf8
($_) for @ARGV, values %ENV;
43 # Subroutine prototypes (needed for perl 5.6)
46 sub multiarchivecmd
($$$$@
);
47 sub singlearchivecmd
($$$$$@
);
48 sub maketarcmd
($$$$@
);
64 sub unlink_directory
($);
65 sub find_comparable_file
($);
70 sub handle_empty_add
(@
);
71 sub issingleformat
($);
72 sub repack_archive
($$$$);
73 sub set_config_option
($$$);
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.39.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
;
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_lbzip2
= 'lbzip2'; # lbzip2 program
104 $::cfg_path_lha
= 'lha'; # lha program
105 $::cfg_path_lrzip
= 'lrzip'; # lrzip program
106 $::cfg_path_lzip
= 'lzip'; # lzip program
107 $::cfg_path_lzma
= 'lzma'; # lzma program
108 $::cfg_path_lzop
= 'lzop'; # lzop program
109 $::cfg_path_nomarch
= 'nomarch'; # nomarch program
110 $::cfg_path_pager
= 'pager'; # pager program
111 $::cfg_path_pbzip2
= 'pbzip2'; # pbzip2 program
112 $::cfg_path_pigz
= 'pigz'; # pigz program
113 $::cfg_path_plzip
= 'plzip'; # plzip program
114 $::cfg_path_rar
= 'rar'; # rar program
115 $::cfg_path_rpm
= 'rpm'; # rpm program
116 $::cfg_path_rpm2cpio
= 'rpm2cpio'; # rpm2cpio program
117 $::cfg_path_rzip
= 'rzip'; # rzip program
118 $::cfg_path_syscfg
= File
::Spec
->catfile($::SYSCONFDIR
, $::PROGRAM
.'.conf'); # system-wide configuration file
119 $::cfg_path_tar
= 'tar'; # tar program
120 $::cfg_path_unace
= 'unace'; # unace program
121 $::cfg_path_unalz
= 'unalz'; # unalz program
122 $::cfg_path_unarj
= 'unarj'; # unarj program
123 $::cfg_path_unrar
= 'unrar'; # unrar program
124 $::cfg_path_unzip
= 'unzip'; # unzip program
125 $::cfg_path_usercfg
= '.'.$::PROGRAM
.'rc'; # user configuration file
126 $::cfg_path_xargs
= 'xargs'; # xargs program
127 $::cfg_path_xz
= 'xz'; # xz program
128 $::cfg_path_zip
= 'zip'; # zip program
129 $::cfg_show_extracted
= 1; # always show extracted file/directory
130 $::cfg_strip_unknown_ext
= 1; # strip unknown extensions
131 $::cfg_tmpdir_name
= 'Unpack-%04d'; # extraction directory name
132 $::cfg_tmpfile_name
= 'Pack-%04d'; # temporary file used during packing
133 $::cfg_use_arc_for_unpack
= 0; # use arc to unpack arc files?
134 $::cfg_use_arj_for_unpack
= 0; # use arj to unpack arj files?
135 $::cfg_use_file
= 1; # use file(1) for unknown extensions?
136 $::cfg_use_file_always
= 0; # always use file to identify archives (ignore extension)
137 $::cfg_use_find_cpio_print0
= 1; # use -print0/-0 find/cpio options?
138 $::cfg_use_gzip_for_z
= 1; # use gzip to decompress .Z files?
139 $::cfg_use_jar
= 0; # use jar or zip for .jar archives?
140 $::cfg_use_lbzip2
= 0; # use lbzip2 instead of bzip2
141 $::cfg_use_pbzip2
= 0; # use pbzip2 instead of bzip2
142 $::cfg_use_pigz
= 0; # use pigz instead of gzip
143 $::cfg_use_plzip
= 0; # use plzip instead of lzip
144 $::cfg_use_rar_for_unpack
= 0; # use rar to unpack rar files?
145 $::cfg_use_tar_bzip2_option
= 1; # does tar support --bzip2?
146 $::cfg_use_tar_lzma_option
= 1; # does tar support --lzma?
147 $::cfg_use_tar_lzip_option
= 0; # does tar support --lzip?
148 $::cfg_use_tar_lzop_option
= 0; # does tar support --lzop?
149 $::cfg_use_tar_xz_option
= 0; # does tar support --xz?
150 $::cfg_use_tar_z_option
= 1; # does tar support -z?
153 $::basename
= quote
(File
::Basename
::basename
($0));
155 $::up
= File
::Spec
->updir();
156 $::cur
= File
::Spec
->curdir();
158 @
::opt_format_options
= ();
161 Getopt
::Long
::config
('bundling');
162 Getopt
::Long
::GetOptions
(
163 'l|list' => \
$::opt_cmd_list
,
164 'x|extract' => \
$::opt_cmd_extract
,
165 'X|extract-to=s' => \
$::opt_cmd_extract_to
,
166 'a|add' => \
$::opt_cmd_add
,
167 'c|cat' => \
$::opt_cmd_cat
,
168 'd|diff' => \
$::opt_cmd_diff
,
169 'r|repack' => \
$::opt_cmd_repack
,
170 'q|quiet' => sub { $::opt_verbosity
--; },
171 'v|verbose' => sub { $::opt_verbosity
++; },
172 'V|verbosity=i' => \
$::opt_verbosity
,
173 'config=s' => \
$::opt_config
,
174 'o|option=s' => sub { push @
::opt_options
, $_[1] },
175 'help' => \
$::opt_cmd_help
,
176 'version' => \
$::opt_cmd_version
,
177 'F|format=s' => \
$::opt_format
,
178 'O|format-option=s' => sub { push @
::opt_format_options
, $_[1] },
179 'f|force' => \
$::opt_force
,
180 'p|page' => \
$::opt_use_pager
,
181 'e|each' => \
$::opt_each
,
182 'E|explain' => \
$::opt_explain
,
183 'S|simulate' => \
$::opt_simulate
,
184 'save-outdir=s' => \
$::opt_save_outdir
,
185 'D|subdir' => \
$::opt_extract_subdir
,
186 '0|null' => \
$::opt_null
,
190 if ($::opt_cmd_version
) {
191 print $::PACKAGE
.' '.$::VERSION
."\
192 Copyright (C) 2011 Oskar Liljeblad\
193 This is free software. You may redistribute copies of it under the terms of
194 the GNU General Public License <http://www.gnu.org/licenses/gpl.html>.
195 There is NO WARRANTY, to the extent permitted by law.
197 Written by Oskar Liljeblad.\n";
202 if ($::opt_cmd_help
) {
204 Usage
: $::PROGRAM
[OPTION
]... ARCHIVE
[FILE
]...
205 $::PROGRAM
-e
[OPTION
]... [ARCHIVE
]...
206 Manage file archives of various types
.
209 -l
, --list list files
in archive
(als
)
210 -x
, --extract extract files from archive
(aunpack
)
211 -X
, --extract
-to
=PATH extract archive to specified directory
212 -a
, --add create archive
(apack
)
213 -c
, --cat extract file to standard out
(acat
)
214 -d
, --diff generate a diff between two archives
(adiff
)
215 -r
, --repack repack archives to a different format
(arepack
)
216 --help display this help
and exit
217 --version output version information
and exit
220 -e
, --each execute command above
for each file specified
221 -F
, --format
=EXT override archive format
(see below
)
222 -O
, --format
-option
=OPT give specific options to the archiver
223 -D
, --subdir always create subdirectory
when extracting
224 -f
, --force allow overwriting of
local files
225 -q
, --quiet decrease verbosity level by one
226 -v
, --verbose increase verbosity level by one
227 -V
, --verbosity
=LEVEL specify verbosity
(0, 1 or 2)
228 -p
, --page
send output through pager
229 -0, --null filenames from standard
in are null
-byte separated
230 -E
, --explain explain what is being done by
$::PROGRAM
231 -S
, --simulate simulation mode
- no filesystem changes are made
232 -o
, --option
=KEY
=VALUE override a configuration option
233 --config
=FILE load configuration defaults from file
235 Archive format
(for --format
) may be specified either as a
236 file extension
("tar.gz") or as
"tar+gzip".
238 Report bugs to Oskar Liljeblad
<$::BUG_EMAIL
>.
243 # Read configuration files
244 if (defined $::opt_config
) {
245 readconfig
($::opt_config
, 0);
247 readconfig
($::cfg_path_syscfg
, 1);
248 if ($::cfg_path_usercfg
!~ /^\//) {
249 readconfig
(File
::Spec
->catfile($ENV{HOME
}, $::cfg_path_usercfg
), 1);
251 readconfig
($::cfg_path_usercfg
, 1);
254 foreach my $opt (@
::opt_options
) {
255 my ($var,$val) = ($opt =~ /^([^=]+)=(.*)$/);
256 die "$::basename: invalid value for --option: $opt\n" if !defined $val;
257 set_config_option
($var, $val, '');
260 # Verify option integrity
261 $::opt_verbosity
+= $::cfg_default_verbosity
;
262 if ($::opt_explain
&& $::opt_simulate
) {
263 die "$::basename: --explain and --simulate options are mutually exclusive\n"; #OK
266 my $mode = getmode
();
268 if (defined $::opt_save_outdir
&& $mode eq 'extract-to') {
269 die "$::basename: --save-outdir cannot be used in extract-to mode\n";
271 if ($::opt_extract_subdir
&& $mode ne 'extract') {
272 die "$::basename: --subdir can only be used in extract mode\n";
275 if ($mode eq 'diff') {
276 die "$::basename: missing archive argument\n" if (@ARGV < 2); #OK
277 my $use_pager = $::opt_use_pager
;
279 $::opt_use_pager
= 0;
281 my $outfile1 = makeoutdir
() || exit 1;
282 my $outfile2 = makeoutdir
() || exit 1;
283 $::opt_cmd_extract_to
= $outfile1;
284 $::opt_cmd_extract_to_type
= 'f';
285 exit 1 if (!runcmds
('extract-to', undef, $ARGV[0]));
286 $::opt_cmd_extract_to
= $outfile2;
287 $::opt_cmd_extract_to_type
= 'f';
288 exit 1 if (!runcmds
('extract-to', undef, $ARGV[1]));
290 my $match1 = find_comparable_file
($outfile1);
291 my $match2 = find_comparable_file
($outfile2);
293 my @cmd = ($::cfg_path_diff
, split(/ /, $::cfg_args_diff
), $match1, $match2);
294 push @cmd, ['|'], get_pager_program
() if $use_pager;
295 my $allok = cmdexec
(1, @cmd);
297 foreach my $file ($outfile1,$outfile2) {
298 warn 'rm -r ',quote
($file),"\n" if $::opt_simulate
;
299 if (-e
$file && -d
$file) {
301 #print "$::basename: remove `$file'? ";
302 #select((select(STDOUT), $| = 1)[0]);
304 #if (defined $line && $line =~ /^y/) {
306 warn 'rm -r ',quote
($file),"\n" if $::opt_explain
;
307 unlink_directory
($file) if !$::opt_simulate
;
315 exit ($allok ?
0 : 1);
317 elsif ($mode eq 'repack') {
320 if (!defined $::opt_format
) {
321 die "$::basename: specify a format with -F when using --each in repack mode\n";
323 my $fmt2 = findformat
($::opt_format
, 1);
324 exit 1 if !defined $fmt2; # OK
325 for (my $c = 0; $c < @ARGV; $c++) {
326 my $fmt1 = findformat
($ARGV[$c], 0);
327 next if !defined $fmt1;
328 if (!issingleformat
($fmt1) && issingleformat
($fmt2)) {
329 warn "$::basename: format $fmt1 is cannot be repacked into format $fmt2\n";
330 warn "skipping ", quote
($ARGV[$c]), "\n";
333 if ($fmt1 eq $fmt2) {
334 warn "$::basename: will not repack to same archive type\n";
335 warn "skipping ", quote
($ARGV[$c]), "\n";
338 my $newname = stripext
($ARGV[$c]).formatext
($fmt2);
340 warn "$::basename: ".quote
($newname).": destination file exists\n";
341 warn "skipping ", quote
($ARGV[$c]), "\n";
344 repack_archive
($ARGV[$c], $newname, $fmt1, $fmt2);
345 my $diff = $::opt_simulate ?
0 : (-s
$ARGV[$c]) - (-s
$newname);
347 if ($::opt_verbosity
>= 1) {
348 print quote
($newname), ': ',
349 ($diff >= 0 ?
'saved '.$diff : 'grew '.-$diff),' ',
350 ($diff == 1 ?
'byte':'bytes'), "\n";
353 if ($::opt_verbosity
>= 1) {
354 print $totaldiff >= 0 ?
'saved '.$totaldiff : 'grew '.-$totaldiff, ' ',
355 $totaldiff == 1 ?
'byte':'bytes', " in total\n";
358 die "$::basename: missing archive arguments\n" if @ARGV < 1; #OK
359 die "$::basename: missing archive argument\n" if @ARGV < 2; #OK
360 die "$::basename: will not repack to same archive file\n"
361 if ($ARGV[0] eq $ARGV[1] || File
::Spec
->canonpath($ARGV[0]) eq File
::Spec
->canonpath($ARGV[1]));
362 die "$::basename: ".quote
($ARGV[1]).": destination file exists\n" if -e
$ARGV[1];
363 my $fmt1 = findformat
($ARGV[0], 0);
364 my $fmt2 = findformat
($ARGV[1], 0);
365 exit 1 if !defined $fmt1 || !defined $fmt2; # OK
366 die "$::basename: format $fmt1 is cannot be repacked into format $fmt1\n"
367 if (!issingleformat
($fmt1) && issingleformat
($fmt2));
368 die "$::basename: will not repack to same archive type\n" if $fmt1 eq $fmt2;
369 repack_archive
($ARGV[0], $ARGV[1], $fmt1, $fmt2);
370 my $diff = ($::opt_simulate ?
0 : (-s
$ARGV[0]) - (-s
$ARGV[1]));
371 if ($::opt_verbosity
>= 1) {
372 print quote
($ARGV[1]), ': ',
373 ($diff >= 0 ?
'saved '.$diff : 'grew '.-$diff),' ',
374 ($diff == 1 ?
'byte':'bytes'), "\n";
378 elsif ($::opt_each
) {
380 if ($mode eq 'cat') {
381 die "$::basename: --each can not be used with cat or add command\n"; #OK
383 if ($mode eq 'add') {
384 if (!defined $::opt_format
) {
385 die "$::basename: specify a format with -F when using --each in add mode\n";
387 my $format = findformat
($::opt_format
, 1);
388 exit 1 if !defined $format;
389 for (my $c = 0; $c < @ARGV; $c++) {
390 my $archive = File
::Spec
->canonpath($ARGV[$c]) . formatext
($format);
391 warn quote
($archive).":\n" if $::opt_verbosity
> 1;
392 runcmds
('add', $format, $archive, $ARGV[$c]) or $allok = 0;
395 for (my $c = 0; $c < @ARGV; $c++) {
396 warn quote
($ARGV[$c]).":\n" if $::opt_verbosity
> 1;
397 runcmds
($mode, undef, $ARGV[$c]) or $allok = 0;
400 exit ($allok ?
0 : 1);
403 die "$::basename: missing archive argument\n" if (@ARGV == 0); #OK
404 runcmds
($mode, undef, shift @ARGV, @ARGV) || exit 1;
407 # runcmds(mode, format, archive, args)
408 # Execute an atool command. This is where it all happens.
409 # If mode is 'extract', returns the directory (or only file)
410 # which was extracted.
411 # If forceformat is undef, the format will be detected from
412 # $::opt_format or the filename.
414 my ($mode, $format, $archive, @args) = @_;
416 if (!defined $format) {
417 if (defined $::opt_format
) {
418 $format = findformat
($::opt_format
, 1);
420 $format = findformat
($archive, 0);
422 return undef if !defined $format;
427 if ($format eq 'tar+bzip2') {
428 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
429 if ($::cfg_use_tar_bzip2_option
) {
430 push @cmd, maketarcmd
($archive, $outdir, $mode, 'f', '--bzip2'), @args;
431 } elsif ($::cfg_use_pbzip2
) {
432 push @cmd, $::cfg_path_pbzip2
, '-cd', $archive, ['|'] if $mode ne 'add';
433 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
434 push @cmd, ['|'], $::cfg_path_pbzip2
, '-c', ['>'], $archive if $mode eq 'add';
435 #if ($mode eq 'add') {
436 # Unfortunately pbzip2 cannot read from standard in
437 # 2012-03-15: It seems now it does.
438 # my $tmpname = makeoutfile($::cfg_tmpfile_name);
439 # push @cmd, maketarcmd($tmpname, $outdir, $mode, 'f'), @args;
440 # push @cmd, [';'], $::cfg_path_pbzip2, '-c', $tmpname, ['>'], $archive;
441 # push @cmd, [';'], 'rm', $tmpname;
443 # push @cmd, $::cfg_path_pbzip2, '-cd', $archive, ['|'];
444 # push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
446 } elsif ($::cfg_use_lbzip2
) {
447 push @cmd, $::cfg_path_lbzip2
, '-cd', $archive, ['|'] if $mode ne 'add';
448 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
449 push @cmd, ['|'], $::cfg_path_lbzip2
, '-c', ['>'], $archive if $mode eq 'add';
451 push @cmd, $::cfg_path_bzip2
, '-cd', $archive, ['|'] if $mode ne 'add';
452 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
453 push @cmd, ['|'], $::cfg_path_bzip2
, '-c', ['>'], $archive if $mode eq 'add';
455 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
456 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
458 elsif ($format eq 'tar+gzip') {
459 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
460 if ($::cfg_use_tar_z_option
) {
461 push @cmd, maketarcmd
($archive, $outdir, $mode, 'zf'), @args;
462 } elsif ($::cfg_use_pigz
) {
463 push @cmd, $::cfg_path_pigz
, '-cd', $archive, ['|'] if $mode ne 'add';
464 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
465 push @cmd, ['|'], $::cfg_path_pigz
, '-c', ['>'], $archive if $mode eq 'add';
467 push @cmd, $::cfg_path_gzip
, '-cd', $archive, ['|'] if $mode ne 'add';
468 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
469 push @cmd, ['|'], $::cfg_path_gzip
, '-c', ['>'], $archive if $mode eq 'add';
471 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
472 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
474 elsif ($format eq 'tar+bzip') {
475 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
476 push @cmd, $::cfg_path_bzip
, '-cd', $archive, ['|'] if $mode ne 'add';
477 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
478 push @cmd, ['|'], $::cfg_path_bzip
, '-c', ['>'], $archive if $mode eq 'add';
479 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
480 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
482 elsif ($format eq 'tar+compress') {
483 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
484 if ($::cfg_use_gzip_for_z
) {
485 push @cmd, $::cfg_path_gzip
, '-cd', $archive, ['|'] if $mode ne 'add';
487 push @cmd, $::cfg_path_compress
, '-cd', $archive, ['|'] if $mode ne 'add';
489 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
490 push @cmd, ['|'], $::cfg_path_compress
, '-c', ['>'], $archive if $mode eq 'add';
491 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
492 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
494 elsif ($format eq 'tar+lzop') {
495 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
496 if ($::cfg_use_tar_lzop_option
) {
497 push @cmd, maketarcmd
($archive, $outdir, $mode, 'f', '--lzop'), @args;
499 push @cmd, $::cfg_path_lzop
, '-cd', $archive, ['|'] if $mode ne 'add';
500 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
501 push @cmd, ['|'], $::cfg_path_lzop
, '-c', ['>'], $archive if $mode eq 'add';
503 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
504 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
506 elsif ($format eq 'tar+lzip') {
507 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
508 if ($::cfg_use_tar_lzip_option
) {
509 push @cmd, maketarcmd
($archive, $outdir, $mode, 'f', '--lzip'), @args;
510 } elsif ($::cfg_use_plzip
) {
511 push @cmd, $::cfg_path_plzip
, '-cd', $archive, ['|'] if $mode ne 'add';
512 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
513 push @cmd, ['|'], $::cfg_path_plzip
, '-c', ['>'], $archive if $mode eq 'add';
515 push @cmd, $::cfg_path_lzip
, '-cd', $archive, ['|'] if $mode ne 'add';
516 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
517 push @cmd, ['|'], $::cfg_path_lzip
, '-c', ['>'], $archive if $mode eq 'add';
519 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
520 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
522 elsif ($format eq 'tar+xz') {
523 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
524 if ($::cfg_use_tar_xz_option
) {
525 push @cmd, maketarcmd
($archive, $outdir, $mode, 'f', '--xz'), @args;
527 push @cmd, $::cfg_path_xz
, '-cd', $archive, ['|'] if $mode ne 'add';
528 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
529 push @cmd, ['|'], $::cfg_path_xz
, '-c', ['>'], $archive if $mode eq 'add';
531 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
532 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
534 elsif ($format eq 'tar+7z') {
535 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
536 push @cmd, $::cfg_path_7z
, 'x', '-so', $archive, ['|'] if $mode ne 'add';
537 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
538 push @cmd, ['|'], $::cfg_path_7z
, 'a', '-si', $archive if $mode eq 'add';
539 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
540 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
542 elsif ($format eq 'tar+lzma') {
543 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
544 if ($::cfg_use_tar_lzma_option
) {
545 push @cmd, maketarcmd
($archive, $outdir, $mode, 'f', '--lzma'), @args;
547 push @cmd, $::cfg_path_lzma
, '-cd', $archive, ['|'] if $mode ne 'add';
548 push @cmd, maketarcmd
('-', $outdir, $mode, 'f'), @args;
549 push @cmd, ['|'], $::cfg_path_lzma
, '-c', ['>'], $archive if $mode eq 'add';
551 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
552 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
554 elsif ($format eq 'tar') {
555 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
556 push @cmd, maketarcmd
($archive, $outdir, $mode, 'f'), @args;
557 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
558 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
560 elsif ($format eq 'jar' && $::cfg_use_jar
) {
561 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
563 if ($mode eq 'add') {
564 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
567 $opts .= 'v' if $::opt_verbosity
>= 1;
568 push @cmd, $::cfg_path_jar
;
569 push @cmd, "x$opts", '-C', $outdir if $mode eq 'extract';
570 push @cmd, "x$opts", '-C', $::opt_cmd_extract_to
if $mode eq 'extract-to';
571 push @cmd, "t$opts" if $mode eq 'list';
572 push @cmd, "c$opts" if $mode eq 'add';
573 push @cmd, $archive, @args;
574 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
575 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
577 elsif ($format eq 'jar' || $format eq 'zip') {
578 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
579 if ($mode eq 'add') {
580 push @cmd, $::cfg_path_zip
, '-r';
582 push @cmd, $::cfg_path_unzip
;
583 push @cmd, '-p' if $mode eq 'cat';
584 push @cmd, '-l' if $mode eq 'list';
585 push @cmd, '-d', $outdir if $mode eq 'extract';
586 push @cmd, '-d', $::opt_cmd_extract_to
if $mode eq 'extract-to';
588 push @cmd, '-v' if $::opt_verbosity
> 1;
589 push @cmd, '-qq' if $::opt_verbosity
< 0;
590 push @cmd, '-q' if $::opt_verbosity
== 0;
591 push @cmd, $archive, @args;
592 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
593 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
595 elsif ($format eq 'rar') {
596 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
597 if ($mode eq 'add' || $::cfg_use_rar_for_unpack
) {
598 push @cmd, $::cfg_path_rar
;
600 push @cmd, $::cfg_path_unrar
;
602 push @cmd, 'a' if $mode eq 'add';
603 push @cmd, 'vt' if $mode eq 'list' && $::opt_verbosity
>= 3;
604 push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity
== 2;
605 push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity
<= 1;
606 push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
607 push @cmd, '-ierr', 'p' if $mode eq 'cat';
608 push @cmd, '-r0' if ($mode eq 'add');
609 push @cmd, $archive, @args;
610 push @cmd, tailslash
($outdir) if $mode eq 'extract';
611 push @cmd, tailslash
($::opt_cmd_extract_to
) if $mode eq 'extract-to';
612 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
613 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
615 elsif ($format eq '7z') {
616 # 7z has the -so option for writing data to stdout, but it doesn't
617 # write data to terminal even if the file is designed to be
618 # read in a terminal...
619 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
620 #if ($mode eq 'cat') {
621 # warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
624 push @cmd, $::cfg_path_7z
;
625 push @cmd, 'a' if $mode eq 'add';
626 push @cmd, 'l' if $mode eq 'list';
627 push @cmd, 'x', '-so' if $mode eq 'cat';
628 push @cmd, 'x', '-o'.$outdir if $mode eq 'extract';
629 push @cmd, 'x', '-o'.$::opt_cmd_extract_to
if $mode eq 'extract-to';
630 push @cmd, @
::opt_format_options
, $archive, @args;
631 return multiarchivecmd
($archive, $outdir, $mode, 1, 0, \
@args, @cmd);
633 elsif ($format eq 'cab') {
634 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
635 if ($mode eq 'add') {
636 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
639 push @cmd, $::cfg_path_cabextract
;
640 push @cmd, '--single';
641 push @cmd, '--directory', $outdir if $mode eq 'extract';
642 push @cmd, '--directory', $::opt_cmd_extract_to
if $mode eq 'extract-to';
643 push @cmd, '--pipe' if $mode eq 'cat';
644 push @cmd, '--list' if $mode eq 'list';
646 push @cmd, '--filter';
648 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
650 elsif ($format eq 'alzip') {
651 if ($mode eq 'cat' || $mode eq 'add' || $mode eq 'list') {
652 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
655 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
656 push @cmd, $::cfg_path_unalz
;
658 push @cmd, $outdir if $mode eq 'extract';
659 push @cmd, $::opt_cmd_extract_to
if $mode eq 'extract-to';
660 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
662 elsif ($format eq 'lha') {
663 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
664 push @cmd, $::cfg_path_lha
;
665 push @cmd, 'a' if $mode eq 'add';
666 push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity
>= 3;
667 push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity
== 2;
668 push @cmd, 'lq' if $mode eq 'list' && $::opt_verbosity
<= 1;
669 push @cmd, 'xw='.tailslash
($outdir) if $mode eq 'extract';
670 push @cmd, 'xw='.tailslash
($::opt_cmd_extract_to
) if $mode eq 'extract-to';
671 push @cmd, 'p' if $mode eq 'cat';
672 push @cmd, $archive, @args;
673 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
674 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
676 elsif ($format eq 'ace') {
677 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
678 push @cmd, $::cfg_path_unace
;
679 if ($mode eq 'add' || $mode eq 'cat') {
680 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
683 push @cmd, 'v', '-c' if $mode eq 'list' && $::opt_verbosity
>= 3;
684 push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity
== 2;
685 push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity
<= 1;
686 push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
687 push @cmd, $archive, @args;
688 push @cmd, tailslash
($outdir) if $mode eq 'extract';
689 push @cmd, tailslash
($::opt_cmd_extract_to
) if $mode eq 'extract-to';
690 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
691 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
693 elsif ($format eq 'arj') {
694 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
695 if ($mode eq 'cat') {
696 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
699 if ($mode eq 'add' || $::cfg_use_arj_for_unpack
) {
700 push @cmd, $::cfg_path_arj
;
701 push @cmd, 'a' if $mode eq 'add';
702 push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity
== 2;
703 push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity
<= 1;
704 push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
705 push @cmd, $archive, @args;
706 push @cmd, tailslash
($outdir) if $mode eq 'extract';
707 push @cmd, tailslash
($::opt_cmd_extract_to
) if $mode eq 'extract-to';
708 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
709 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
711 push @cmd, $::cfg_path_unarj
;
712 # XXX: cat mode might work for arj archives, but it extract to stderr!
713 push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity
== 2;
714 push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity
<= 1;
715 push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
716 push @cmd, $archive if ($mode ne 'extract' && $mode ne 'extract-to');;
717 # we call makeabsolute here because needcwd=1 to the multiarchivecmd call
718 push @cmd, makeabsolute
($archive) if ($mode eq 'extract' || $mode eq 'extract-to');
720 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
721 return multiarchivecmd
($archive, $outdir, $mode, 0, 1, \
@args, @cmd);
724 elsif ($format eq 'arc') {
725 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
726 if ($mode eq 'add' || $::cfg_use_arc_for_unpack
) {
727 push @cmd, $::cfg_path_arc
;
728 push @cmd, 'a' if $mode eq 'add';
729 push @cmd, 'v' if $mode eq 'list' && $::opt_verbosity
>= 3;
730 push @cmd, 'l' if $mode eq 'list' && $::opt_verbosity
== 2;
731 push @cmd, 'ln' if $mode eq 'list' && $::opt_verbosity
<= 1;
732 push @cmd, 'x' if ($mode eq 'extract' || $mode eq 'extract-to');
733 push @cmd, 'p' if $mode eq 'cat';
735 push @cmd, $::cfg_path_nomarch
;
736 push @cmd, '-lvU' if $mode eq 'list' && $::opt_verbosity
>= 2;
737 push @cmd, '-lU' if $mode eq 'list' && $::opt_verbosity
<= 1;
738 push @cmd, '-p' if $mode eq 'cat';
740 push @cmd, $archive if ($mode ne 'extract' && $mode ne 'extract-to');
741 # we call makeabsolute here because needcwd=1 to the multiarchivecmd call
742 push @cmd, makeabsolute
($archive) if ($mode eq 'extract' || $mode eq 'extract-to');
744 @cmd = handle_empty_add
(@cmd) if ($mode eq 'add' && @args == 0);
745 return multiarchivecmd
($archive, $outdir, $mode, 0, 1, \
@args, @cmd);
747 elsif ($format eq 'rpm') {
748 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
749 if ($mode eq 'list') {
750 push @cmd, $::cfg_path_rpm
;
752 push @cmd, '-v' if $::opt_verbosity
>= 1;
753 push @cmd, $archive, @args;
754 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
756 elsif ($mode eq 'extract' || $mode eq 'extract-to') {
757 push @cmd, $::cfg_path_rpm2cpio
;
758 push @cmd, makeabsolute
($archive);
760 push @cmd, $::cfg_path_cpio
, '-imd', '--quiet', @args;
761 return multiarchivecmd
($archive, $outdir, $mode, 0, 1, \
@args, @cmd);
764 # FIXME: I guess cat could work too, but it would require that we
765 # extracted to a temporary dir, read and printed it, then removed it.
766 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
770 elsif ($format eq 'deb') {
771 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
772 if ($mode eq 'cat') {
773 push @cmd, $::cfg_path_dpkg_deb
, '--fsys-tarfile', makeabsolute
($archive), ['|'];
774 push @cmd, $::cfg_path_tar
, '-xO', @args;
775 } elsif ($mode eq 'list' || $mode eq 'extract' || $mode eq 'extract-to') {
776 push @cmd, $::cfg_path_dpkg_deb
;
777 push @cmd, '--contents' if $mode eq 'list';
778 if ($mode eq 'extract' || $mode eq 'extract-to') {
779 push @cmd, '--extract' if $::opt_verbosity
<= 0;
780 push @cmd, '--vextract' if $::opt_verbosity
> 0;
783 push @cmd, $outdir if $mode eq 'extract';
784 push @cmd, $::opt_cmd_extract_to
if $mode eq 'extract-to';
786 if ($::cfg_extract_deb_control
&& ($mode eq 'extract' || $mode eq 'extract-to')) {
788 push @cmd, $::cfg_path_dpkg_deb
;
789 push @cmd, '--control';
791 push @cmd, File
::Spec
->catdir($outdir, 'DEBIAN') if $mode eq 'extract';
792 push @cmd, File
::Spec
->catdir($::opt_cmd_extract_to
, 'DEBIAN') if $mode eq 'extract-to';
795 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
797 elsif ($format eq 'ar') {
798 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
799 my $v = ($::opt_verbosity
>= 1 ?
'v' : '');
800 push @cmd, $::cfg_path_ar
;
801 push @cmd, 'rc'.$v if $mode eq 'add';
802 push @cmd, 'x'.$v if ($mode eq 'extract' || $mode eq 'extract-to');
803 push @cmd, 't'.$v if $mode eq 'list';
804 # Don't use v(erbose) with cat command because ar would add "\n<member data>\n\n" to output
805 push @cmd, 'p' if $mode eq 'cat';
806 push @cmd, makeabsolute
($archive), @args;
807 return multiarchivecmd
($archive, $outdir, $mode, 1, 1, \
@args, @cmd);
809 elsif ($format eq 'cpio') {
810 return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir
()));
811 if ($mode eq 'list') {
812 push @cmd, $::cfg_path_cat
, $archive, ['|'];
813 push @cmd, $::cfg_path_cpio
, '-t';
814 push @cmd, '-v' if $::opt_verbosity
>= 1;
815 return multiarchivecmd
($archive, $outdir, $mode, 0, 0, \
@args, @cmd);
817 elsif ($mode eq 'extract' || $mode eq 'extract-to') {
818 push @cmd, $::cfg_path_cat
, makeabsolute
($archive), ['|'];
819 push @cmd, $::cfg_path_cpio
, '-i';
820 push @cmd, '-v' if $::opt_verbosity
>= 1;
821 return multiarchivecmd
($archive, $outdir, $mode, 0, 1, \
@args, @cmd);
823 elsif ($mode eq 'add') {
825 push @cmd, $::cfg_path_cpio
;
826 push @cmd, '-0' if $::opt_null
;
828 push @cmd, '-v' if $::opt_verbosity
>= 1;
829 push @cmd, ['>'], $archive;
831 push @cmd, $::cfg_path_find
, @args;
832 push @cmd, '-print0' if $::cfg_use_find_cpio_print0
;
833 push @cmd, ['|'], $::cfg_path_cpio
;
834 push @cmd, '-0' if $::cfg_use_find_cpio_print0
;
836 push @cmd, '-v' if $::opt_verbosity
>= 1;
837 push @cmd, ['>'], $archive;
839 return multiarchivecmd
($archive, $outdir, $mode, 1, 1, \
@args, @cmd);
842 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
846 elsif ($format eq 'bzip2') {
847 return singlearchivecmd
($archive, $::cfg_path_pbzip2
, $format, $mode, 1, @args) if $::cfg_use_pbzip2
;
848 return singlearchivecmd
($archive, $::cfg_path_lbzip2
, $format, $mode, 1, @args) if $::cfg_use_lbzip2
;
849 return singlearchivecmd
($archive, $::cfg_path_bzip2
, $format, $mode, 1, @args);
851 elsif ($format eq 'bzip') {
852 return singlearchivecmd
($archive, $::cfg_path_bzip
, $format, $mode, 1, @args);
854 elsif ($format eq 'gzip') {
855 return singlearchivecmd
($archive, $::cfg_use_pigz ?
$::cfg_path_pigz
: $::cfg_path_gzip
, $format, $mode, 1, @args);
857 elsif ($format eq 'compress') {
858 if ($::cfg_use_gzip_for_z
&& $mode ne 'add') {
859 return singlearchivecmd
($archive, $::cfg_path_gzip
, $format, $mode, 1, @args);
861 return singlearchivecmd
($archive, $::cfg_path_compress
, $format, $mode, 1, @args);
864 elsif ($format eq 'lzma') {
865 return singlearchivecmd
($archive, $::cfg_path_lzma
, $format, $mode, 1, @args);
867 elsif ($format eq 'lzop') {
868 return singlearchivecmd
($archive, $::cfg_path_lzop
, $format, $mode, 0, @args);
870 elsif ($format eq 'lzip') {
871 return singlearchivecmd
($archive, $::cfg_use_plzip ?
$::cfg_path_plzip
: $::cfg_path_lzip
, $format, $mode, 1, @args);
873 elsif ($format eq 'xz') {
874 return singlearchivecmd
($archive, $::cfg_path_xz
, $format, $mode, 1, @args);
876 elsif ($format eq 'rzip') {
877 return singlearchivecmd
($archive, $::cfg_path_rzip
, $format, $mode, 0, @args);
879 elsif ($format eq 'lrzip') {
880 return singlearchivecmd
($archive, $::cfg_path_lrzip
, $format, $mode, 0, @args);
887 # Return 1 if value defined and is non-zero, 0 otherwise.
890 return defined $value && $value ?
1 : 0;
894 # Identify the execution mode, and return it.
895 # Possible modes are 'cat', 'extract', 'list', 'add' or 'extract-to'.
898 if (de
($::opt_cmd_list
)
900 + de
($::opt_cmd_extract
)
902 + de
($::opt_cmd_extract_to
)
903 + de
($::opt_cmd_diff
)
904 + de
($::opt_cmd_repack
) > 1) {
905 die "$::basename: only one command may be specified\n"; #OK
907 $mode = 'cat' if ($::basename
eq 'acat');
908 $mode = 'extract' if ($::basename
eq 'aunpack');
909 $mode = 'list' if ($::basename
eq 'als');
910 $mode = 'add' if ($::basename
eq 'apack');
911 $mode = 'diff' if ($::basename
eq 'adiff');
912 $mode = 'repack' if ($::basename
eq 'arepack');
913 $mode = 'add' if ($::opt_cmd_add
);
914 $mode = 'cat' if ($::opt_cmd_cat
);
915 $mode = 'list' if ($::opt_cmd_list
);
916 $mode = 'extract' if ($::opt_cmd_extract
);
917 $mode = 'extract-to' if ($::opt_cmd_extract_to
);
918 $mode = 'diff' if ($::opt_cmd_diff
);
919 $mode = 'repack' if ($::opt_cmd_repack
);
920 if (!defined $mode) {
921 die "$::basename: no command specified\nTry `$::basename --help' for more information.\n"; #OK
926 # singlearchivecmd(archive, command, format, mode, args)
927 # Execute a command for single-file archives.
928 # The command parameter specifies what command to execute.
929 # If mode is 'extract-to', returns the directory (or only file)
930 # which was extracted.
931 sub singlearchivecmd
($$$$$@
) {
932 my ($archive, $cmd, $format, $mode, $can_do_c, @args) = @_;
937 push @cmd, '-v' if $::opt_verbosity
> 1;
939 if ($mode eq 'list') {
940 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
943 elsif ($mode eq 'cat') {
945 warn "$::basename: ".quote
($archive).": $mode command not supported for $format archives\n";
948 push @cmd, '-c', '-d', $archive, @args;
949 $outfile = $archive; # Just so that we don't return undef
951 elsif ($mode eq 'add') {
953 warn "$::basename: cannot add more than one file with this format\n";
956 if (!$::opt_force
&& (-e
$archive || -l
$archive)) {
957 warn "$::basename: ".quote
($archive).": refusing to overwrite existing file\n";
960 #if (!$::cfg_keep_compressed && stripext($archive) ne $args[0]) {
961 # warn "$::basename: ".quote($archive).": cannot create a $format archive with this name (use -X)\n";
965 push @cmd, '-c', @args, ['>'], $archive;
967 push @cmd, '-o', $archive, @args;
969 $outfile = $archive; # Just so that we don't return undef
971 elsif ($mode eq 'extract') {
972 $outfile = stripext
($archive);
973 if ($::cfg_decompress_to_cwd
) {
974 $outfile = basename
($outfile);
977 $outfile = makeoutfile
($::cfg_tmpdir_name
);
978 $reason = 'local file exists';
981 push @cmd, '-c', '-d', $archive, @args, ['>'], $outfile;
983 push @cmd, '-o', $outfile, '-d', $archive, @args;
986 elsif ($mode eq 'extract-to') {
987 $outfile = $::opt_cmd_extract_to
;
988 if ($::opt_simulate ?
$::opt_cmd_extract_to_type
eq 'd' : -d
$outfile) {
989 my $base = File
::Basename
::basename
($archive);
990 $outfile = File
::Spec
->catfile($outfile, stripext
($base));
993 push @cmd, '-c', '-d', $archive, @args, ['>'], $outfile;
995 push @cmd, '-o', $outfile, '-d', $archive, @args;
999 push @cmd, ['|'], get_pager_program
() if $::opt_use_pager
;
1000 cmdexec
(0, @cmd) || return undef;
1002 if ($mode eq 'extract' || $mode eq 'extract-to') {
1003 if ($::cfg_show_extracted
&& !$::opt_simulate
) {
1004 my $archivebase = File
::Basename
::basename
($archive);
1005 my $rmsg = defined $reason ?
" ($reason)" : '';
1006 warn quote
($archivebase).": extracted to `".quote
($outfile)."'$rmsg\n";
1010 if (!$::cfg_keep_compressed
) {
1011 if ($mode eq 'extract') {
1012 warn 'unlink ', quote
($archive), "\n" if ($::opt_explain
|| $::opt_simulate
);
1013 if (!$::opt_simulate
) {
1014 unlink($archive) || warn "$::basename: ".quote
($archive).": cannot remove - $!\n";
1017 elsif ($mode eq 'add') {
1018 warn 'unlink ', quote
($args[0]), "\n" if ($::opt_explain
|| $::opt_simulate
);
1019 if (!$::opt_simulate
) {
1020 unlink($args[0]) || warn "$::basename: ".quote
($args[0]).": cannot remove - $!\n";
1029 # Create (partial) command line arguments for a tar command.
1030 # The parameter opts specifies additional arguments to add.
1031 sub maketarcmd
($$$$@
) {
1032 my ($archive, $outdir, $mode, $opts, @rest) = @_;
1033 $opts = 'v'.$opts if $::opt_verbosity
>= 1;
1034 my @cmd = ($::cfg_path_tar
);
1035 push @cmd, "xO$opts" if $mode eq 'cat';
1036 push @cmd, "x$opts" if ($mode eq 'extract' || $mode eq 'extract-to');
1037 push @cmd, "t$opts" if $mode eq 'list';
1038 push @cmd, "c$opts" if $mode eq 'add';
1039 push @cmd, $archive if defined $archive;
1040 push @cmd, '-C', $outdir if $mode eq 'extract';
1041 push @cmd, '-C', $::opt_cmd_extract_to
if $mode eq 'extract-to';
1046 # cmdexec(ignore_return, cmdspec)
1047 # Execute a command specification.
1048 # The cmdspec parameter is a list of string arguments building
1049 # the command line. If there's a list reference instead of a
1050 # string, it is a shell meta character/string which shouldn't
1053 my ($ignret, @cmd) = @_;
1055 if ($::opt_explain
|| $::opt_simulate
) {
1056 my $spec = join(' ', map { ref $_ ? @
{$_} : shquotemeta
$_ } @cmd);
1057 explain quote
($spec)."\n";
1058 return 1 if ($::opt_simulate
);
1061 my $cmds = makespec
(@cmd);
1062 if (!shell_execute
(@cmd)) {
1063 warn "$::basename: ".quote
($cmds).": cannot execute - $::errmsg\n";
1067 if ($?
& 0xFF != 0) {
1068 warn "$::basename: ".quote
($cmds).": abnormal exit (exit code $?)\n";
1072 if (!$ignret && $?
>> 8 != 0) {
1073 warn "$::basename: ".quote
($cmds).": non-zero return-code\n";
1081 # Make a command specification when printing errors.
1084 my $spec = $cmd[0].' ...';
1086 foreach (@cmd, '') {
1088 $spec .= " | $_ ...";
1091 $lastref = 1 if (ref);
1096 # makeoutfile(template)
1097 # Make a unique output file for extraction command.
1098 sub makeoutfile
($) {
1099 my ($template) = @_;
1102 $file = sprintf $template, int rand 10000;
1108 # Make a temporary (unique) output directory for extraction command.
1112 $dir = sprintf $::cfg_tmpdir_name
, int rand 10000;
1115 warn 'mkdir ', $dir, "\n" if $::opt_simulate
|| $::opt_explain
;
1116 if (!$::opt_simulate
) {
1117 if (!mkdir($dir, 0700)) {
1118 warn "$::basename: ".quote
($dir).": cannot create directory - $!\n";
1121 push @
::rmdirs
, $dir;
1127 # Print on screen if $::opt_explain is true.
1130 print STDERR
$msg if ($::opt_explain
|| $::opt_simulate
);
1134 # If specified filename does not end with a slash,
1135 # add one and return the new filename.
1138 return ($file =~ /\/$/ ? $file : "$file/");
1142 # A more sophisticated quotemeta for bourne shells.
1143 # (This should be used for printing only.)
1144 sub shquotemeta($) {
1146 $str =~ s/([^A-Za-z0-9_.+,\/:=@%^-])/\\$1/g;
1150 # multiarchivecmd(archive, outdir, mode, create, needcwd, argref, cmdspec)
1151 # Execute a command for multi-file archives.
1152 # The `create' argument controls whether the archive
1153 # will be created (1) or just added to (0) if mode is "add
".
1154 # If mode is 'extract', returns the directory (or only file)
1155 # which was extracted.
1156 # If needcwd is true, the outdir must be changed to.
1157 sub multiarchivecmd($$$$@) {
1158 my ($archive, $outdir, $mode, $create, $needcwd, $argref, @cmd) = @_;
1159 my @args = @{$argref};
1161 if ($mode eq 'cat' && @args == 0) {
1162 die "$::basename
: missing file argument
\n"; #OK
1165 if ($mode eq 'add' && $create && !$::opt_force && (-e $archive || -l $archive)) {
1166 warn "$::basename
: ".quote($archive).": refusing to overwrite existing file
\n";
1170 push @cmd, ['|'], get_pager_program() if $::opt_use_pager;
1175 if ($mode eq 'extract') {
1176 warn "cd
", quote($outdir), "\n" if $::opt_explain || $::opt_simulate;
1177 if (!$::opt_simulate && !chdir($outdir)) {
1178 warn "$::basename
: ".quote($outdir).": cannot change to
- $!\n";
1182 if ($mode eq 'extract-to') {
1183 warn "cd
", quote($::opt_cmd_extract_to), "\n" if $::opt_explain || $::opt_simulate;
1184 if (!$::opt_simulate && !chdir($::opt_cmd_extract_to)) {
1185 warn "$::basename
: ".quote($::opt_cmd_extract_to).": cannot change to
- $!\n";
1191 if ($mode ne 'extract') {
1192 cmdexec(0, @cmd) || return undef;
1193 if (defined $olddir) {
1194 warn "cd
", quote($olddir), "\n" if $::opt_explain || $::opt_simulate;
1195 if (!$::opt_simulate && !chdir($olddir)) {
1196 warn "$::basename
: ".quote($olddir).": cannot change to
- $!\n";
1200 # XXX: can't save outdir with extract-to.
1204 if (!cmdexec(0, @cmd)) {
1205 if (defined $olddir) {
1206 warn "cd
", quote($olddir), "\n" if $::opt_explain || $::opt_simulate;
1207 if (!$::opt_simulate && !chdir($olddir)) {
1208 warn "$::basename
: ".quote($olddir).": cannot change to
- $!\n";
1214 if (defined $olddir) {
1215 warn "cd
", quote($olddir), "\n" if $::opt_explain || $::opt_simulate;
1216 if (!$::opt_simulate && !chdir($olddir)) {
1217 warn "$::basename
: ".quote($olddir).": cannot change to
- $!\n";
1222 return undef if $::opt_simulate;
1224 if (!opendir(DIR, $outdir)) {
1225 warn "$::basename
: ".quote($outdir).": cannot list
- $!\n";
1228 my @files = grep !/^\.\.?$/, readdir DIR;
1231 my $archivebase = File::Basename::basename($archive);
1235 warn quote($archivebase).": archive is empty
\n";
1238 } elsif ($::opt_extract_subdir) {
1240 } elsif (@files == 1) {
1241 my $fromfile = File::Spec->catfile($outdir, $files[0]);
1242 if ($::opt_force || (!-l $files[0] && !-e $files[0])) {
1244 # If the file is a directory, it can only be moved if writable
1245 my $oldmode = undef;
1246 if (!-l $fromfile && -d $fromfile) {
1247 my @statinfo = stat($fromfile);
1249 warn quote($fromfile).": cannot get file info
- $!\n";
1252 $oldmode = $statinfo[2];
1253 if (!chmod(0700, $fromfile)) {
1254 warn quote($fromfile).": cannot change mode
- $!\n";
1259 if (!rename $fromfile, $files[0]) {
1260 warn quote($fromfile).": cannot
rename - $!\n";
1265 # If we changed mode previously, restore that mode now
1266 if (defined $oldmode) {
1267 if (!chmod($oldmode, $files[0])) {
1268 warn quote($files[0]).": cannot change mode
- $!\n";
1273 if ($::cfg_show_extracted) {
1274 my $file = ($files[0] =~ /\// ? dirname($files[0]) : $files[0]);
1275 warn quote($archivebase).": extracted to
`".quote($file)."'\n" ;
1278 save_outdir($files[0]);
1281 $reason = 'local file exists';
1282 $adddir = 1 if (!-l $files[0] && -d $files[0]);
1284 $reason = 'multiple files in root';
1287 my $localoutdir = stripext($archivebase);
1288 if (!-e $localoutdir) {
1289 if (!rename $outdir, $localoutdir) {
1290 warn quote($outdir).": cannot rename - $!\n";
1293 $outdir = $localoutdir;
1296 warn quote($archivebase).": extracted to `".quote($outdir)."' ($reason)\n";
1297 save_outdir($adddir ? File::Spec->catfile($outdir, $files[0]) : $outdir);
1302 # Strip extension from the specified file.
1305 return $file if ($file =~ s/(\.tar\.bz2|\.tbz2)$//);
1306 return $file if ($file =~ s/(\.tar\.bz|\.tbz)$//);
1307 return $file if ($file =~ s/(\.tar\.gz|\.tgz)$//);
1308 return $file if ($file =~ s/(\.tar\.Z|\.tZ)$//);
1309 return $file if ($file =~ s/(\.tar\.7z|\.t7z)$//);
1310 return $file if ($file =~ s/(\.tar\.lzma|\.tlzma)$//);
1311 return $file if ($file =~ s/(\.tar\.lzo|\.lzo)$//);
1312 return $file if ($file =~ s/(\.tar\.lz|\.lz)$//);
1313 return $file if ($file =~ s/\.tar$//);
1314 return $file if ($file =~ s/\.bz2$//);
1315 return $file if ($file =~ s/\.bz$//);
1316 return $file if ($file =~ s/\.lz$//);
1317 return $file if ($file =~ s/\.gz$//);
1318 return $file if ($file =~ s/\.zip$//);
1319 return $file if ($file =~ s/\.7z$//);
1320 return $file if ($file =~ s/\.alz$//);
1321 return $file if ($file =~ s/\.jar$//);
1322 return $file if ($file =~ s/\.war$//);
1323 return $file if ($file =~ s/\.Z$//);
1324 return $file if ($file =~ s/\.rar$//);
1325 return $file if ($file =~ s/\.(lha|lzh)$//);
1326 return $file if ($file =~ s/\.ace$//);
1327 return $file if ($file =~ s/\.arj$//);
1328 return $file if ($file =~ s/\.a$//);
1329 return $file if ($file =~ s/\.lzma$//);
1330 return $file if ($file =~ s/\.rpm$//);
1331 return $file if ($file =~ s/\.deb$//);
1332 return $file if ($file =~ s/\.cpio$//);
1333 return $file if ($file =~ s/\.cab$//);
1334 return $file if ($::cfg_strip_unknown_ext && $file =~ s/\.[^.]+$//);
1339 # Return the usual extension for the specified file format
1342 return '.tar
.bz2
' if $format eq 'tar
+bzip2
';
1343 return '.tar
.gz
' if $format eq 'tar
+gzip
';
1344 return '.tar
.bz
' if $format eq 'tar
+bzip
';
1345 return '.tar
.7z
' if $format eq 'tar
+7z
';
1346 return '.tar
.lzo
' if $format eq 'tar
+lzop
';
1347 return '.tar
.lzma
' if $format eq 'tar
+lzma
';
1348 return '.tar
.lz
' if $format eq 'tar
+lzip
';
1349 return '.tar
.xz
' if $format eq 'tar
+xz
';
1350 return '.tar
.Z
' if $format eq 'tar
+compress
';
1351 return '.tar
' if $format eq 'tar
';
1352 return '.bz2
' if $format eq 'bzip2
';
1353 return '.lzma
' if $format eq 'lzma
';
1354 return '.7z
' if $format eq '7z
';
1355 return '.alz
' if $format eq 'alzip
';
1356 return '.bz
' if $format eq 'bzip
';
1357 return '.gz
' if $format eq 'gzip
';
1358 return '.lzo
' if $format eq 'lzop
';
1359 return '.lz
' if $format eq 'lzip
';
1360 return '.xz
' if $format eq 'xzip
';
1361 return '.rz
' if $format eq 'rzip
';
1362 return '.lrz
' if $format eq 'lrzip
';
1363 return '.zip
' if $format eq 'zip
';
1364 return '.jar
' if $format eq 'jar
';
1365 return '.Z
' if $format eq 'compress
';
1366 return '.rar
' if $format eq 'rar
';
1367 return '.ace
' if $format eq 'ace
';
1368 return '.a
' if $format eq 'ar
';
1369 return '.arj
' if $format eq 'arj
';
1370 return '.lha
' if $format eq 'lha
';
1371 return '.rpm
' if $format eq 'rpm
';
1372 return '.deb
' if $format eq 'deb
';
1373 return '.cpio
' if $format eq 'cpio
';
1374 return '.cab
' if $format eq 'cab
';
1375 die "$::basename: ".quote($format).": don't know file extension
for format
\n";
1378 # issingleformat(fmt)
1379 # fmt is a file specification as returned by findformat.
1380 # This function returns true if fmt is a single file archive (gzip etc)
1381 # for certain. This means that 7zip is not a single file archive format,
1382 # although it can be used in this way.
1383 sub issingleformat($) {
1385 return 1 if $fmt eq 'bzip2';
1386 return 1 if $fmt eq 'gzip';
1387 return 1 if $fmt eq 'bzip';
1388 return 1 if $fmt eq 'compress';
1389 return 1 if $fmt eq 'lzma';
1390 return 1 if $fmt eq 'lzop';
1391 return 1 if $fmt eq 'lzip';
1392 return 1 if $fmt eq 'xz';
1393 return 1 if $fmt eq 'rzip';
1394 return 1 if $fmt eq 'lrzip';
1398 # findformat(spec, manual)
1399 # Figure out format from specified file/string.
1400 # If manual is 0, spec is a filename, otherwise
1401 # it is a format description string.
1402 sub findformat($$) {
1403 my ($file, $manual) = @_;
1404 my $spec = lc $file;
1406 ['tar+bzip2', qr/^(GNU|POSIX) tar archive \(bzip2 compressed data(\W|$)/],
1407 ['tar+gzip', qr/^(GNU|POSIX) tar archive \(gzip compressed data(\W|$)/],
1408 ['tar+bzip', qr/^(GNU|POSIX) tar archive \(bzip compressed data(\W|$)/],
1409 ['tar+compress', qr/^(GNU|POSIX) tar archive \(compress'd data(\W|$)/],
1410 ['tar', qr/^(GNU|POSIX) tar archive(\W|$)/],
1411 ['zip', qr/ \(Zip archive data[^)]*\)$/],
1412 ['zip', qr/^Zip archive data(\W|$)/],
1413 ['zip', qr/^MS-DOS executable (.*), ZIP self-extracting archive(\W|$)/],
1414 ['rar', qr/^RAR archive data(\W|$)/],
1415 ['lha', qr/^LHa \(2\.x\) archive data /],
1416 ['lha', qr/^LHa 2\.x\? archive data /],
1417 ['lha', qr/^LHarc 1\.x archive data /],
1418 ['lha', qr/^MS-DOS executable .*, LHA's SFX$/],
1419 ['7z', qr/^7(z|-zip) archive data, version .*$/],
1420 ['ar', qr/^current ar archive(\W|$)/],
1421 ['arj', qr/^ARJ archive data(\W|$)/],
1422 ['arc', qr/^ARC archive data(\W|$)/],
1423 ['cpio', qr/^cpio archive$/],
1424 ['cpio', qr/^ASCII cpio archive /],
1425 ['rpm', qr/^RPM v/],
1426 ['cab', qr/^Microsoft Cabinet archive data\W/],
1427 ['cab', qr/^PE executable for MS Windows /],
1428 ['deb', qr/^Debian binary package(\W|$)/],
1429 ['bzip2', qr/ \(bzip2 compressed data(\W|$)/],
1430 ['bzip', qr/ \(bzip compressed data(\W|$)/],
1431 ['gzip', qr/ \(gzip compressed data(\W|$)/],
1432 ['compress', qr/ \(compress'd data(\W|$)/],
1433 ['lzma', qr/^lzma compressed data /], # Not in my magic
1434 ['lzop', qr/^lzop compressed data /],
1435 ['lzip', qr/^lzip compressed data /], # Not in my magic
1436 ['xz', qr/^xz compressed data /], # Not in my magic
1437 ['rzip', qr/^rzip compressed data /],
1438 ['lrzip', qr/^lrzip compressed data /], # Not in my magic
1439 ['bzip2', qr/^bzip2 compressed data(\W|$)/],
1440 ['bzip', qr/^bzip compressed data(\W|$)/],
1441 ['gzip', qr/^gzip compressed data(\W|$)/],
1442 ['compress', qr/^compress'd data(\W|$)/],
1444 my @fileextensions = (
1445 ['tar+7z', qr/(\.tar\.7z|\.t7z)$/],
1446 ['tar+bzip', qr/(\.tar\.bz|\.tbz)$/],
1447 ['tar+bzip2', qr/(\.tar\.bz2|\.tbz2)$/],
1448 ['tar+compress', qr/(\.tar\.[zZ]|\.t[zZ])$/],
1449 ['tar+gzip', qr/(\.tar\.gz|\.tgz)$/],
1450 ['tar+lzip', qr/(\.tar\.lz|\.tlz)$/],
1451 ['tar+lzma', qr/(\.tar\.lzma|\.tlzma)$/],
1452 ['tar+lzop', qr/(\.tar\.lzo|\.tzo)$/],
1453 ['tar+xz', qr/(\.tar\.xz|\.txz)$/],
1456 ['ace', qr/\.ace$/],
1457 ['alzip', qr/\.alz$/],
1459 ['arc', qr/\.arc$/],
1460 ['arj', qr/\.arj$/],
1461 ['bzip', qr/\.bz$/],
1462 ['bzip2', qr/\.bz2$/],
1463 ['cab', qr/\.cab$/],
1464 ['compress', qr/\.[zZ]$/],
1465 ['cpio', qr/\.cpio$/],
1466 ['deb', qr/\.deb$/],
1467 ['gzip', qr/\.gz$/],
1468 ['jar', qr/\.(jar|war)$/],
1469 ['lha', qr/\.(lha|lzh)$/],
1470 ['lrzip', qr/\.lrz$/],
1471 ['lzip', qr/\.lz$/],
1472 ['lzma', qr/\.lzma$/],
1473 ['lzop', qr/\.lzo$/],
1474 ['rar', qr/\.rar$/],
1475 ['rpm', qr/\.rpm$/],
1476 ['rzip', qr/\.rz$/],
1477 ['tar', qr/\.tar$/],
1479 ['zip', qr/\.zip$/],
1484 $spec =~ s/^\.*/\./;
1485 $spec =~ s/lzop/lzo/;
1486 $spec =~ s/lzip/lz/;
1487 $spec =~ s/rzip/rz/;
1488 $spec =~ s/lrzip/lrz/;
1489 $spec =~ s/bzip2/bz2/;
1490 $spec =~ s/bzip/bz/;
1491 $spec =~ s/gzip/gz/;
1492 $spec =~ s/7zip/7z/;
1493 $spec =~ s/alzip/alz/;
1494 $spec =~ s/compress/Z/;
1497 if (!$::cfg_use_file_always) {
1498 foreach my $formatinfo (@fileextensions) {
1499 my ($format, $regex) = @{$formatinfo};
1500 return $format if ($spec =~ $regex);
1503 if (!$manual && $::cfg_use_file) {
1505 warn "$::basename
: ".quote($file).": no such file
and cannot identify format from extension
\n";
1508 if (!sysopen(TMP, $file, O_RDONLY)) {
1509 warn "$::basename
: ".quote($file).": cannot
open - $!\n";
1514 warn "$::basename
: ".quote($file).": not a regular file
\n";
1517 if ($::opt_verbosity >= 1) {
1518 if ($::cfg_use_file_always) {
1519 warn "$::basename
: ".quote($file).": identifying format using file
\n";
1521 warn "$::basename
: ".quote($file).": format
not known
, identifying using file
\n";
1524 my @cmd = ($::cfg_path_file, '-b', '-L', '-z', '--', $file);
1525 $spec = backticks(@cmd);
1526 if (!defined $spec) {
1527 warn "$::basename
: $::errmsg
\n";
1530 if ($? & 0xFF != 0) {
1531 warn "$::basename
: ".quote($::cfg_path_file).": abnormal
exit\n";
1535 warn "$::basename
: ".quote($file).": unknown file format
\n";
1539 foreach my $formatinfo (@fileoutput) {
1540 my ($format, $regex) = @{$formatinfo};
1541 if ($spec =~ $regex) {
1542 warn "$::basename
: ".quote($file).": format is
`$format'\n" if $::opt_verbosity >= 1;
1546 warn "$::basename: ".quote($file).": unsupported file format `$spec'\n";
1549 warn "$::basename: ".quote($file).": unrecognized file format\n";
1553 # backticks(cmdargs, ..)
1554 # An implementation of the backtick (qx//) operator.
1555 # The difference is that command STDERR output will still
1556 # be printed on STDERR, and the shell isn't used to parse
1559 if (!pipe(IN
,OUT
)) {
1560 $::errmsg
= "pipe failed - $!";
1564 if (!defined $child) {
1565 $::errmsg
= "fork failed - $!";
1570 close STDOUT
|| exit 1;
1571 open(STDOUT
, '>&OUT') || exit 1;
1572 close OUT
|| exit 1;
1573 $SIG{__WARN__
} = sub {};
1577 my $text = join('', <IN
>);
1579 if (waitpid($child,0) != $child && $^O
ne 'MSWin32') {
1580 $::errmsg
= "waitpid failed - $!";
1586 # set_config_option(variable, value)
1587 # Set a configuration option.
1588 sub set_config_option
($$$) {
1589 my ($var, $val, $context) = @_;
1591 'args_diff' => [ 'option', \
$::cfg_args_diff
, qr/.*/ ],
1592 'decompress_to_cwd' => [ 'option', \
$::cfg_decompress_to_cwd
, qr/^(0|1)$/ ],
1593 'default_verbosity' => [ 'option', \
$::cfg_default_verbosity
, qr/^\d+$/ ],
1594 'extract_deb_control' => [ 'option', \
$::cfg_extract_deb_control
, qr/^(0|1)$/ ],
1595 'keep_compressed' => [ 'option', \
$::cfg_keep_compressed
, qr/^(0|1)$/ ],
1596 'path_7z' => [ 'option', \
$::cfg_path_7z
, qr/.*/ ],
1597 'path_ar' => [ 'option', \
$::cfg_path_ar
, qr/.*/ ],
1598 'path_arc' => [ 'option', \
$::cfg_path_arc
, qr/.*/ ],
1599 'path_arj' => [ 'option', \
$::cfg_path_arj
, qr/.*/ ],
1600 'path_bzip' => [ 'option', \
$::cfg_path_bzip
, qr/.*/ ],
1601 'path_bzip2' => [ 'option', \
$::cfg_path_bzip2
, qr/.*/ ],
1602 'path_cabextract' => [ 'option', \
$::cfg_path_cabextract
, qr/.*/ ],
1603 'path_cat' => [ 'option', \
$::cfg_path_cat
, qr/.*/ ],
1604 'path_compress' => [ 'option', \
$::cfg_path_compress
, qr/.*/ ],
1605 'path_cpio' => [ 'option', \
$::cfg_path_cpio
, qr/.*/ ],
1606 'path_diff' => [ 'option', \
$::cfg_path_diff
, qr/.*/ ],
1607 'path_dpkg_deb' => [ 'option', \
$::cfg_path_dpkg_deb
, qr/.*/ ],
1608 'path_file' => [ 'option', \
$::cfg_path_file
, qr/.*/ ],
1609 'path_find' => [ 'option', \
$::cfg_path_find
, qr/.*/ ],
1610 'path_gzip' => [ 'option', \
$::cfg_path_gzip
, qr/.*/ ],
1611 'path_jar' => [ 'option', \
$::cfg_path_jar
, qr/.*/ ],
1612 'path_lbzip2' => [ 'option', \
$::cfg_path_lbzip2
, qr/.*/ ],
1613 'path_lha' => [ 'option', \
$::cfg_path_lha
, qr/.*/ ],
1614 'path_lrzip' => [ 'option', \
$::cfg_path_lrzip
, qr/.*/ ],
1615 'path_lzip' => [ 'option', \
$::cfg_path_lzip
, qr/.*/ ],
1616 'path_lzma' => [ 'option', \
$::cfg_path_lzma
, qr/.*/ ],
1617 'path_lzop' => [ 'option', \
$::cfg_path_lzop
, qr/.*/ ],
1618 'path_nomarch' => [ 'option', \
$::cfg_path_nomarch
, qr/.*/ ],
1619 'path_pager' => [ 'option', \
$::cfg_path_pager
, qr/.*/ ],
1620 'path_pbzip2' => [ 'option', \
$::cfg_path_pbzip2
, qr/.*/ ],
1621 'path_pigz' => [ 'option', \
$::cfg_path_pigz
, qr/.*/ ],
1622 'path_plzip' => [ 'option', \
$::cfg_path_plzip
, qr/.*/ ],
1623 'path_rar' => [ 'option', \
$::cfg_path_rar
, qr/.*/ ],
1624 'path_rpm' => [ 'option', \
$::cfg_path_rpm
, qr/.*/ ],
1625 'path_rpm2cpio' => [ 'option', \
$::cfg_path_rpm2cpio
, qr/.*/ ],
1626 'path_rzip' => [ 'option', \
$::cfg_path_rzip
, qr/.*/ ],
1627 'path_tar' => [ 'option', \
$::cfg_path_tar
, qr/.*/ ],
1628 'path_unace' => [ 'option', \
$::cfg_path_unace
, qr/.*/ ],
1629 'path_unalz' => [ 'option', \
$::cfg_path_unalz
, qr/.*/ ],
1630 'path_unarj' => [ 'option', \
$::cfg_path_unarj
, qr/.*/ ],
1631 'path_unrar' => [ 'option', \
$::cfg_path_unrar
, qr/.*/ ],
1632 'path_unzip' => [ 'option', \
$::cfg_path_unzip
, qr/.*/ ],
1633 'path_usercfg' => [ 'option', \
$::cfg_path_usercfg
, qr/.*/ ],
1634 'path_xargs' => [ 'option', \
$::cfg_path_xargs
, qr/.*/ ],
1635 'path_xz' => [ 'option', \
$::cfg_path_xz
, qr/.*/ ],
1636 'path_zip' => [ 'option', \
$::cfg_path_zip
, qr/.*/ ],
1637 'show_extracted' => [ 'option', \
$::cfg_show_extracted
, qr/^(0|1)$/ ],
1638 'strip_unknown_ext' => [ 'option', \
$::cfg_strip_unknown_ext
, qr/^(0|1)$/ ],
1639 'tmpdir_name' => [ 'option', \
$::cfg_tmpdir_name
, qr/.*/ ],
1640 'tmpfile_name' => [ 'option', \
$::cfg_tmpfile_name
, qr/.*/ ],
1641 'use_arc_for_unpack' => [ 'option', \
$::cfg_use_arc_for_unpack
, qr/^(0|1)$/ ],
1642 'use_arj_for_unpack' => [ 'option', \
$::cfg_use_arj_for_unpack
, qr/^(0|1)$/ ],
1643 'use_file' => [ 'option', \
$::cfg_use_file
, qr/^(0|1)$/ ],
1644 'use_file_always' => [ 'option', \
$::cfg_use_file_always
, qr/^(0|1)$/ ],
1645 'use_find_cpio_print0' => [ 'option', \
$::cfg_use_find_cpio_print0
, qr/^(0|1)$/ ],
1646 'use_gzip_for_z' => [ 'option', \
$::cfg_use_gzip_for_z
, qr/^(0|1)$/ ],
1647 'use_lbzip2' => [ 'option', \
$::cfg_use_lbzip2
, qr/^(0|1)$/ ],
1648 'use_jar' => [ 'option', \
$::cfg_use_jar
, qr/^(0|1)$/ ],
1649 'use_pbzip2' => [ 'option', \
$::cfg_use_pbzip2
, qr/^(0|1)$/ ],
1650 'use_pigz' => [ 'option', \
$::cfg_use_pigz
, qr/^(0|1)$/ ],
1651 'use_plzip' => [ 'option', \
$::cfg_use_plzip
, qr/^(0|1)$/ ],
1652 'use_rar_for_unpack' => [ 'option', \
$::cfg_use_rar_for_unpack
, qr/^(0|1)$/ ],
1653 'use_rar_for_unrar' => [ 'obsolete', 'use_rar_for_unpack' ],
1654 'use_tar_bzip2_option' => [ 'option', \
$::cfg_use_tar_bzip2_option
, qr/^(0|1)$/ ],
1655 'use_tar_lzma_option' => [ 'option', \
$::cfg_use_tar_lzma_option
, qr/^(0|1)$/ ],
1656 'use_tar_lzop_option' => [ 'option', \
$::cfg_use_tar_lzop_option
, qr/^(0|1)$/ ],
1657 'use_tar_xz_option' => [ 'option', \
$::cfg_use_tar_xz_option
, qr/^(0|1)$/ ],
1658 'use_tar_j_option' => [ 'obsolete', 'use_tar_bzip2_option' ],
1659 'use_tar_z_option' => [ 'option', \
$::cfg_use_tar_z_option
, qr/^(0|1)$/ ],
1661 die $::basename
,': ',$context,'unrecognized directive `',$var,"'\n" if !exists $optionmap{$var};
1662 return 0 if !exists $optionmap{$var};
1663 my ($type) = @
{$optionmap{$var}};
1664 if ($type eq 'obsolete') {
1665 warn $context.$var.' is obsolete - use '.$optionmap{$var}->[1].')'."\n";
1666 $var = $optionmap{$var}->[1];
1668 my ($varref,$check) = @
{$optionmap{$var}}[1,2];
1669 die $::basename
,': ',$context,'invalid value for `',$var,"'\n" if $val !~ $check;
1675 # Read and parse the specified configuration file.
1676 # If the file does not exist, just return.
1677 # If there is an error in the configuration file,
1678 # the program will be terminated. This could be a
1679 # problem when there are errors in the system-wide
1680 # configuration file.
1681 sub readconfig
($$) {
1682 my ($file, $failok) = @_;
1683 return if ($failok && !-e
$file);
1684 sysopen(FILE
, $file, O_RDONLY
) || die "$::basename: ".quote
($file).": cannot open for reading - $!\n"; #OK
1687 next if /^\s*(#(.*))?$/;
1688 my ($var,$val) = /^(.*?)\s+([^\s].*)$/; # joe markup bug -> ]]
1689 set_config_option
($var, $val, quote
($file).':'.$..': ');
1694 # Remove a directory recursively. This function used to change
1695 # the mode on the directories is traverses, but I now consider
1696 # that to be unsafe (what if there's a bug in atool and it
1697 # removes a file it shouldn't?).
1698 sub unlink_directory
($) {
1700 die "$::basename: internal error 1 - please report this bug\n"
1701 if ($dir eq '/' || $dir eq $ENV{HOME
});
1702 # chmod 0700, $dir || die "$::basename: cannot chmod `".quote($dir)."': $!\n";
1703 chdir $dir || die "$::basename: ".quote
($dir).": cannot change to - $!\n";
1704 opendir(DIR
, $::cur
) || die "$::basename: ".quote
($dir).": cannot list - $!\n";
1705 my @files = readdir(DIR
);
1707 foreach my $file (@files) {
1708 next if $file eq $::cur
|| $file eq $::up
;
1709 if (-d
$file && !-l
$file) {
1710 unlink_directory
($file);
1712 unlink $file || die "$::basename: ".quote
($file).": cannot remove - $!\n";
1715 chdir $::up
|| die "$::basename: $::up: cannot change to - $!\n";
1716 rmdir $dir || die "$::basename: ".quote
($dir).": cannot remove - $!\n";
1719 # find_comparable_file(dir)
1720 # Assuming that the contents of some archive has been extracted to dir,
1721 # this function will determine the main file or directory in this
1722 # archive - the file or directory which will be compared when this
1723 # archive is compared to some other.
1724 sub find_comparable_file
($) {
1727 if (opendir(my $dh, $dir)) {
1730 my $file = readdir($dh);
1731 last if !defined $file;
1732 next if $file eq '.' || $file eq '..';
1736 $result = File
::Spec
->catfile($dir, $files[0]) if @files == 1;
1741 # makeabsolute(file)
1742 # Return the absolute version of file.
1743 sub makeabsolute
($) {
1745 return $file if (substr($file, 0, 1) eq '/');
1746 return File
::Spec
->catfile(getcwd
(), $file);
1750 # Quote a style like the GNU fileutils would do (`locale'
1755 for (my $c = 0; $c < length($in); $c++) {
1756 my $ch = substr($in, $c, 1);
1759 } elsif ($ch eq "\f") {
1761 } elsif ($ch eq "\n") {
1763 } elsif ($ch eq "\r") {
1765 } elsif ($ch eq "\t") {
1767 } elsif (ord($ch) == 11) { # Vertical Tab, \v
1769 } elsif ($ch eq "\\") {
1771 } elsif ($ch eq "'") {
1773 } elsif ($ch !~ /[[:print:]]/) {
1774 $out .= sprintf('\\%03o', ord($ch));
1783 # Execute a command with pipes and output redirection like the
1784 # shell does. Only difference is we do it without the shell.
1785 # This reason for this is because we don't have to quote
1786 # meta-characters - some meta-characters like LF and DEL are
1788 sub shell_execute
(@
) {
1792 for ($c = 0; $c < @cmdspec; $c++) {
1793 if (ref $cmdspec[$c] && ${$cmdspec[$c]}[0] eq ';') {
1794 return 0 if !shell_execute_single_statement
(@cmdspec[$start..$c-1]);
1799 return 0 if !shell_execute_single_statement
(@cmdspec[$start..$c-1]);
1804 sub shell_execute_single_statement
(@
) {
1807 while (@cmdspec > 0) {
1810 my $redir_out = undef;
1813 for ($c = 0; $c < @cmdspec; $c++) {
1814 if (ref $cmdspec[$c]) {
1815 push @cmds, [ @cmdspec[$start..$c-1] ];
1816 if (${$cmdspec[$c]}[0] eq '>') {
1817 $redir_out = $cmdspec[$c+1];
1820 #} elsif (${$cmdspec[$c]}[0] eq ';') {
1825 } elsif (${$cmdspec[$c]}[0] eq '|') {
1830 push @cmds, [ @cmdspec[$start..$c-1] ] if $start < $c;
1831 #for (my $x = 0; $x < @cmds; $x++) {
1832 # print $x, ': ', join(':',@{$cmds[$x]}), "\n";
1834 splice @cmdspec,0,$c;
1836 $SIG{INT
} = 'IGNORE';
1841 for (my $c = 0; $c <= $#cmds; $c++) {
1843 @op = reverse POSIX
::pipe();
1844 if (!@op || !defined $op[0] || !defined $op[1]) {
1845 $::errmsg
= "pipe failed - $!";
1849 if ($c == $#cmds && defined $redir_out) {
1850 @_ = (); # XXX: necessary to overcome POSIX autoload bug!
1851 @op = (POSIX
::open($redir_out, &POSIX
::O_WRONLY
| &POSIX
::O_CREAT
));
1852 if (!@op || !defined $op[0]) {
1853 $::errmsg
= quote
($redir_out).": cannot open for writing - $!";
1858 die "fork failed - $!\n" if !defined $pid;
1862 die "dup2 failed - $!\n" if POSIX
::dup2
($ip[1], 0) < 0;
1863 POSIX
::close($_) foreach (@ip);
1866 die "dup2 failed - $!\n" if POSIX
::dup2
($op[0], 1) < 0;
1867 POSIX
::close($_) foreach (@op);
1869 exec(@
{$cmds[$c]}) || die ${$cmds[$c]}[0].": cannot execute - $!\n";
1871 POSIX
::close($op[0]) if ($c == $#cmds && defined $redir_out);
1872 POSIX
::close($_) foreach (@ip);
1875 push @children, $pid;
1878 foreach (@children) {
1879 if (waitpid($_,0) < 0 && $^O
ne 'MSWin32') {
1880 $::errmsg
= "waitpid failed - $!";
1890 # Write dir to file indicated by $::opt_save_outdir.
1892 sub save_outdir
($) {
1894 if (defined $::opt_save_outdir
&& !-l
$dir && -d
$dir) {
1895 if (!sysopen(TMP
, $::opt_save_outdir
, O_WRONLY
)) {
1896 warn die "$::basename: ".quote
($::opt_save_outdir
).": cannot open for writing - $!\n";
1898 print TMP
$dir, "\n";
1904 # Somewhat stupid subroutine to add xargs to the command line.
1906 sub handle_empty_add
(@
) {
1909 unshift @cmd, '-0' if ($::opt_null
);
1910 unshift @cmd, $::cfg_path_xargs
;
1914 # Return a suitable pager command
1916 sub get_pager_program
{
1917 return $ENV{PAGER
} if (exists $ENV{PAGER
});
1918 return $::cfg_path_pager
;
1921 # repack_archive(srcfile,dstfile,srcfmt,dstfmt)
1922 # Repack an archive from a file to another (that shouldn't exist).
1923 sub repack_archive
($$$$) {
1924 my ($file1,$file2,$fmt1,$fmt2) = @_;
1926 # Special cases for tar-based archives (single file archives).
1927 if ($fmt1 =~ /^tar\+/ && $fmt2 =~ /^tar$/) {
1928 $fmt1 =~ s/^tar\+//;
1929 $::opt_cmd_extract_to
= $file2; # XXX: would like to get rid of these
1930 $::opt_cmd_extract_to_type
= 'f'; # XXX: would like to get rid of these
1931 exit 1 if (!runcmds
('extract-to', $fmt1, $file1));
1933 } elsif ($fmt1 =~ /^tar$/ && $fmt2 =~ /^tar\+/) {
1934 $fmt2 =~ s/^tar\+//;
1935 exit 1 if (!runcmds
('add', $fmt2, $file2, $file1));
1939 if ($fmt1 =~ /^tar\+/ && $fmt2 =~ /^tar\+/) {
1940 $fmt1 =~ s/^tar\+//;
1941 $fmt2 =~ s/^tar\+//;
1945 if (File
::Spec
->file_name_is_absolute($file2)) {
1946 $newarchive = $file2;
1948 $newarchive = File
::Spec
->catdir($::up
, $file2);
1952 $outdir = makeoutdir
() || exit 1;
1953 $::opt_cmd_extract_to
= $outdir;
1954 $::opt_cmd_extract_to_type
= 'd';
1955 exit 1 if !runcmds
('extract-to', $fmt1, $file1);
1956 warn 'cd ',quote
($outdir),"\n" if $::opt_explain
|| $::opt_simulate
;
1957 if (!$::opt_simulate
) {
1958 chdir($outdir) || die "$::basename: ".quote
($outdir).": cannot change to - $!\n";
1960 if (issingleformat
($fmt2)) {
1961 # Preferrably we would like to find out what file it was
1962 # extracted to from the above execute-to command.
1963 #my $oldfile = stripext_exactly(basename($file1), $fmt1);
1964 my $oldfile = find_comparable_file
($::cur
); # FIXME: won't work in simulate mode
1965 exit 1 if !runcmds
('add', $fmt2, $newarchive, $oldfile);
1967 exit 1 if !runcmds
('add', $fmt2, $newarchive, $::cur
);
1969 warn 'cd ',quote
($::up
),"\n" if $::opt_explain
|| $::opt_simulate
;
1970 if (!$::opt_simulate
) {
1971 chdir($::up
) || die "$::basename: ".$::up
.": cannot change to - $!\n"; #OK?????
1973 warn 'rm -r ',quote
($outdir),"\n" if $::opt_explain
|| $::opt_simulate
;
1974 if (!$::opt_simulate
) {
1975 unlink_directory
($outdir);
1980 map (rmdir, @
::rmdirs
) if !$::opt_simulate
; # Errors are ignored