atool.in

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