summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2008-07-04 14:36:12 +0000
committerNorbert Preining <preining@logic.at>2008-07-04 14:36:12 +0000
commite7b12a2a60643054e3baff9557f490c23adfd33d (patch)
tree43edebf07654034f9aa67443f8bcc59d0d09926a
parent6737a5115a3e6b41f7fb21196e3bc9dbfaa09b8f (diff)
TLUtils.pm: add a rmtree function, imported from File/Path.pm
git-svn-id: svn://tug.org/texlive/trunk@9238 c570f23f-e606-0410-a88d-b1316a301751
-rw-r--r--Master/tlpkg/TeXLive/TLUtils.pm172
1 files changed, 172 insertions, 0 deletions
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index db267c05e36..c7a19de172c 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -39,6 +39,7 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure
TeXLive::TLUtils::dirname_and_basename($path);
TeXLive::TLUtils::dir_writable($path);
TeXLive::TLUtils::mkdirhier($path);
+ TeXLive::TLUtils::rmtree($root, $verbose, $safe);
TeXLive::TLUtils::copy($file, $target_dir);
TeXLive::TLUtils::download_file($path, $destination [, $progs ]);
TeXLive::TLUtils::setup_programs($bindir, $platform);
@@ -91,6 +92,7 @@ BEGIN {
&dirname_and_basename
&dir_writable
&mkdirhier
+ &rmtree
&copy
&install_package
&install_packages
@@ -509,6 +511,176 @@ sub mkdirhier {
=pod
+=item C<rmtree($root, $verbose, $safe)>
+
+The C<rmtree> function provides a convenient way to delete a
+subtree from the directory structure, much like the Unix command C<rm -r>.
+C<rmtree> takes three arguments:
+
+=over 4
+
+=item *
+
+the root of the subtree to delete, or a reference to
+a list of roots. All of the files and directories
+below each root, as well as the roots themselves,
+will be deleted.
+
+=item *
+
+a boolean value, which if TRUE will cause C<rmtree> to
+print a message each time it examines a file, giving the
+name of the file, and indicating whether it's using C<rmdir>
+or C<unlink> to remove it, or that it's skipping it.
+(defaults to FALSE)
+
+=item *
+
+a boolean value, which if TRUE will cause C<rmtree> to
+skip any files to which you do not have delete access
+(if running under VMS) or write access (if running
+under another OS). This will change in the future when
+a criterion for 'delete permission' under OSs other
+than VMS is settled. (defaults to FALSE)
+
+=back
+
+It returns the number of files successfully deleted. Symlinks are
+simply deleted and not followed.
+
+B<NOTE:> There are race conditions internal to the implementation of
+C<rmtree> making it unsafe to use on directory trees which may be
+altered or moved while C<rmtree> is running, and in particular on any
+directory trees with any path components or subdirectories potentially
+writable by untrusted users.
+
+Additionally, if the third parameter is not TRUE and C<rmtree> is
+interrupted, it may leave files and directories with permissions altered
+to allow deletion (and older versions of this module would even set
+files and directories to world-read/writable!)
+
+Note also that the occurrence of errors in C<rmtree> can be determined I<only>
+by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
+from the return value.
+
+=cut
+
+#taken from File/Path.pm
+#
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+# These OSes complain if you want to remove a file that you have no
+# write permission to:
+my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
+ $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
+
+sub rmtree {
+ my($roots, $verbose, $safe) = @_;
+ my(@files);
+ my($count) = 0;
+ $verbose ||= 0;
+ $safe ||= 0;
+
+ if ( defined($roots) && length($roots) ) {
+ $roots = [$roots] unless ref $roots;
+ } else {
+ warn "No root path(s) specified";
+ return 0;
+ }
+
+ my($root);
+ foreach $root (@{$roots}) {
+ if ($Is_MacOS) {
+ $root = ":$root" if $root !~ /:/;
+ $root =~ s#([^:])\z#$1:#;
+ } else {
+ $root =~ s#/\z##;
+ }
+ (undef, undef, my $rp) = lstat $root or next;
+ $rp &= 07777; # don't forget setuid, setgid, sticky bits
+ if ( -d _ ) {
+ # notabene: 0700 is for making readable in the first place,
+ # it's also intended to change it to writable in case we have
+ # to recurse in which case we are better than rm -rf for
+ # subtrees with strange permissions
+ chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ or warn "Can't make directory $root read+writeable: $!"
+ unless $safe;
+
+ if (opendir my $d, $root) {
+ no strict 'refs';
+ if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
+ # Blindly untaint dir names
+ @files = map { /^(.*)$/s ; $1 } readdir $d;
+ } else {
+ @files = readdir $d;
+ }
+ closedir $d;
+ } else {
+ warn "Can't read $root: $!";
+ @files = ();
+ }
+ # Deleting large numbers of files from VMS Files-11 filesystems
+ # is faster if done in reverse ASCIIbetical order
+ @files = reverse @files if $Is_VMS;
+ ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
+ if ($Is_MacOS) {
+ @files = map("$root$_", @files);
+ } else {
+ @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
+ }
+ $count += rmtree(\@files,$verbose,$safe);
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
+ chmod $rp | 0700, $root
+ or warn "Can't make directory $root writeable: $!"
+ if $force_writeable;
+ print "rmdir $root\n" if $verbose;
+ if (rmdir $root) {
+ ++$count;
+ } else {
+ warn "Can't remove directory $root: $!";
+ chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ or warn("and can't restore permissions to "
+ . sprintf("0%o",$rp) . "\n");
+ }
+ } else {
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root)
+ : !(-l $root || -w $root)))
+ {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
+ chmod $rp | 0600, $root
+ or warn "Can't make file $root writeable: $!"
+ if $force_writeable;
+ print "unlink $root\n" if $verbose;
+ # delete all versions under VMS
+ for (;;) {
+ unless (unlink $root) {
+ warn "Can't unlink file $root: $!";
+ if ($force_writeable) {
+ chmod $rp, $root
+ or warn("and can't restore permissions to "
+ . sprintf("0%o",$rp) . "\n");
+ }
+ last;
+ }
+ ++$count;
+ last unless $Is_VMS && lstat $root;
+ }
+ }
+ }
+ $count;
+}
+
+=pod
+
=item C<copy($file, $target_dir)>
Copy file C<$file> to directory C<$target_dir>. No external programs