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

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