mirror of
https://github.com/MidnightCommander/mc
synced 2024-12-22 20:36:50 +03:00
* extfs/uzip: New file from Oskar Liljeblad.
* extfs/README.uzip: Likewise. * extfs/Makefile.am: Adjust for constant uzip.
This commit is contained in:
Pavel Roskin
parent
efbe340d5e
commit
de997c6f3a
@ -1,3 +1,9 @@
|
||||
2001-03-07 Pavel Roskin <proski@gnu.org>
|
||||
|
||||
* extfs/uzip: New file from Oskar Liljeblad.
|
||||
* extfs/README.uzip: Likewise.
|
||||
* extfs/Makefile.am: Adjust for constant uzip.
|
||||
|
||||
2001-03-07 Pavel Machek <pavel@bug.ucw.cz>
|
||||
|
||||
* extfs/*uzip*: replace uzip with perl version by
|
||||
|
||||
@ -6,7 +6,7 @@ EXTFS_MISC = README extfs.ini unarj.diff sfs.ini
|
||||
|
||||
# Filters that don't need adaptation to the local system
|
||||
EXTFS_CONST = a apt audio deba debd dpkg hp48 mailfs patchfs rpm bpp \
|
||||
rpms trpm uarj
|
||||
rpms trpm uarj uzip
|
||||
|
||||
# Filters that need adaptation to the local system - source files
|
||||
EXTFS_IN = \
|
||||
@ -18,8 +18,7 @@ EXTFS_IN = \
|
||||
ftplist.in \
|
||||
uar.in \
|
||||
ulha.in \
|
||||
uha.in \
|
||||
uzip.in
|
||||
uha.in
|
||||
|
||||
# Filters that need adaptation to the local system - files to install
|
||||
EXTFS_OUT = \
|
||||
@ -31,8 +30,7 @@ EXTFS_OUT = \
|
||||
ftplist \
|
||||
uar \
|
||||
ulha \
|
||||
uha \
|
||||
uzip
|
||||
uha
|
||||
|
||||
extfs_DATA = $(EXTFS_MISC)
|
||||
|
||||
|
||||
125
vfs/extfs/README.uzip
Normal file
125
vfs/extfs/README.uzip
Normal file
@ -0,0 +1,125 @@
|
||||
Overview
|
||||
========
|
||||
|
||||
uzip is a module for the extfs Virtual File System (VFS) in
|
||||
Midnight Commander. It allows browsing, extraction and
|
||||
modification of zip archives.
|
||||
|
||||
uzip was written by Oskar Liljeblad. If you find a bug, or know
|
||||
of an improvement, please email me at osk@hem.passagen.se.
|
||||
|
||||
License and Copyright
|
||||
=====================
|
||||
|
||||
uzip is released under the terms of the GNU General Public License.
|
||||
uzip is copyright (C) 2000-2001 by Oskar Liljeblad.
|
||||
|
||||
Requirements
|
||||
============
|
||||
|
||||
Info-Zip mode:
|
||||
Info-ZIP unzip 5.41 (for listing and extracting files)
|
||||
Info-ZIP zip 2.30 (for adding and deleting files)
|
||||
|
||||
otherwise:
|
||||
any unzip
|
||||
any zip
|
||||
|
||||
History
|
||||
=======
|
||||
|
||||
2001-03-01 Oskar Liljeblad <osk@hem.passagen.se>
|
||||
|
||||
* Release 1.3.0.
|
||||
* Caching of files when listing archives has been fixed. (MC
|
||||
would list a directory twice in some cases.)
|
||||
* 'strict' is now used. (This is why global variables
|
||||
are now initialized using 'my'.)
|
||||
* Some code simplifications thanks to more understanding
|
||||
of perl :)
|
||||
* Minor documentation clarifications.
|
||||
|
||||
2001-02-21 Oskar Liljeblad <osk@hem.passagen.se>
|
||||
|
||||
* Release 1.2.0.
|
||||
* The 'rmdir' extfs command of uzip was modified not to fail
|
||||
when deleting directories that doesn't exist. (A different/
|
||||
better solution would be to recreate the automaticly deleted
|
||||
directories, but that's slower and harder to implement.)
|
||||
Strangely, the zip man page does not mention this delete-
|
||||
empty-directories behavior.
|
||||
|
||||
2000-10-31 Oskar Liljeblad <osk@hem.passagen.se>
|
||||
|
||||
* Release 1.1.0.
|
||||
* mczipfs_copyin: Fixed order of arguments.
|
||||
* safesystem, safeticks: Improved error handling.
|
||||
* mczipfs_copyout: Now allows error code 11, and redirects
|
||||
stderr to /dev/null.
|
||||
|
||||
2000-10-29 Oskar Liljeblad <osk@hem.passagen.se>
|
||||
|
||||
* Release 1.0.1.
|
||||
* Fixed bug causing files with special permission not to
|
||||
be listed.
|
||||
|
||||
2000-10-29 Oskar Liljeblad <osk@hem.passagen.se>
|
||||
|
||||
* Release 1.0.0: First version.
|
||||
|
||||
Differencies between new (Perl) and old (sh/AWK) uzip
|
||||
=====================================================
|
||||
|
||||
The script is written purely in Perl, which (hopefully) means
|
||||
faster execution and cleaner code.
|
||||
|
||||
Listing is done only with either zipinfo or unzip,
|
||||
not both at the same time. Previously unzip would be used
|
||||
if the archive contained non-unix file listings (after
|
||||
zipinfo was run). Now there is an option to choose which
|
||||
one to use (zipinfo is the default and preferred). This
|
||||
should make listing of non-unix archives faster.
|
||||
|
||||
Files appearing before their parent directories in the listings
|
||||
are now cached and printed later. This fixes a bug that would
|
||||
cause some directories to be listed twice.
|
||||
|
||||
Temporary filenames are choosen better. That is, they are
|
||||
generated using tmpnam(3). Previously, hardcoded filenames
|
||||
(in the current directory) would be used.
|
||||
|
||||
The error messages are much better. Errors are checked for
|
||||
(hopefully) all functions that can fail.
|
||||
|
||||
The copyin command no longer makes a copy of the file before
|
||||
adding it. Instead it makes a temporary directory in which
|
||||
a symlink to the original file is placed. This should speed
|
||||
up addition considerably.
|
||||
|
||||
The run command is supported.
|
||||
|
||||
The theoretic commands "mklink" and "linkout" are supported.
|
||||
However, MC extfs doesn't support these so they are rather
|
||||
useless at the moment.
|
||||
|
||||
Known problems and Unsupported features
|
||||
=======================================
|
||||
|
||||
Files added to the archive get listed with a+x permissions in MC.
|
||||
This appears to be a problem with the MC extfs, and (probably) not uzip.
|
||||
|
||||
Extracted files do not have the same modification/access date as
|
||||
in the archive. The same applies for permissions and ownership.
|
||||
Fortunately MC extfs will set these attributes based on the file
|
||||
listings.
|
||||
|
||||
Interpretation of special information ("central-directory extra field")
|
||||
in zip archives. This is used to store information such as universal
|
||||
time and unix UID/GID on files.
|
||||
|
||||
It would be nice if listing archives with symbolic links was faster.
|
||||
Unzip has to be executed once for each link. This is because the
|
||||
symbolic link file must be extracted in order to get the link
|
||||
destination.
|
||||
|
||||
-
|
||||
400
vfs/extfs/uzip
Normal file
400
vfs/extfs/uzip
Normal file
@ -0,0 +1,400 @@
|
||||
#! /usr/bin/perl -w
|
||||
#
|
||||
# zip file archive Virtual File System for Midnight Commander
|
||||
# Version 1.3.0 (2001-03-01).
|
||||
#
|
||||
# (C) 2000-2001 Oskar Liljeblad <osk@hem.passagen.se>.
|
||||
#
|
||||
|
||||
use POSIX;
|
||||
use File::Basename;
|
||||
use strict;
|
||||
|
||||
#
|
||||
# Configuration options
|
||||
#
|
||||
|
||||
# Location of the zip program
|
||||
my $app_zip = '/usr/bin/zip';
|
||||
# Location of the unzip program
|
||||
my $app_unzip = '/usr/bin/unzip';
|
||||
# Set this to 1 if zipinfo (unzip -Z) is to be used (recommended), otherwise 0.
|
||||
my $op_has_zipinfo = 1;
|
||||
|
||||
# Command used to list archives (zipinfo mode)
|
||||
my $cmd_list_zi = "$app_unzip -Z -l -T";
|
||||
# Command used to list archives (non-zipinfo mode)
|
||||
my $cmd_list_nzi = "$app_unzip -qq -v";
|
||||
# Command used to add a file to the archive
|
||||
my $cmd_add = "$app_zip -g";
|
||||
# Command used to add a link file to the archive (unused)
|
||||
my $cmd_addlink = "$app_zip -g -y";
|
||||
# Command used to delete a file from the archive
|
||||
my $cmd_delete = "$app_zip -d";
|
||||
# Command used to extract a file to standard out
|
||||
my $cmd_extract = "$app_unzip -p";
|
||||
|
||||
#
|
||||
# Main code
|
||||
#
|
||||
|
||||
die "uzip: missing command and/or archive arguments\n" if ($#ARGV < 1);
|
||||
|
||||
# Initialization of some global variables
|
||||
my $cmd = shift;
|
||||
my %known = ( './' => 1 );
|
||||
my %pending = ();
|
||||
my $oldpwd = POSIX::getcwd();
|
||||
my $archive = shift;
|
||||
my $aarchive = absolutize($archive, $oldpwd);
|
||||
my $cmd_list = ($op_has_zipinfo ? $cmd_list_zi : $cmd_list_nzi);
|
||||
my ($qarchive, $aqarchive) = map (quotemeta, $archive, $aarchive);
|
||||
|
||||
if ($cmd eq 'list') { &mczipfs_list(@ARGV); }
|
||||
if ($cmd eq 'rm') { &mczipfs_rm(@ARGV); }
|
||||
if ($cmd eq 'rmdir') { &mczipfs_rmdir(@ARGV); }
|
||||
if ($cmd eq 'mkdir') { &mczipfs_mkdir(@ARGV); }
|
||||
if ($cmd eq 'copyin') { &mczipfs_copyin(@ARGV); }
|
||||
if ($cmd eq 'copyout') { &mczipfs_copyout(@ARGV); }
|
||||
if ($cmd eq 'run') { &mczipfs_run(@ARGV); }
|
||||
#if ($cmd eq 'mklink') { &mczipfs_mklink(@ARGV); } # Not supported by MC extfs
|
||||
#if ($cmd eq 'linkout') { &mczipfs_linkout(@ARGV); } # Not supported by MC extfs
|
||||
exit 1;
|
||||
|
||||
# Remove a file from the archive.
|
||||
sub mczipfs_rm {
|
||||
my ($qfile) = map (quotemeta, @_);
|
||||
&checkargs(1, 'archive file', @_);
|
||||
&safesystem("$cmd_delete $qarchive $qfile >/dev/null");
|
||||
exit;
|
||||
}
|
||||
|
||||
# Remove an empty directory from the archive.
|
||||
# The only difference from mczipfs_rm is that we append an
|
||||
# additional slash to the directory name to remove. I am not
|
||||
# sure this is absolutely necessary, but it doesn't hurt.
|
||||
sub mczipfs_rmdir {
|
||||
my ($qfile) = map (quotemeta, @_);
|
||||
&checkargs(1, 'archive directory', @_);
|
||||
&safesystem("$cmd_delete $qarchive $qfile/ >/dev/null 2>&1", 12);
|
||||
exit;
|
||||
}
|
||||
|
||||
# Extract a file from the archive.
|
||||
# Note that we don't need to check if the file is a link,
|
||||
# because mc apparently doesn't call copyout for symbolic links.
|
||||
sub mczipfs_copyout {
|
||||
my ($qafile, $qfsfile) = map (quotemeta, @_);
|
||||
&checkargs(1, 'archive file', @_);
|
||||
&checkargs(2, 'local file', @_);
|
||||
&safesystem("$cmd_extract $qarchive $qafile > $qfsfile 2>/dev/null", 11);
|
||||
exit;
|
||||
}
|
||||
|
||||
# Add a file to the archive.
|
||||
# This is done by making a temporary directory, in which
|
||||
# we create a symlink the original file (with a new name).
|
||||
# Zip is then run to include the real file in the archive,
|
||||
# with the name of the symbolic link.
|
||||
# Here we also doesn't need to check for symbolic links,
|
||||
# because the mc extfs doesn't allow adding of symbolic
|
||||
# links.
|
||||
sub mczipfs_copyin {
|
||||
my ($afile, $fsfile) = @_;
|
||||
&checkargs(1, 'archive file', @_);
|
||||
&checkargs(2, 'local file', @_);
|
||||
my ($qafile) = quotemeta $afile;
|
||||
$fsfile = &absolutize($fsfile, $oldpwd);
|
||||
my $adir = File::Basename::dirname($afile);
|
||||
|
||||
my $tmpdir = &mktmpdir();
|
||||
chdir $tmpdir || &croak("chdir $tmpdir failed");
|
||||
&mkdirs($adir, 0700);
|
||||
symlink ($fsfile, $afile) || &croak("link $afile failed");
|
||||
&safesystem("$cmd_add $aqarchive $qafile >/dev/null");
|
||||
unlink $afile || &croak("unlink $afile failed");
|
||||
&rmdirs($adir);
|
||||
chdir $oldpwd || &croak("chdir $oldpwd failed");
|
||||
rmdir $tmpdir || &croak("rmdir $tmpdir failed");
|
||||
exit;
|
||||
}
|
||||
|
||||
# Add an empty directory the the archive.
|
||||
# This is similar to mczipfs_copyin, except that we don't need
|
||||
# to use symlinks.
|
||||
sub mczipfs_mkdir {
|
||||
my ($dir) = @_;
|
||||
&checkargs(1, 'directory', @_);
|
||||
my ($qdir) = quotemeta $dir;
|
||||
|
||||
my $tmpdir = &mktmpdir();
|
||||
chdir $tmpdir || &croak("chdir $tmpdir failed");
|
||||
&mkdirs($dir, 0700);
|
||||
&safesystem("$cmd_add $aqarchive $qdir >/dev/null");
|
||||
&rmdirs($dir);
|
||||
chdir $oldpwd || &croak("chdir $oldpwd failed");
|
||||
rmdir $tmpdir || &croak("rmdir $tmpdir failed");
|
||||
exit;
|
||||
}
|
||||
|
||||
# Add a link to the archive. This operation is not used yet,
|
||||
# because it is not supported by the MC extfs.
|
||||
sub mczipfs_mklink {
|
||||
my ($linkdest, $afile) = @_;
|
||||
&checkargs(1, 'link destination', @_);
|
||||
&checkargs(2, 'archive file', @_);
|
||||
my ($qafile) = quotemeta $afile;
|
||||
my $adir = File::Basename::dirname($afile);
|
||||
|
||||
my $tmpdir = &mktmpdir();
|
||||
chdir $tmpdir || &croak("chdir $tmpdir failed");
|
||||
&mkdirs($adir, 0700);
|
||||
symlink ($linkdest, $afile) || &croak("link $afile failed");
|
||||
&safesystem("$cmd_addlink $aqarchive $qafile >/dev/null");
|
||||
unlink $afile || &croak("unlink $afile failed");
|
||||
&rmdirs($adir);
|
||||
chdir $oldpwd || &croak("chdir $oldpwd failed");
|
||||
rmdir $tmpdir || &croak("rmdir $tmpdir failed");
|
||||
exit;
|
||||
}
|
||||
|
||||
# This operation is not used yet, because it is not
|
||||
# supported by the MC extfs.
|
||||
sub mczipfs_linkout {
|
||||
my ($afile, $fsfile) = @_;
|
||||
&checkargs(1, 'archive file', @_);
|
||||
&checkargs(2, 'local file', @_);
|
||||
my ($qafile) = map (quotemeta, $afile);
|
||||
|
||||
my $linkdest = &get_link_destination($afile);
|
||||
symlink ($linkdest, $fsfile) || &croak("link $fsfile failed");
|
||||
exit;
|
||||
}
|
||||
|
||||
# Use unzip to find the link destination of a certain file in the
|
||||
# archive.
|
||||
sub get_link_destination {
|
||||
my ($afile) = @_;
|
||||
my ($qafile) = map (quotemeta, $afile);
|
||||
my $linkdest = safeticks("$cmd_extract $qarchive $qafile");
|
||||
&croak ("extract failed", "link destination of $afile not found")
|
||||
if (!defined $linkdest || $linkdest eq '');
|
||||
return $linkdest;
|
||||
}
|
||||
|
||||
# List files in the archive.
|
||||
# Because mc currently doesn't allow a file's parent directory
|
||||
# to be listed after the file itself, we need to do some
|
||||
# rearranging of the output. Most of this is done in
|
||||
# checked_print_file.
|
||||
sub mczipfs_list {
|
||||
open (PIPE, "$cmd_list $qarchive |") || &croak("$app_unzip failed");
|
||||
if ($op_has_zipinfo) {
|
||||
while (<PIPE>) {
|
||||
chomp;
|
||||
next if /^Archive:/;
|
||||
next if /^\d+ file/;
|
||||
next if /^Empty zipfile\.$/;
|
||||
my @match = /^(.{10}) +([\d.]+) +([a-z\d]+) +(\d+) +([^ ]{2}) +(\d+) +([^ ]{4}) +(\d{4})(\d\d)(\d\d)\.(\d\d)(\d\d)(\d\d) +(.*)$/;
|
||||
next if ($#match != 13);
|
||||
&checked_print_file(@match);
|
||||
}
|
||||
} else {
|
||||
while (<PIPE>) {
|
||||
chomp;
|
||||
my @match = /^ +(\d+) +([^ ]+) +(\d+) +(\d+\%) +(\d?\d)-(\d?\d)-(\d\d) (\d?\d):(\d\d) +([0-9a-f]+) +(.*)$/;
|
||||
next if ($#match != 10);
|
||||
my @rmatch = ('', '', 'unknown', $match[0], '', $match[2], $match[1],
|
||||
$match[6] + ($match[6] < 70 ? 2000 : 1900), $match[4], $match[5],
|
||||
$match[7], $match[8], "00", $match[10]);
|
||||
&checked_print_file(@rmatch);
|
||||
}
|
||||
}
|
||||
if (!close (PIPE)) {
|
||||
&croak("$app_unzip failed") if ($! != 0);
|
||||
&croak("$app_unzip failed", 'non-zero exit status ('.($? >> 8).')')
|
||||
}
|
||||
|
||||
foreach my $key (sort keys %pending) {
|
||||
foreach my $file (@{ $pending{$key} }) {
|
||||
&print_file(@{ $file });
|
||||
}
|
||||
}
|
||||
|
||||
exit;
|
||||
}
|
||||
|
||||
# Execute a file in the archive, by first extracting it to a
|
||||
# temporary directory. The name of the extracted file will be
|
||||
# the same as the name of it in the archive.
|
||||
sub mczipfs_run {
|
||||
my ($afile) = @_;
|
||||
&checkargs(1, 'archive file', @_);
|
||||
my $qafile = quotemeta $afile;
|
||||
my $tmpdir = &mktmpdir();
|
||||
my $tmpfile = File::Basename::basename($afile);
|
||||
|
||||
chdir $tmpdir || &croak("chdir $tmpdir failed");
|
||||
&safesystem("$cmd_extract $aqarchive $qafile > $tmpfile");
|
||||
chmod 0700, $tmpfile;
|
||||
&safesystem("./$tmpfile");
|
||||
unlink $tmpfile || &croak("rm $tmpfile failed");
|
||||
chdir $oldpwd || &croak("chdir $oldpwd failed");
|
||||
rmdir $tmpdir || &croak("rmdir $tmpdir failed");
|
||||
exit;
|
||||
}
|
||||
|
||||
# This is called prior to printing the listing of a file.
|
||||
# A check is done to see if the parent directory of the file has already
|
||||
# been printed or not. If it hasn't, we must cache it (in %pending) and
|
||||
# print it later once the parent directory has been listed. When all
|
||||
# files have been processed, there may still be some that haven't been
|
||||
# printed because their parent directories weren't listed at all. These
|
||||
# files are dealt with in mczipfs_list.
|
||||
sub checked_print_file {
|
||||
my @waiting = ([ @_ ]);
|
||||
|
||||
while ($#waiting != -1) {
|
||||
my $item = shift @waiting;
|
||||
my $filename = ${$item}[13];
|
||||
my $dirname = File::Basename::dirname($filename) . '/';
|
||||
|
||||
if (exists $known{$dirname}) {
|
||||
&print_file(@{$item});
|
||||
if ($filename =~ /\/$/) {
|
||||
$known{$filename} = 1;
|
||||
if (exists $pending{$filename}) {
|
||||
push @waiting, @{ $pending{$filename} };
|
||||
delete $pending{$filename};
|
||||
}
|
||||
}
|
||||
} else {
|
||||
push @{$pending{$dirname}}, $item;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Print the mc extfs listing of a file from a set of parsed fields.
|
||||
# If the file is a link, we extract it from the zip archive and
|
||||
# include the output as the link destination. Because this output
|
||||
# is not newline terminated, we must execute unzip once for each
|
||||
# link file encountered.
|
||||
sub print_file {
|
||||
my ($perms,$zipver,$platform,$realsize,$format,$cmpsize,$comp,$year,$mon,$day,$hours,$mins,$secs,$filename) = @_;
|
||||
$mon = (qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/)[$mon-1];
|
||||
if ($platform ne 'unx') {
|
||||
$perms = ($filename =~ /\/$/ ? 'drwxr-xr-x' : '-rw-r--r--');
|
||||
}
|
||||
printf "%-10s 1 %-8d %-8d %8d $mon $day $year $hours:$mins $filename", $perms, $<, $(, $realsize;
|
||||
if ($platform eq 'unx' && $perms =~ /^l/) {
|
||||
my $linkdest = &get_link_destination($filename);
|
||||
print " -> $linkdest";
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
# Die with a reasonable error message.
|
||||
sub croak {
|
||||
my ($command, $desc) = @_;
|
||||
die "uzip ($cmd): $command - $desc\n" if (defined $desc);
|
||||
die "uzip ($cmd): $command - $!\n";
|
||||
}
|
||||
|
||||
# Make a set of directories, like the command `mkdir -p'.
|
||||
# This subroutine has been tailored for this script, and
|
||||
# because of that, it ignored the directory name '.'.
|
||||
sub mkdirs {
|
||||
my ($dirs, $mode) = @_;
|
||||
$dirs = &cleandirs($dirs);
|
||||
return if ($dirs eq '.');
|
||||
|
||||
my $newpos = -1;
|
||||
while (($newpos = index($dirs, '/', $newpos+1)) != -1) {
|
||||
my $dir = substr($dirs, 0, $newpos);
|
||||
mkdir ($dir, $mode) || &croak("mkdir $dir failed");
|
||||
}
|
||||
mkdir ($dirs, $mode) || &croak("mkdir $dirs failed");
|
||||
}
|
||||
|
||||
# Remove a set of directories, failing if the directories
|
||||
# contain other files.
|
||||
# This subroutine has been tailored for this script, and
|
||||
# because of that, it ignored the directory name '.'.
|
||||
sub rmdirs {
|
||||
my ($dirs) = @_;
|
||||
$dirs = &cleandirs($dirs);
|
||||
return if ($dirs eq '.');
|
||||
|
||||
rmdir $dirs || &croak("rmdir $dirs failed");
|
||||
my $newpos = length($dirs);
|
||||
while (($newpos = rindex($dirs, '/', $newpos-1)) != -1) {
|
||||
my $dir = substr($dirs, 0, $newpos);
|
||||
rmdir $dir || &croak("rmdir $dir failed");
|
||||
}
|
||||
}
|
||||
|
||||
# Return a semi-canonical directory name.
|
||||
sub cleandirs {
|
||||
my ($dir) = @_;
|
||||
$dir =~ s:/+:/:g;
|
||||
$dir =~ s:/*$::;
|
||||
return $dir;
|
||||
}
|
||||
|
||||
# Make a temporary directory with mode 0700.
|
||||
sub mktmpdir {
|
||||
while (1) {
|
||||
my $dir = POSIX::tmpnam();
|
||||
return $dir if mkdir ($dir, 0700);
|
||||
}
|
||||
}
|
||||
|
||||
# Make a filename absolute and return it.
|
||||
sub absolutize {
|
||||
my ($file, $pwd) = @_;
|
||||
return "$pwd/$file" if ($file !~ /^\//);
|
||||
return $file;
|
||||
}
|
||||
|
||||
# Like the system built-in function, but with error checking.
|
||||
# The other argument is an exit status to allow.
|
||||
sub safesystem {
|
||||
my ($command, @allowrc) = @_;
|
||||
my ($desc) = ($command =~ /^([^ ]*) */);
|
||||
$desc = File::Basename::basename($desc);
|
||||
system $command;
|
||||
my $rc = $?;
|
||||
&croak("`$desc' failed") if (($rc & 0xFF) != 0);
|
||||
if ($rc != 0) {
|
||||
$rc = $rc >> 8;
|
||||
foreach my $arc (@allowrc) {
|
||||
return if ($rc == $arc);
|
||||
}
|
||||
&croak("`$desc' failed", "non-zero exit status ($rc)");
|
||||
}
|
||||
}
|
||||
|
||||
# Like backticks built-in, but with error checking.
|
||||
sub safeticks {
|
||||
my ($command, @allowrc) = @_;
|
||||
my ($desc) = ($command =~ /^([^ ]*) /);
|
||||
$desc = File::Basename::basename($desc);
|
||||
my $out = `$command`;
|
||||
my $rc = $?;
|
||||
&croak("`$desc' failed") if (($rc & 0xFF) != 0);
|
||||
if ($rc != 0) {
|
||||
$rc = $rc >> 8;
|
||||
foreach my $arc (@allowrc) {
|
||||
return if ($rc == $arc);
|
||||
}
|
||||
&croak("`$desc' failed", "non-zero exit status ($rc)");
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
# Make sure enough arguments are supplied, or die.
|
||||
sub checkargs {
|
||||
my $count = shift;
|
||||
my $desc = shift;
|
||||
&croak('missing argument', $desc) if ($count-1 > $#_);
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user