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