vfs/extfs/uzip.in

   1 #! @PERL@ -w
   2 #
   3 # zip file archive Virtual File System for Midnight Commander
   4 # Version 1.4.0 (2001-08-07).
   5 #
   6 # (C) 2000-2001  Oskar Liljeblad <osk@hem.passagen.se>.
   7 #
   8
   9 use POSIX;
  10 use File::Basename;
  11 use strict;
  12
  13 #
  14 # Configuration options
  15 #
  16
  17 # Location of the zip program
  18 my $app_zip = "@ZIP@";
  19 # Location of the unzip program
  20 my $app_unzip = "@UNZIP@";
  21 # Set this to 1 if zipinfo (unzip -Z) is to be used (recommended), otherwise 0.
  22 my $op_has_zipinfo = @HAVE_ZIPINFO@;
  23
  24 # Command used to list archives (zipinfo mode)
  25 my $cmd_list_zi = "$app_unzip -Z -l -T";
  26 # Command used to list archives (non-zipinfo mode)
  27 my $cmd_list_nzi = "$app_unzip -qq -v";
  28 # Command used to add a file to the archive
  29 my $cmd_add = "$app_zip -g";
  30 # Command used to add a link file to the archive (unused)
  31 my $cmd_addlink = "$app_zip -g -y";
  32 # Command used to delete a file from the archive
  33 my $cmd_delete = "$app_zip -d";
  34 # Command used to extract a file to standard out
  35 my $cmd_extract = "$app_unzip -p";
  36
  37 # -rw-r--r--  2.2 unx     2891 tx     1435 defN 20000330.211927 ./edit.html
  38 # (perm) (?) (?) (size) (?) (zippedsize) (method) (yyyy)(mm)(dd)(HH)(MM) (fname)
  39 my $regex_zipinfo_line = qr"^(\S{7,10})\s+(\d+\.\d+)\s+(\S+)\s+(\d+)\s+(\S\S)\s+(\d+)\s+(\S{4})\s+(\d{4})(\d\d)(\d\d)\.(\d\d)(\d\d)(\d\d)\s(.*)$";
  40
  41 #     2891  Defl:N     1435  50%  03-30-00 21:19  50cbaaf8  ./edit.html
  42 # (size) (method) (zippedsize) (zipratio) (mm)(dd)(yy)(HH)(MM) (cksum) (fname)
  43 my $regex_nonzipinfo_line = qr"^\s*(\d+)\s+(\S+)\s+(\d+)\s+(-?\d+\%)\s+(\d?\d)-(\d?\d)-(\d\d)\s+(\d?\d):(\d\d)\s+([0-9a-f]+)\s\s(.*)$";
  44
  45 #
  46 # Main code
  47 #
  48
  49 die "uzip: missing command and/or archive arguments\n" if ($#ARGV < 1);
  50
  51 # Initialization of some global variables
  52 my $cmd = shift;
  53 my %known = ( './' => 1 );
  54 my %pending = ();
  55 my $oldpwd = POSIX::getcwd();
  56 my $archive = shift;
  57 my $aarchive = absolutize($archive, $oldpwd);
  58 my $cmd_list = ($op_has_zipinfo ? $cmd_list_zi : $cmd_list_nzi);
  59 my ($qarchive, $aqarchive) = map (quotemeta, $archive, $aarchive);
  60
  61 # Strip all "." and ".." path components from a pathname.
  62 sub zipfs_canonicalize_pathname($) {
  63   my ($fname) = @_;
  64   $fname =~ s,/+,/,g;
  65   $fname =~ s,(^|/)(?:\.?\./)+,$1,;
  66   return $fname;
  67 }
  68
  69 # The Midnight Commander never calls this script with archive pathnames
  70 # starting with either "./" or "../". Some ZIP files contain such names,
  71 # so we need to build a translation table for them.
  72 my $zipfs_realpathname_table = undef;
  73 sub zipfs_realpathname($) {
  74     my ($fname) = @_;
  75
  76     if (!defined($zipfs_realpathname_table)) {
  77         $zipfs_realpathname_table = {};
  78         if (!open(ZIP, "$cmd_list $qarchive |")) {
  79             return $fname;
  80         }
  81         foreach my $line (<ZIP>) {
  82             $line =~ s/\r*\n*$//;
  83             if ($op_has_zipinfo) {
  84                 if ($line =~ $regex_zipinfo_line) {
  85                     my ($fname) = ($14);
  86                     $zipfs_realpathname_table->{zipfs_canonicalize_pathname($fname)} = $fname;
  87                 }
  88             } else {
  89                 if ($line =~ $regex_nonzipinfo_line) {
  90                     my ($fname) = ($11);
  91                     $zipfs_realpathname_table->{zipfs_canonicalize_pathname($fname)} = $fname;
  92                 }
  93             }
  94         }
  95         if (!close(ZIP)) {
  96             return $fname;
  97         }
  98     }
  99     if (exists($zipfs_realpathname_table->{$fname})) {
 100         return $zipfs_realpathname_table->{$fname};
 101     }
 102     return $fname;
 103 }
 104
 105 if ($cmd eq 'list')    { &mczipfs_list(@ARGV); }
 106 if ($cmd eq 'rm')      { &mczipfs_rm(@ARGV); }
 107 if ($cmd eq 'rmdir')   { &mczipfs_rmdir(@ARGV); }
 108 if ($cmd eq 'mkdir')   { &mczipfs_mkdir(@ARGV); }
 109 if ($cmd eq 'copyin')  { &mczipfs_copyin(@ARGV); }
 110 if ($cmd eq 'copyout') { &mczipfs_copyout(@ARGV); }
 111 if ($cmd eq 'run')               { &mczipfs_run(@ARGV); }
 112 #if ($cmd eq 'mklink')  { &mczipfs_mklink(@ARGV); }             # Not supported by MC extfs
 113 #if ($cmd eq 'linkout') { &mczipfs_linkout(@ARGV); }    # Not supported by MC extfs
 114 exit 1;
 115
 116 # Remove a file from the archive.
 117 sub mczipfs_rm {
 118         my ($qfile) = map { &zipquotemeta(zipfs_realpathname($_)) } @_;
 119
 120         # "./" at the beginning of pathnames is stripped by Info-ZIP,
 121         # so convert it to "[.]/" to prevent stripping.
 122         $qfile =~ s/^\\\./[.]/;
 123
 124         &checkargs(1, 'archive file', @_);
 125         &safesystem("$cmd_delete $qarchive $qfile >/dev/null");
 126         exit;
 127 }
 128
 129 # Remove an empty directory from the archive.
 130 # The only difference from mczipfs_rm is that we append an
 131 # additional slash to the directory name to remove. I am not
 132 # sure this is absolutely necessary, but it doesn't hurt.
 133 sub mczipfs_rmdir {
 134         my ($qfile) = map { &zipquotemeta(zipfs_realpathname($_)) } @_;
 135         &checkargs(1, 'archive directory', @_);
 136         &safesystem("$cmd_delete $qarchive $qfile/ >/dev/null", 12);
 137   exit;
 138 }
 139
 140 # Extract a file from the archive.
 141 # Note that we don't need to check if the file is a link,
 142 # because mc apparently doesn't call copyout for symbolic links.
 143 sub mczipfs_copyout {
 144         my ($qafile, $qfsfile) = map { &zipquotemeta(zipfs_realpathname($_)) } @_;
 145         &checkargs(1, 'archive file', @_);
 146         &checkargs(2, 'local file', @_);
 147         &safesystem("$cmd_extract $qarchive $qafile > $qfsfile", 11);
 148   exit;
 149 }
 150
 151 # Add a file to the archive.
 152 # This is done by making a temporary directory, in which
 153 # we create a symlink the original file (with a new name).
 154 # Zip is then run to include the real file in the archive,
 155 # with the name of the symbolic link.
 156 # Here we also doesn't need to check for symbolic links,
 157 # because the mc extfs doesn't allow adding of symbolic
 158 # links.
 159 sub mczipfs_copyin {
 160         my ($afile, $fsfile) = @_;
 161         &checkargs(1, 'archive file', @_);
 162         &checkargs(2, 'local file', @_);
 163         my ($qafile) = quotemeta $afile;
 164         $fsfile = &absolutize($fsfile, $oldpwd);
 165         my $adir = File::Basename::dirname($afile);
 166
 167         my $tmpdir = &mktmpdir();
 168         chdir $tmpdir || &croak("chdir $tmpdir failed");
 169         &mkdirs($adir, 0700);
 170         symlink ($fsfile, $afile) || &croak("link $afile failed");
 171         &safesystem("$cmd_add $aqarchive $qafile >/dev/null");
 172         unlink $afile || &croak("unlink $afile failed");
 173         &rmdirs($adir);
 174         chdir $oldpwd || &croak("chdir $oldpwd failed");
 175         rmdir $tmpdir || &croak("rmdir $tmpdir failed");
 176   exit;
 177 }
 178
 179 # Add an empty directory the the archive.
 180 # This is similar to mczipfs_copyin, except that we don't need
 181 # to use symlinks.
 182 sub mczipfs_mkdir {
 183         my ($dir) = @_;
 184         &checkargs(1, 'directory', @_);
 185         my ($qdir) = quotemeta $dir;
 186
 187         my $tmpdir = &mktmpdir();
 188         chdir $tmpdir || &croak("chdir $tmpdir failed");
 189         &mkdirs($dir, 0700);
 190         &safesystem("$cmd_add $aqarchive $qdir >/dev/null");
 191         &rmdirs($dir);
 192         chdir $oldpwd || &croak("chdir $oldpwd failed");
 193         rmdir $tmpdir || &croak("rmdir $tmpdir failed");
 194   exit;
 195 }
 196
 197 # Add a link to the archive. This operation is not used yet,
 198 # because it is not supported by the MC extfs.
 199 sub mczipfs_mklink {
 200         my ($linkdest, $afile) = @_;
 201         &checkargs(1, 'link destination', @_);
 202         &checkargs(2, 'archive file', @_);
 203         my ($qafile) = quotemeta $afile;
 204         my $adir = File::Basename::dirname($afile);
 205
 206         my $tmpdir = &mktmpdir();
 207         chdir $tmpdir || &croak("chdir $tmpdir failed");
 208         &mkdirs($adir, 0700);
 209         symlink ($linkdest, $afile) || &croak("link $afile failed");
 210         &safesystem("$cmd_addlink $aqarchive $qafile >/dev/null");
 211         unlink $afile || &croak("unlink $afile failed");
 212         &rmdirs($adir);
 213         chdir $oldpwd || &croak("chdir $oldpwd failed");
 214         rmdir $tmpdir || &croak("rmdir $tmpdir failed");
 215   exit;
 216 }
 217
 218 # This operation is not used yet, because it is not
 219 # supported by the MC extfs.
 220 sub mczipfs_linkout {
 221         my ($afile, $fsfile) = @_;
 222         &checkargs(1, 'archive file', @_);
 223         &checkargs(2, 'local file', @_);
 224         my ($qafile) = map { &zipquotemeta($_) } $afile;
 225
 226         my $linkdest = &get_link_destination($afile);
 227         symlink ($linkdest, $fsfile) || &croak("link $fsfile failed");
 228   exit;
 229 }
 230
 231 # Use unzip to find the link destination of a certain file in the
 232 # archive.
 233 sub get_link_destination {
 234         my ($afile) = @_;
 235         my ($qafile) = map { &zipquotemeta($_) } $afile;
 236         my $linkdest = safeticks("$cmd_extract $qarchive $qafile");
 237         &croak ("extract failed", "link destination of $afile not found")
 238                         if (!defined $linkdest || $linkdest eq '');
 239         return $linkdest;
 240 }
 241
 242 # List files in the archive.
 243 # Because mc currently doesn't allow a file's parent directory
 244 # to be listed after the file itself, we need to do some
 245 # rearranging of the output. Most of this is done in
 246 # checked_print_file.
 247 sub mczipfs_list {
 248         open (PIPE, "$cmd_list $qarchive |") || &croak("$app_unzip failed");
 249         if ($op_has_zipinfo) {
 250                 while (<PIPE>) {
 251                         chomp;
 252                         next if /^Archive:/;
 253                         next if /^\d+ file/;
 254                         next if /^Empty zipfile\.$/;
 255                         my @match = /$regex_zipinfo_line/;
 256                         next if ($#match != 13);
 257                         &checked_print_file(@match);
 258                 }
 259         } else {
 260                 while (<PIPE>) {
 261                         chomp;
 262                         my @match = /$regex_nonzipinfo_line/;
 263                         next if ($#match != 10);
 264                         my @rmatch = ('', '', 'unknown', $match[0], '', $match[2], $match[1],
 265                                         $match[6] + ($match[6] < 70 ? 2000 : 1900), $match[4], $match[5],
 266                                         $match[7], $match[8], "00", $match[10]);
 267                         &checked_print_file(@rmatch);
 268                 }
 269         }
 270         if (!close (PIPE)) {
 271                 &croak("$app_unzip failed") if ($! != 0);
 272                 &croak("$app_unzip failed", 'non-zero exit status ('.($? >> 8).')')
 273         }
 274
 275         foreach my $key (sort keys %pending) {
 276                 foreach my $file (@{ $pending{$key} }) {
 277                         &print_file(@{ $file });
 278                 }
 279         }
 280
 281   exit;
 282 }
 283
 284 # Execute a file in the archive, by first extracting it to a
 285 # temporary directory. The name of the extracted file will be
 286 # the same as the name of it in the archive.
 287 sub mczipfs_run {
 288         my ($afile) = @_;
 289         &checkargs(1, 'archive file', @_);
 290         my $qafile = &zipquotemeta(zipfs_realpathname($afile));
 291         my $tmpdir = &mktmpdir();
 292         my $tmpfile = File::Basename::basename($afile);
 293
 294         chdir $tmpdir || &croak("chdir $tmpdir failed");
 295         &safesystem("$cmd_extract $aqarchive $qafile > $tmpfile");
 296   chmod 0700, $tmpfile;
 297         &safesystem("./$tmpfile");
 298         unlink $tmpfile || &croak("rm $tmpfile failed");
 299         chdir $oldpwd || &croak("chdir $oldpwd failed");
 300         rmdir $tmpdir || &croak("rmdir $tmpdir failed");
 301   exit;
 302 }
 303
 304 # This is called prior to printing the listing of a file.
 305 # A check is done to see if the parent directory of the file has already
 306 # been printed or not. If it hasn't, we must cache it (in %pending) and
 307 # print it later once the parent directory has been listed. When all
 308 # files have been processed, there may still be some that haven't been
 309 # printed because their parent directories weren't listed at all. These
 310 # files are dealt with in mczipfs_list.
 311 sub checked_print_file {
 312         my @waiting = ([ @_ ]);
 313
 314         while ($#waiting != -1) {
 315                 my $item = shift @waiting;
 316                 my $filename = ${$item}[13];
 317                 my $dirname = File::Basename::dirname($filename) . '/';
 318
 319                 if (exists $known{$dirname}) {
 320                         &print_file(@{$item});
 321                         if ($filename =~ /\/$/) {
 322                                 $known{$filename} = 1;
 323                                 if (exists $pending{$filename}) {
 324                                         push @waiting, @{ $pending{$filename} };
 325                                         delete $pending{$filename};
 326                                 }
 327                         }
 328                 } else {
 329                         push @{$pending{$dirname}}, $item;
 330                 }
 331         }
 332 }
 333
 334 # Print the mc extfs listing of a file from a set of parsed fields.
 335 # If the file is a link, we extract it from the zip archive and
 336 # include the output as the link destination. Because this output
 337 # is not newline terminated, we must execute unzip once for each
 338 # link file encountered.
 339 sub print_file {
 340         my ($perms,$zipver,$platform,$realsize,$format,$cmpsize,$comp,$year,$mon,$day,$hours,$mins,$secs,$filename) = @_;
 341         if ($platform ne 'unx') {
 342                 $perms = ($filename =~ /\/$/ ? 'drwxr-xr-x' : '-rw-r--r--');
 343         }
 344         printf "%-10s    1 %-8d %-8d %8s %s/%s/%s %s:%s:%s %s", $perms, $<,
 345                 $(, $realsize, $mon, $day, $year, $hours, $mins, $secs, $filename;
 346         if ($platform eq 'unx' && $perms =~ /^l/) {
 347                 my $linkdest = &get_link_destination($filename);
 348                 print " -> $linkdest";
 349         }
 350         print "\n";
 351 }
 352
 353 # Die with a reasonable error message.
 354 sub croak {
 355         my ($command, $desc) = @_;
 356         die "uzip ($cmd): $command - $desc\n" if (defined $desc);
 357         die "uzip ($cmd): $command - $!\n";
 358 }
 359
 360 # Make a set of directories, like the command `mkdir -p'.
 361 # This subroutine has been tailored for this script, and
 362 # because of that, it ignored the directory name '.'.
 363 sub mkdirs {
 364         my ($dirs, $mode) = @_;
 365         $dirs = &cleandirs($dirs);
 366         return if ($dirs eq '.');
 367
 368         my $newpos = -1;
 369         while (($newpos = index($dirs, '/', $newpos+1)) != -1) {
 370                 my $dir = substr($dirs, 0, $newpos);
 371                 mkdir ($dir, $mode) || &croak("mkdir $dir failed");
 372         }
 373         mkdir ($dirs, $mode) || &croak("mkdir $dirs failed");
 374 }
 375
 376 # Remove a set of directories, failing if the directories
 377 # contain other files.
 378 # This subroutine has been tailored for this script, and
 379 # because of that, it ignored the directory name '.'.
 380 sub rmdirs {
 381         my ($dirs) = @_;
 382         $dirs = &cleandirs($dirs);
 383         return if ($dirs eq '.');
 384
 385         rmdir $dirs || &croak("rmdir $dirs failed");
 386         my $newpos = length($dirs);
 387         while (($newpos = rindex($dirs, '/', $newpos-1)) != -1) {
 388                 my $dir = substr($dirs, 0, $newpos);
 389                 rmdir $dir || &croak("rmdir $dir failed");
 390         }
 391 }
 392
 393 # Return a semi-canonical directory name.
 394 sub cleandirs {
 395         my ($dir) = @_;
 396         $dir =~ s:/+:/:g;
 397         $dir =~ s:/*$::;
 398         return $dir;
 399 }
 400
 401 # Make a temporary directory with mode 0700.
 402 sub mktmpdir {
 403         use File::Temp qw(mkdtemp);
 404         my $template = "/tmp/mcuzipfs.XXXXXX";
 405         $template="$ENV{MC_TMPDIR}/mcuzipfs.XXXXXX" if ($ENV{MC_TMPDIR});
 406         return mkdtemp($template);
 407 }
 408
 409 # Make a filename absolute and return it.
 410 sub absolutize {
 411         my ($file, $pwd) = @_;
 412         return "$pwd/$file" if ($file !~ /^\//);
 413         return $file;
 414 }
 415
 416 # Like the system built-in function, but with error checking.
 417 # The other argument is an exit status to allow.
 418 sub safesystem {
 419         my ($command, @allowrc) = @_;
 420         my ($desc) = ($command =~ /^([^ ]*) */);
 421         $desc = File::Basename::basename($desc);
 422         system $command;
 423         my $rc = $?;
 424         &croak("`$desc' failed") if (($rc & 0xFF) != 0);
 425         if ($rc != 0) {
 426                 $rc = $rc >> 8;
 427                 foreach my $arc (@allowrc) {
 428                         return if ($rc == $arc);
 429                 }
 430                 &croak("`$desc' failed", "non-zero exit status ($rc)");
 431         }
 432 }
 433
 434 # Like backticks built-in, but with error checking.
 435 sub safeticks {
 436         my ($command, @allowrc) = @_;
 437         my ($desc) = ($command =~ /^([^ ]*) /);
 438         $desc = File::Basename::basename($desc);
 439         my $out = `$command`;
 440         my $rc = $?;
 441         &croak("`$desc' failed") if (($rc & 0xFF) != 0);
 442         if ($rc != 0) {
 443                 $rc = $rc >> 8;
 444                 foreach my $arc (@allowrc) {
 445                         return if ($rc == $arc);
 446                 }
 447                 &croak("`$desc' failed", "non-zero exit status ($rc)");
 448         }
 449         return $out;
 450 }
 451
 452 # Make sure enough arguments are supplied, or die.
 453 sub checkargs {
 454         my $count = shift;
 455         my $desc = shift;
 456         &croak('missing argument', $desc) if ($count-1 > $#_);
 457 }
 458
 459 # Quote zip wildcard metacharacters. Unfortunately Info-ZIP zip and unzip
 460 # on unix interpret some wildcards in filenames, despite the fact that
 461 # the shell already does this. Thus this function.
 462 sub zipquotemeta {
 463         my ($name) = @_;
 464         my $out = '';
 465         for (my $c = 0; $c < length $name; $c++) {
 466                 my $ch = substr($name, $c, 1);
 467                 $out .= '\\' if (index('*?[]\\', $ch) != -1);
 468                 $out .= $ch;
 469         }
 470         return quotemeta($out);
 471 }