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, 2011, 2012 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.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;
  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_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?
 151
 152 # Global variables
 153 $::basename = quote(File::Basename::basename($0));
 154 @::rmdirs = ();
 155 $::up = File::Spec->updir();
 156 $::cur = File::Spec->curdir();
 157 @::opt_options = ();
 158 @::opt_format_options = ();
 159
 160 # Parse arguments
 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,
 187 ) or exit 1;
 188
 189 # Display --version
 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.
 196
 197 Written by Oskar Liljeblad.\n";
 198   exit;
 199 }
 200
 201 # Display --help
 202 if ($::opt_cmd_help) {
 203   print <<_END_;
 204 Usage: $::PROGRAM [OPTION]... ARCHIVE [FILE]...
 205        $::PROGRAM -e [OPTION]... [ARCHIVE]...
 206 Manage file archives of various types.
 207
 208 Commands:
 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
 218
 219 Options:
 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
 234
 235 Archive format (for --format) may be specified either as a
 236 file extension ("tar.gz") or as "tar+gzip".
 237
 238 Report bugs to Oskar Liljeblad <$::BUG_EMAIL>.
 239 _END_
 240   exit;
 241 }
 242
 243 # Read configuration files
 244 if (defined $::opt_config) {
 245   readconfig($::opt_config, 0);
 246 } else {
 247   readconfig($::cfg_path_syscfg, 1);
 248   if ($::cfg_path_usercfg !~ /^\//) {
 249     readconfig(File::Spec->catfile($ENV{HOME}, $::cfg_path_usercfg), 1);
 250   } else {
 251     readconfig($::cfg_path_usercfg, 1);
 252   }
 253 }
 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, '');
 258 }
 259
 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
 264 }
 265
 266 my $mode = getmode();
 267
 268 if (defined $::opt_save_outdir && $mode eq 'extract-to') {
 269   die "$::basename: --save-outdir cannot be used in extract-to mode\n";
 270 }
 271 if ($::opt_extract_subdir && $mode ne 'extract') {
 272   die "$::basename: --subdir can only be used in extract mode\n";
 273 }
 274
 275 if ($mode eq 'diff') {
 276   die "$::basename: missing archive argument\n" if (@ARGV < 2); #OK
 277   my $use_pager = $::opt_use_pager;
 278   $::opt_verbosity--;
 279   $::opt_use_pager = 0;
 280
 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]));
 289
 290   my $match1 = find_comparable_file($outfile1);
 291   my $match2 = find_comparable_file($outfile2);
 292
 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);
 296
 297   foreach my $file ($outfile1,$outfile2) {
 298     warn 'rm -r ',quote($file),"\n" if $::opt_simulate;
 299     if (-e $file && -d $file) {
 300     #if (-e $file) {
 301       #print "$::basename: remove `$file'? ";
 302       #select((select(STDOUT), $| = 1)[0]);
 303       #my $line = <STDIN>;
 304       #if (defined $line && $line =~ /^y/) {
 305         #if (-d $file) {
 306           warn 'rm -r ',quote($file),"\n" if $::opt_explain;
 307           unlink_directory($file) if !$::opt_simulate;
 308         #} else {
 309           #unlink $file;
 310         #}
 311       #}
 312     }
 313   }
 314
 315   exit ($allok ? 0 : 1);
 316 }
 317 elsif ($mode eq 'repack') {
 318   if ($::opt_each) {
 319     my $totaldiff = 0;
 320     if (!defined $::opt_format) {
 321       die "$::basename: specify a format with -F when using --each in repack mode\n";
 322     }
 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";
 331         next;
 332       }
 333       if ($fmt1 eq $fmt2) {
 334         warn "$::basename: will not repack to same archive type\n";
 335         warn "skipping ", quote($ARGV[$c]), "\n";
 336         next;
 337       }
 338       my $newname = stripext($ARGV[$c]).formatext($fmt2);
 339       if (-e $newname) {
 340         warn "$::basename: ".quote($newname).": destination file exists\n";
 341         warn "skipping ", quote($ARGV[$c]), "\n";
 342         next;
 343       }
 344       repack_archive($ARGV[$c], $newname, $fmt1, $fmt2);
 345       my $diff = $::opt_simulate ? 0 : (-s $ARGV[$c]) - (-s $newname);
 346       $totaldiff += $diff;
 347       if ($::opt_verbosity >= 1) {
 348         print quote($newname), ': ',
 349             ($diff >= 0 ? 'saved '.$diff : 'grew '.-$diff),' ',
 350             ($diff == 1 ? 'byte':'bytes'), "\n";
 351       }
 352     }
 353     if ($::opt_verbosity >= 1) {
 354       print $totaldiff >= 0 ? 'saved '.$totaldiff : 'grew '.-$totaldiff, ' ',
 355           $totaldiff == 1 ? 'byte':'bytes', " in total\n";
 356     }
 357   } else {
 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";
 375     }
 376   }
 377 }
 378 elsif ($::opt_each) {
 379   my $allok = 1;
 380   if ($mode eq 'cat') {
 381     die "$::basename: --each can not be used with cat or add command\n";  #OK
 382   }
 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";
 386     }
 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;
 393     }
 394   } else {
 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;
 398     }
 399   }
 400   exit ($allok ? 0 : 1);
 401 }
 402 else {
 403   die "$::basename: missing archive argument\n" if (@ARGV == 0);  #OK
 404   runcmds($mode, undef, shift @ARGV, @ARGV) || exit 1;
 405 }
 406
 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.
 413 sub runcmds($$$;@) {
 414   my ($mode, $format, $archive, @args) = @_;
 415
 416   if (!defined $format) {
 417     if (defined $::opt_format) {
 418       $format = findformat($::opt_format, 1);
 419     } else {
 420       $format = findformat($archive, 0);
 421     }
 422     return undef if !defined $format;
 423   }
 424
 425   my @cmd;
 426   my $outdir;
 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;
 442       #} else {
 443       #  push @cmd, $::cfg_path_pbzip2, '-cd', $archive, ['|'];
 444       #  push @cmd, maketarcmd('-', $outdir, $mode, 'f'), @args;
 445       #}
 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';
 450     } else {
 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';
 454     }
 455     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 456     return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
 457   }
 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';
 466     } else {
 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';
 470     }
 471     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 472     return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
 473   }
 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);
 481   }
 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';
 486     } else {
 487       push @cmd, $::cfg_path_compress, '-cd', $archive, ['|'] if $mode ne 'add';
 488     }
 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);
 493   }
 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;
 498     } else {
 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';
 502     }
 503     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 504     return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
 505   }
 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';
 514     } else {
 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';
 518     }
 519     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 520     return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
 521   }
 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;
 526     } else {
 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';
 530     }
 531     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 532     return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
 533   }
 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);
 541   }
 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;
 546     } else {
 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';
 550     }
 551     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 552     return multiarchivecmd($archive, $outdir, $mode, 1, 0, \@args, @cmd);
 553   }
 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);
 559   }
 560   elsif ($format eq 'jar' && $::cfg_use_jar) {
 561     return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
 562     my $opts = '';
 563     if ($mode eq 'add') {
 564       warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
 565       return undef;
 566     }
 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);
 576   }
 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';
 581     } else {
 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';
 587     }
 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);
 594   }
 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;
 599     } else {
 600       push @cmd, $::cfg_path_unrar;
 601     }
 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);
 614   }
 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";
 622     #  return undef;
 623     #}
 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);
 632   }
 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";
 637       return undef;
 638     }
 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';
 645     push @cmd, $archive;
 646     push @cmd, '--filter';
 647     push @cmd, @args;
 648     return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
 649   }
 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";
 653       return undef;
 654     }
 655     return undef if ($mode eq 'extract' && !defined ($outdir = makeoutdir()));
 656     push @cmd, $::cfg_path_unalz;
 657     push @cmd, $archive;
 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);
 661   }
 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);
 675   }
 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";
 681       return undef;
 682     }
 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);
 692   }
 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";
 697       return undef;
 698     }
 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);
 710     } else {
 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');
 719       push @cmd, @args;
 720       @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 721       return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
 722     }
 723   }
 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';
 734     } else {
 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';
 739     }
 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');
 743     push @cmd, @args;
 744     @cmd = handle_empty_add(@cmd) if ($mode eq 'add' && @args == 0);
 745     return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
 746   }
 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;
 751       push @cmd, '-qlp';
 752       push @cmd, '-v' if $::opt_verbosity >= 1;
 753       push @cmd, $archive, @args;
 754       return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
 755     }
 756     elsif ($mode eq 'extract' || $mode eq 'extract-to') {
 757       push @cmd, $::cfg_path_rpm2cpio;
 758       push @cmd, makeabsolute($archive);
 759       push @cmd, ['|'];
 760       push @cmd, $::cfg_path_cpio, '-imd', '--quiet', @args;
 761       return multiarchivecmd($archive, $outdir, $mode, 0, 1, \@args, @cmd);
 762     }
 763     else { # add and cat
 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";
 767       return undef;
 768     }
 769   }
 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;
 781       }
 782       push @cmd, $archive;
 783       push @cmd, $outdir if $mode eq 'extract';
 784       push @cmd, $::opt_cmd_extract_to if $mode eq 'extract-to';
 785       push @cmd, @args;
 786       if ($::cfg_extract_deb_control && ($mode eq 'extract' || $mode eq 'extract-to')) {
 787         push @cmd, [';'];
 788         push @cmd, $::cfg_path_dpkg_deb;
 789         push @cmd, '--control';
 790         push @cmd, $archive;
 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';
 793       }
 794     }
 795     return multiarchivecmd($archive, $outdir, $mode, 0, 0, \@args, @cmd);
 796   }
 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);
 808   }
 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);
 816     }
 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);
 822     }
 823     elsif ($mode eq 'add') {
 824       if (@args == 0) {
 825         push @cmd, $::cfg_path_cpio;
 826         push @cmd, '-0' if $::opt_null;
 827         push @cmd, '-o';
 828         push @cmd, '-v' if $::opt_verbosity >= 1;
 829         push @cmd, ['>'], $archive;
 830       } else {
 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;
 835         push @cmd, '-o';
 836         push @cmd, '-v' if $::opt_verbosity >= 1;
 837         push @cmd, ['>'], $archive;
 838       }
 839       return multiarchivecmd($archive, $outdir, $mode, 1, 1, \@args, @cmd);
 840     }
 841     else { # cat
 842       warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
 843       return undef;
 844     }
 845   }
 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);
 850   }
 851   elsif ($format eq 'bzip') {
 852     return singlearchivecmd($archive, $::cfg_path_bzip, $format, $mode, 1, @args);
 853   }
 854   elsif ($format eq 'gzip') {
 855     return singlearchivecmd($archive, $::cfg_use_pigz ? $::cfg_path_pigz : $::cfg_path_gzip, $format, $mode, 1, @args);
 856   }
 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);
 860     } else {
 861       return singlearchivecmd($archive, $::cfg_path_compress, $format, $mode, 1, @args);
 862     }
 863   }
 864   elsif ($format eq 'lzma') {
 865     return singlearchivecmd($archive, $::cfg_path_lzma, $format, $mode, 1, @args);
 866   }
 867   elsif ($format eq 'lzop') {
 868     return singlearchivecmd($archive, $::cfg_path_lzop, $format, $mode, 0, @args);
 869   }
 870   elsif ($format eq 'lzip') {
 871     return singlearchivecmd($archive, $::cfg_use_plzip ? $::cfg_path_plzip : $::cfg_path_lzip, $format, $mode, 1, @args);
 872   }
 873   elsif ($format eq 'xz') {
 874     return singlearchivecmd($archive, $::cfg_path_xz, $format, $mode, 1, @args);
 875   }
 876   elsif ($format eq 'rzip') {
 877     return singlearchivecmd($archive, $::cfg_path_rzip, $format, $mode, 0, @args);
 878   }
 879   elsif ($format eq 'lrzip') {
 880     return singlearchivecmd($archive, $::cfg_path_lrzip, $format, $mode, 0, @args);
 881   }
 882
 883   return undef;
 884 }
 885
 886 # de(value):
 887 # Return 1 if value defined and is non-zero, 0 otherwise.
 888 sub de($) {
 889   my ($value) = @_;
 890   return defined $value && $value ? 1 : 0;
 891 }
 892
 893 # getmode()
 894 # Identify the execution mode, and return it.
 895 # Possible modes are 'cat', 'extract', 'list', 'add' or 'extract-to'.
 896 sub getmode() {
 897   my $mode;
 898   if (de($::opt_cmd_list)
 899       + de($::opt_cmd_cat)
 900       + de($::opt_cmd_extract)
 901       + de($::opt_cmd_add)
 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
 906   }
 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
 922   }
 923   return $mode;
 924 }
 925
 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) = @_;
 933   my $outfile;
 934   my $reason;
 935   my @cmd;
 936   push @cmd, $cmd;
 937   push @cmd, '-v' if $::opt_verbosity > 1;
 938
 939   if ($mode eq 'list') {
 940     warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
 941     return undef;
 942   }
 943   elsif ($mode eq 'cat') {
 944     if (!$can_do_c) {
 945       warn "$::basename: ".quote($archive).": $mode command not supported for $format archives\n";
 946       return undef;
 947     }
 948     push @cmd, '-c', '-d', $archive, @args;
 949     $outfile = $archive; # Just so that we don't return undef
 950   }
 951   elsif ($mode eq 'add') {
 952     if (@args > 1) {
 953       warn "$::basename: cannot add more than one file with this format\n";
 954       return undef;
 955     }
 956     if (!$::opt_force && (-e $archive || -l $archive)) {
 957       warn "$::basename: ".quote($archive).": refusing to overwrite existing file\n";
 958       return undef;
 959     }
 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";
 962     # return;
 963     #}
 964     if ($can_do_c) {
 965       push @cmd, '-c', @args, ['>'], $archive;
 966     } else {
 967       push @cmd, '-o', $archive, @args;
 968     }
 969     $outfile = $archive; # Just so that we don't return undef
 970   }
 971   elsif ($mode eq 'extract') {
 972     $outfile = stripext($archive);
 973     if ($::cfg_decompress_to_cwd) {
 974       $outfile = basename($outfile);
 975     }
 976     if (-e $outfile) {
 977       $outfile = makeoutfile($::cfg_tmpdir_name);
 978       $reason = 'local file exists';
 979     }
 980     if ($can_do_c) {
 981       push @cmd, '-c', '-d', $archive, @args, ['>'], $outfile;
 982     } else {
 983       push @cmd, '-o', $outfile, '-d', $archive, @args;
 984     }
 985   }
 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));
 991     }
 992     if ($can_do_c) {
 993       push @cmd, '-c', '-d', $archive, @args, ['>'], $outfile;
 994     } else {
 995       push @cmd, '-o', $outfile, '-d', $archive, @args;
 996     }
 997   }
 998
 999   push @cmd, ['|'], get_pager_program() if $::opt_use_pager;
1000   cmdexec(0, @cmd) || return undef;
1001
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";
1007     }
1008   }
1009
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";
1015       }
1016     }
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";
1021       }
1022     }
1023   }
1024
1025   return $outfile;
1026 }
1027
1028 # maketarcmd(opts):
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';
1042   push @cmd, @rest;
1043   return @cmd;
1044 }
1045
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
1051 # be quoted.
1052 sub cmdexec($@) {
1053   my ($ignret, @cmd) = @_;
1054
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);
1059   }
1060
1061   my $cmds = makespec(@cmd);
1062   if (!shell_execute(@cmd)) {
1063     warn "$::basename: ".quote($cmds).": cannot execute - $::errmsg\n";
1064     return 0;
1065   }
1066
1067   if ($? & 0xFF != 0) {
1068     warn "$::basename: ".quote($cmds).": abnormal exit (exit code $?)\n";
1069     return 0;
1070   }
1071
1072   if (!$ignret && $? >> 8 != 0) {
1073     warn "$::basename: ".quote($cmds).": non-zero return-code\n";
1074     return 0;
1075   }
1076
1077   return 1;
1078 }
1079
1080 # makespec(@)
1081 # Make a command specification when printing errors.
1082 sub makespec(@) {
1083   my (@cmd) = @_;
1084   my $spec = $cmd[0].' ...';
1085   my $lastref = 0;
1086   foreach (@cmd, '') {
1087     if ($lastref) {
1088       $spec .= " | $_ ...";
1089       $lastref = 0;
1090     }
1091     $lastref = 1 if (ref);
1092   }
1093   return $spec;
1094 }
1095
1096 # makeoutfile(template)
1097 # Make a unique output file for extraction command.
1098 sub makeoutfile($) {
1099   my ($template) = @_;
1100   my $file;
1101   do {
1102     $file = sprintf $template, int rand 10000;
1103   } while (-e $file);
1104   return $file;
1105 }
1106
1107 # makeoutdir()
1108 # Make a temporary (unique) output directory for extraction command.
1109 sub makeoutdir() {
1110   my $dir;
1111   do {
1112     $dir = sprintf $::cfg_tmpdir_name, int rand 10000;
1113   } while (-e $dir);
1114
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";
1119       return undef;
1120     }
1121     push @::rmdirs, $dir;
1122   }
1123   return $dir;
1124 }
1125
1126 # explain($)
1127 # Print on screen if $::opt_explain is true.
1128 sub explain($) {
1129   my ($msg) = @_;
1130   print STDERR $msg if ($::opt_explain || $::opt_simulate);
1131 }
1132
1133 # tailslash($)
1134 # If specified filename does not end with a slash,
1135 # add one and return the new filename.
1136 sub tailslash($) {
1137   my ($file) = @_;
1138   return ($file =~ /\/$/ ? $file : "$file/");
1139 }
1140
1141 # shquotemeta($)
1142 # A more sophisticated quotemeta for bourne shells.
1143 # (This should be used for printing only.)
1144 sub shquotemeta($) {
1145   my ($str) = @_;
1146   $str =~ s/([^A-Za-z0-9_.+,\/:=@%^-])/\\$1/g;
1147   return $str;
1148 }
1149
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};
1160
1161   if ($mode eq 'cat' && @args == 0) {
1162     die "$::basename: missing file argument\n"; #OK
1163   }
1164
1165   if ($mode eq 'add' && $create && !$::opt_force && (-e $archive || -l $archive)) {
1166     warn "$::basename: ".quote($archive).": refusing to overwrite existing file\n";
1167     return undef;
1168   }
1169
1170   push @cmd, ['|'], get_pager_program() if $::opt_use_pager;
1171
1172   my $olddir = undef;
1173   if ($needcwd) {
1174     $olddir = getcwd();
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";
1179         return undef;
1180       }
1181     }
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";
1186         return undef;
1187       }
1188     }
1189   }
1190
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";
1197         return undef;
1198       }
1199     }
1200     # XXX: can't save outdir with extract-to.
1201     return 1;
1202   }
1203
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";
1209       }
1210     }
1211     return undef;
1212   }
1213
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";
1218       return undef;
1219     }
1220   }
1221
1222   return undef if $::opt_simulate;
1223
1224   if (!opendir(DIR, $outdir)) {
1225     warn "$::basename: ".quote($outdir).": cannot list - $!\n";
1226     return undef;
1227   }
1228   my @files = grep !/^\.\.?$/, readdir DIR;
1229   closedir DIR;
1230
1231   my $archivebase = File::Basename::basename($archive);
1232   my $reason;
1233   my $adddir = 0;
1234   if (@files == 0) {
1235     warn quote($archivebase).": archive is empty\n";
1236     rmdir $outdir;
1237     return undef;
1238   } elsif ($::opt_extract_subdir) {
1239     $reason = 'forced';
1240   } elsif (@files == 1) {
1241     my $fromfile = File::Spec->catfile($outdir, $files[0]);
1242     if ($::opt_force || (!-l $files[0] && !-e $files[0])) {
1243
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);
1248         if (!@statinfo) {
1249           warn quote($fromfile).": cannot get file info - $!\n";
1250           return undef;
1251         }
1252         $oldmode = $statinfo[2];
1253         if (!chmod(0700, $fromfile)) {
1254           warn quote($fromfile).": cannot change mode - $!\n";
1255           return undef;
1256         }
1257       }
1258
1259       if (!rename $fromfile, $files[0]) {
1260         warn quote($fromfile).": cannot rename - $!\n";
1261         return undef;
1262       }
1263       rmdir $outdir;
1264
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";
1269           return undef;
1270         }
1271       }
1272
1273       if ($::cfg_show_extracted) {
1274         my $file = ($files[0] =~ /\// ? dirname($files[0]) : $files[0]);
1275         warn quote($archivebase).": extracted to `".quote($file)."'\n" ;
1276       }
1277
1278       save_outdir($files[0]);
1279       return $files[0];
1280     }
1281     $reason = 'local file exists';
1282     $adddir = 1 if (!-l $files[0] && -d $files[0]);
1283   } else {
1284     $reason = 'multiple files in root';
1285   }
1286
1287   my $localoutdir = stripext($archivebase);
1288   if (!-e $localoutdir) {
1289     if (!rename $outdir, $localoutdir) {
1290       warn quote($outdir).": cannot rename - $!\n";
1291       return undef;
1292     }
1293     $outdir = $localoutdir;
1294   }
1295
1296   warn quote($archivebase).": extracted to `".quote($outdir)."' ($reason)\n";
1297   save_outdir($adddir ? File::Spec->catfile($outdir, $files[0]) : $outdir);
1298   return $outdir;
1299 }
1300
1301 # stripext(file)
1302 # Strip extension from the specified file.
1303 sub stripext($) {
1304   my ($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/\.[^.]+$//);
1335   return $file;
1336 }
1337
1338 # formatext(format)
1339 # Return the usual extension for the specified file format
1340 sub formatext($) {
1341   my ($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";
1376 }
1377
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($) {
1384   my ($fmt) = @_;
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';
1395   return 0;
1396 }
1397
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;
1405   my @fileoutput = (
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|$)/],
1443   );
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)$/],
1454
1455     ['7z',             qr/\.7z$/],
1456     ['ace',            qr/\.ace$/],
1457     ['alzip',          qr/\.alz$/],
1458     ['ar',             qr/\.a$/],
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$/],
1478     ['xz',             qr/\.xz$/],
1479     ['zip',            qr/\.zip$/],
1480   );
1481
1482   if ($manual) {
1483     $spec =~ tr/+/./;
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/;
1495     $spec =~ s/^ar$/a/;
1496   }
1497   if (!$::cfg_use_file_always) {
1498     foreach my $formatinfo (@fileextensions) {
1499       my ($format, $regex) = @{$formatinfo};
1500       return $format if ($spec =~ $regex);
1501     }
1502   }
1503   if (!$manual && $::cfg_use_file) {
1504     if (!-e $file) {
1505       warn "$::basename: ".quote($file).": no such file and cannot identify format from extension\n";
1506       return;
1507     }
1508     if (!sysopen(TMP, $file, O_RDONLY)) {
1509       warn "$::basename: ".quote($file).": cannot open - $!\n";
1510       return;
1511     }
1512     close TMP;
1513     if (!-f $file) {
1514       warn "$::basename: ".quote($file).": not a regular file\n";
1515       return;
1516     }
1517     if ($::opt_verbosity >= 1) {
1518             if ($::cfg_use_file_always) {
1519         warn "$::basename: ".quote($file).": identifying format using file\n";
1520             } else {
1521         warn "$::basename: ".quote($file).": format not known, identifying using file\n";
1522                         }
1523     }
1524     my @cmd = ($::cfg_path_file, '-b', '-L', '-z', '--', $file);
1525     $spec = backticks(@cmd);
1526     if (!defined $spec) {
1527       warn "$::basename: $::errmsg\n";
1528       return;
1529     }
1530     if ($? & 0xFF != 0) {
1531       warn "$::basename: ".quote($::cfg_path_file).": abnormal exit\n";
1532       return;
1533     }
1534     if ($? >> 8 != 0) {
1535       warn "$::basename: ".quote($file).": unknown file format\n";
1536       return;
1537     }
1538     chomp $spec;
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;
1543         return $format;
1544       }
1545     }
1546     warn "$::basename: ".quote($file).": unsupported file format `$spec'\n";
1547     return;
1548   }
1549   warn "$::basename: ".quote($file).": unrecognized file format\n";
1550   return;
1551 }
1552
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
1557 # the command line.
1558 sub backticks(@) {
1559   if (!pipe(IN,OUT)) {
1560     $::errmsg = "pipe failed - $!";
1561     return;
1562   }
1563   my $child = fork;
1564   if (!defined $child) {
1565     $::errmsg = "fork failed - $!";
1566     return;
1567   }
1568   if ($child == 0) {
1569     close IN || exit 1;
1570     close STDOUT || exit 1;
1571     open(STDOUT, '>&OUT') || exit 1;
1572     close OUT || exit 1;
1573     $SIG{__WARN__} = sub {};
1574     exec(@_) || exit 1;
1575   }
1576   close OUT;
1577   my $text = join('', <IN>);
1578   close IN;
1579   if (waitpid($child,0) != $child && $^O ne 'MSWin32') {
1580     $::errmsg = "waitpid failed - $!";
1581     return;
1582   }
1583   return $text;
1584 }
1585
1586 # set_config_option(variable, value)
1587 # Set a configuration option.
1588 sub set_config_option($$$) {
1589   my ($var, $val, $context) = @_;
1590   my %optionmap = (
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)$/ ],
1660   );
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];
1667   }
1668   my ($varref,$check) = @{$optionmap{$var}}[1,2];
1669   die $::basename,': ',$context,'invalid value for `',$var,"'\n" if $val !~ $check;
1670   ${$varref} = $val;
1671   return 1;
1672 }
1673
1674 # readconfig(file)
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
1685   while (<FILE>) {
1686     chomp;
1687     next if /^\s*(#(.*))?$/;
1688     my ($var,$val) = /^(.*?)\s+([^\s].*)$/; # joe markup bug -> ]]
1689     set_config_option($var, $val, quote($file).':'.$..': ');
1690   }
1691   close(FILE);
1692 }
1693
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($) {
1699   my ($dir) = @_;
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);
1706   closedir(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);
1711     } else {
1712       unlink $file || die "$::basename: ".quote($file).": cannot remove - $!\n";
1713     }
1714   }
1715   chdir $::up || die "$::basename: $::up: cannot change to - $!\n";
1716   rmdir $dir || die "$::basename: ".quote($dir).": cannot remove - $!\n";
1717 }
1718
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($) {
1725   my ($dir) = @_;
1726   my $result = $dir;
1727   if (opendir(my $dh, $dir)) {
1728     my @files;
1729     for (0..3) {
1730       my $file = readdir($dh);
1731       last if !defined $file;
1732       next if $file eq '.' || $file eq '..';
1733       push @files, $file;
1734     }
1735     closedir($dh);
1736     $result = File::Spec->catfile($dir, $files[0]) if @files == 1;
1737   }
1738   return $result;
1739 }
1740
1741 # makeabsolute(file)
1742 # Return the absolute version of file.
1743 sub makeabsolute($) {
1744   my ($file) = @_;
1745   return $file if (substr($file, 0, 1) eq '/');
1746   return File::Spec->catfile(getcwd(), $file);
1747 }
1748
1749 # quote(string)
1750 # Quote a style like the GNU fileutils would do (`locale'
1751 # quoting style).
1752 sub quote($) {
1753   my ($in) = @_;
1754   my $out = '';
1755   for (my $c = 0; $c < length($in); $c++) {
1756     my $ch = substr($in, $c, 1);
1757     if ($ch eq "\b") {
1758       $out .= "\\b";
1759     } elsif ($ch eq "\f") {
1760       $out .= "\\f";
1761     } elsif ($ch eq "\n") {
1762       $out .= "\\n";
1763     } elsif ($ch eq "\r") {
1764       $out .= "\\r";
1765     } elsif ($ch eq "\t") {
1766       $out .= "\\t";
1767     } elsif (ord($ch) == 11) {      # Vertical Tab, \v
1768       $out .= "\\v";
1769     } elsif ($ch eq "\\") {
1770       $out .= "\\\\";
1771     } elsif ($ch eq "'") {
1772       $out .= "\\'";
1773     } elsif ($ch !~ /[[:print:]]/) {
1774       $out .= sprintf('\\%03o', ord($ch));
1775     } else {
1776       $out .= $ch;
1777     }
1778   }
1779   return $out;
1780 }
1781
1782 # shell_execute(@)
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
1787 # unquotable!
1788 sub shell_execute(@) {
1789   my @cmdspec = @_;
1790   my $start = 0;
1791   my $c;
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]);
1795       $start = $c+1;
1796     }
1797   }
1798   if ($start != $c) {
1799     return 0 if !shell_execute_single_statement(@cmdspec[$start..$c-1]);
1800   }
1801   return 1;
1802 }
1803
1804 sub shell_execute_single_statement(@) {
1805   my (@cmdspec) = @_;
1806
1807   while (@cmdspec > 0) {
1808     my @cmds = ();
1809     my $start = 0;
1810     my $redir_out = undef;
1811     #my $more_cmds = 0;
1812     my $c;
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];
1818           $start = $c+2;
1819           $c++;
1820         #} elsif (${$cmdspec[$c]}[0] eq ';') {
1821           #$more_cmds = 1;
1822         #  $start = $c+1;
1823         #  $c++;
1824         #  last;
1825         } elsif (${$cmdspec[$c]}[0] eq '|') {
1826           $start = $c+1;
1827         }
1828       }
1829     }
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";
1833     #}
1834     splice @cmdspec,0,$c;
1835
1836     $SIG{INT} = 'IGNORE';
1837
1838     my @ip = ();
1839     my @op = ();
1840     my @children = ();
1841     for (my $c = 0; $c <= $#cmds; $c++) {
1842       if ($c != $#cmds) {
1843         @op = reverse POSIX::pipe();
1844         if (!@op || !defined $op[0] || !defined $op[1]) {
1845           $::errmsg = "pipe failed - $!";
1846           return 0;
1847         }
1848       }
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 - $!";
1854           return 0;
1855         }
1856       }
1857       my $pid = fork();
1858       die "fork failed - $!\n" if !defined $pid;
1859       if ($pid == 0) {
1860         $SIG{INT} = '';
1861         if (@ip) {
1862           die "dup2 failed - $!\n" if POSIX::dup2($ip[1], 0) < 0;
1863           POSIX::close($_) foreach (@ip);
1864         }
1865         if (@op) {
1866           die "dup2 failed - $!\n" if POSIX::dup2($op[0], 1) < 0;
1867           POSIX::close($_) foreach (@op);
1868         }
1869         exec(@{$cmds[$c]}) || die ${$cmds[$c]}[0].": cannot execute - $!\n";
1870       }
1871       POSIX::close($op[0]) if ($c == $#cmds && defined $redir_out);
1872       POSIX::close($_) foreach (@ip);
1873       @ip = @op;
1874       @op = ();
1875       push @children, $pid;
1876     }
1877
1878     foreach (@children) {
1879       if (waitpid($_,0) < 0 && $^O ne 'MSWin32') {
1880         $::errmsg = "waitpid failed - $!";
1881         return 0;
1882       }
1883     }
1884     $SIG{INT} = '';
1885   }
1886
1887   return 1;
1888 }
1889
1890 # Write dir to file indicated by $::opt_save_outdir.
1891 #
1892 sub save_outdir($) {
1893   my ($dir) = @_;
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";
1897     } else {
1898       print TMP $dir, "\n";
1899       close(TMP);
1900     }
1901   }
1902 }
1903
1904 # Somewhat stupid subroutine to add xargs to the command line.
1905 #
1906 sub handle_empty_add(@) {
1907   my @cmd = @_;
1908   unshift @cmd, '--';
1909   unshift @cmd, '-0' if ($::opt_null);
1910   unshift @cmd, $::cfg_path_xargs;
1911   return @cmd;
1912 }
1913
1914 # Return a suitable pager command
1915 #
1916 sub get_pager_program {
1917   return $ENV{PAGER} if (exists $ENV{PAGER});
1918   return $::cfg_path_pager;
1919 }
1920
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) = @_;
1925
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));
1932     return;
1933   } elsif ($fmt1 =~ /^tar$/ && $fmt2 =~ /^tar\+/) {
1934     $fmt2 =~ s/^tar\+//;
1935     exit 1 if (!runcmds('add', $fmt2, $file2, $file1));
1936     return;
1937   }
1938
1939   if ($fmt1 =~ /^tar\+/ && $fmt2 =~ /^tar\+/) {
1940     $fmt1 =~ s/^tar\+//;
1941     $fmt2 =~ s/^tar\+//;
1942   }
1943
1944   my $newarchive;
1945   if (File::Spec->file_name_is_absolute($file2)) {
1946     $newarchive = $file2;
1947   } else {
1948     $newarchive = File::Spec->catdir($::up, $file2);
1949   }
1950
1951   my $outdir;
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";
1959   }
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);
1966   } else {
1967     exit 1 if !runcmds('add', $fmt2, $newarchive, $::cur);
1968   }
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?????
1972   }
1973   warn 'rm -r ',quote($outdir),"\n" if $::opt_explain || $::opt_simulate;
1974   if (!$::opt_simulate) {
1975     unlink_directory($outdir);
1976   }
1977 }
1978
1979 sub END {
1980   map (rmdir, @::rmdirs) if !$::opt_simulate; # Errors are ignored
1981 }