"Fossies" - the Fresh Open Source Software Archive

Member "atool-0.39.0/atool" (2 Apr 2012, 78058 Bytes) of package /linux/privat/old/atool-0.39.0.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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