perl 5.004_04

7 files changed, 911 insertions, 218 deletions

diff --git a/gnu/usr.bin/perl/lib/File/Basename.pm b/gnu/usr.bin/perl/lib/File/Basename.pm
index daff148a638..e4863f8911a 100644
--- a/gnu/usr.bin/perl/lib/File/Basename.pm
+++ b/gnu/usr.bin/perl/lib/File/Basename.pm
@@ -2,8 +2,6 @@ package File::Basename;
 
 =head1 NAME
 
-Basename - parse file specifications
-
 fileparse - split a pathname into pieces
 
 basename - extract just the filename from a path
@@ -34,16 +32,23 @@ pieces using the syntax of different operating systems.
 =item fileparse_set_fstype
 
 You select the syntax via the routine fileparse_set_fstype().
+
 If the argument passed to it contains one of the substrings
-"VMS", "MSDOS", or "MacOS", the file specification syntax of that
-operating system is used in future calls to fileparse(),
-basename(), and dirname().  If it contains none of these
-substrings, UNIX syntax is used.  This pattern matching is
+"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification 
+syntax of that operating system is used in future calls to 
+fileparse(), basename(), and dirname().  If it contains none of
+these substrings, UNIX syntax is used.  This pattern matching is
 case-insensitive.  If you've selected VMS syntax, and the file
 specification you pass to one of these routines contains a "/",
 they assume you are using UNIX emulation and apply the UNIX syntax
 rules instead, for that function call only.
 
+If the argument passed to it contains one of the substrings "VMS",
+"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern
+matching for suffix removal is performed without regard for case,
+since those systems are not case-sensitive when opening existing files
+(though some of them preserve case on file creation).
+
 If you haven't called fileparse_set_fstype(), the syntax is chosen
 by examining the builtin variable C<$^O> according to these rules.
 
@@ -61,8 +66,8 @@ B<name> is removed and prepended to B<suffix>.  By proper use of
 C<@suffixlist>, you can remove file types or versions for examination.
 
 You are guaranteed that if you concatenate B<path>, B<name>, and
-B<suffix> together in that order, the result will be identical to the
-input file specification.
+B<suffix> together in that order, the result will denote the same
+file as the input file specification.
 
 =back
 
@@ -70,14 +75,14 @@ input file specification.
 
 Using UNIX file syntax:
 
-    ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', 
+    ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
 				    '\.book\d+');
 
 would yield
 
     $base eq 'draft'
-    $path eq '/virgil/aeneid',
-    $tail eq '.book7'
+    $path eq '/virgil/aeneid/',
+    $type eq '.book7'
 
 Similarly, using VMS syntax:
 
@@ -90,120 +95,100 @@ would yield
     $dir  eq 'Doc_Root:[Help]'
     $type eq '.Rnh'
 
+=over
+
 =item C<basename>
 
 The basename() routine returns the first element of the list produced
-by calling fileparse() with the same arguments.  It is provided for
-compatibility with the UNIX shell command basename(1).
+by calling fileparse() with the same arguments, except that it always
+quotes metacharacters in the given suffixes.  It is provided for
+programmer compatibility with the UNIX shell command basename(1).
 
 =item C<dirname>
 
 The dirname() routine returns the directory portion of the input file
 specification.  When using VMS or MacOS syntax, this is identical to the
 second element of the list produced by calling fileparse() with the same
-input file specification.  When using UNIX or MSDOS syntax, the return
+input file specification.  (Under VMS, if there is no directory information
+in the input file specification, then the current default device and
+directory are returned.)  When using UNIX or MSDOS syntax, the return
 value conforms to the behavior of the UNIX shell command dirname(1).  This
 is usually the same as the behavior of fileparse(), but differs in some
 cases.  For example, for the input file specification F<lib/>, fileparse()
 considers the directory name to be F<lib/>, while dirname() considers the
 directory name to be F<.>).
 
+=back
+
 =cut
 
 require 5.002;
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
+#use strict;
+#use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase);
+$VERSION = "2.5";
+
 
 #   fileparse_set_fstype() - specify OS-based rules used in future
 #                            calls to routines in this package
 #
-#   Currently recognized values: VMS, MSDOS, MacOS
-#       Any other name uses Unix-style rules
+#   Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS
+#       Any other name uses Unix-style rules and is case-sensitive
 
 sub fileparse_set_fstype {
-  my($old) = $Fileparse_fstype;
-  $Fileparse_fstype = $_[0] if $_[0];
-  $old;
+  my @old = ($Fileparse_fstype, $Fileparse_igncase);
+  if (@_) {
+    $Fileparse_fstype = $_[0];
+    $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32)/i);
+  }
+  wantarray ? @old : $old[0];
 }
 
 #   fileparse() - parse file specification
 #
-#   calling sequence:
-#     ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist);
-#     where  $filespec    is the file specification to be parsed, and
-#            @excludelist is a list of patterns which should be removed
-#                         from the end of $filename.
-#            $filename    is the part of $filespec after $prefix (i.e. the
-#                         name of the file).  The elements of @excludelist
-#                         are compared to $filename, and if an  
-#            $prefix     is the path portion $filespec, up to and including
-#                        the end of the last directory name
-#            $tail        any characters removed from $filename because they
-#                         matched an element of @excludelist.
-#
-#   fileparse() first removes the directory specification from $filespec,
-#   according to the syntax of the OS (code is provided below to handle
-#   VMS, Unix, MSDOS and MacOS; you can pick the one you want using
-#   fileparse_set_fstype(), or you can accept the default, which is
-#   based on the information in the builtin variable $^O).  It then compares
-#   each element of @excludelist to $filename, and if that element is a
-#   suffix of $filename, it is removed from $filename and prepended to
-#   $tail.  By specifying the elements of @excludelist in the right order,
-#   you can 'nibble back' $filename to extract the portion of interest
-#   to you.
-#
-#   For example, on a system running Unix,
-#   ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
-#                                       '\.book\d+');
-#   would yield $base == 'draft',
-#               $path == '/virgil/aeneid/'  (note trailing slash)
-#               $tail == '.book7'.
-#   Similarly, on a system running VMS,
-#   ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
-#   would yield $name == 'Rhetoric';
-#               $dir == 'Doc_Root:[Help]', and
-#               $type == '.Rnh'.
-#
-#   Version 2.2  13-Oct-1994  Charles Bailey  bailey@genetics.upenn.edu 
+#   Version 2.4  27-Sep-1996  Charles Bailey  bailey@genetics.upenn.edu
 
 
 sub fileparse {
   my($fullname,@suffices) = @_;
-  my($fstype) = $Fileparse_fstype;
-  my($dirpath,$tail,$suffix);
+  my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
+  my($dirpath,$tail,$suffix,$basename);
 
   if ($fstype =~ /^VMS/i) {
     if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
     else {
-      ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
-      $dirpath = $ENV{'DEFAULT'} unless $dirpath;
+      ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
     }
   }
-  if ($fstype =~ /^MSDOS/i) {
-    ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
-    $dirpath = '.\\' unless $dirpath;
+  if ($fstype =~ /^MS(DOS|Win32)/i) {
+    ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/);
+    $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/;
   }
-  elsif ($fstype =~ /^MAC/i) {
-    ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
+  elsif ($fstype =~ /^MacOS/i) {
+    ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/);
+  }
+  elsif ($fstype =~ /^AmigaOS/i) {
+    ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/);
+    $dirpath = './' unless $dirpath;
   }
   elsif ($fstype !~ /^VMS/i) {  # default to Unix
-    ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
+    ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
     $dirpath = './' unless $dirpath;
   }
 
   if (@suffices) {
     $tail = '';
     foreach $suffix (@suffices) {
-      if ($basename =~ /($suffix)$/) {
+      my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
+      if ($basename =~ s/$pat//) {
         $tail = $1 . $tail;
-        $basename = $`;
       }
     }
   }
 
   wantarray ? ($basename,$dirpath,$tail) : $basename;
-
 }
 
 
@@ -213,7 +198,7 @@ sub basename {
   my($name) = shift;
   (fileparse($name, map("\Q$_\E",@_)))[0];
 }
-  
+
 
 #    dirname() - returns device and directory portion of file specification
 #        Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
@@ -228,25 +213,40 @@ sub dirname {
 
     if ($fstype =~ /VMS/i) { 
         if ($_[0] =~ m#/#) { $fstype = '' }
-        else { return $dirname }
+        else { return $dirname || $ENV{DEFAULT} }
     }
     if ($fstype =~ /MacOS/i) { return $dirname }
     elsif ($fstype =~ /MSDOS/i) { 
-        if ( $dirname =~ /:\\$/) { return $dirname }
+        $dirname =~ s/([^:])[\\\/]*$/$1/;
+        unless( length($basename) ) {
+	    ($basename,$dirname) = fileparse $dirname;
+	    $dirname =~ s/([^:])[\\\/]*$/$1/;
+	}
+    }
+    elsif ($fstype =~ /MSWin32/i) { 
+        $dirname =~ s/([^:])[\\\/]*$/$1/;
+        unless( length($basename) ) {
+	    ($basename,$dirname) = fileparse $dirname;
+	    $dirname =~ s/([^:])[\\\/]*$/$1/;
+	}
+    }
+    elsif ($fstype =~ /AmigaOS/i) {
+        if ( $dirname =~ /:$/) { return $dirname }
         chop $dirname;
-        $dirname =~ s:[^\\]+$:: unless $basename;
-        $dirname = '.' unless $dirname;
+        $dirname =~ s#[^:/]+$## unless length($basename);
     }
     else { 
-        if ( $dirname eq '/') { return $dirname }
-        chop $dirname;
-        $dirname =~ s:[^/]+$:: unless $basename;
-        $dirname = '.' unless $dirname;
+        $dirname =~ s:(.)/*$:$1:;
+        unless( length($basename) ) {
+	    local($File::Basename::Fileparse_fstype) = $fstype;
+	    ($basename,$dirname) = fileparse $dirname;
+	    $dirname =~ s:(.)/*$:$1:;
+	}
     }
 
     $dirname;
 }
 
-$Fileparse_fstype = $^O;
+fileparse_set_fstype $^O;
 
 1;
diff --git a/gnu/usr.bin/perl/lib/File/Compare.pm b/gnu/usr.bin/perl/lib/File/Compare.pm
new file mode 100644
index 00000000000..2f9c45c4c60
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/File/Compare.pm
@@ -0,0 +1,143 @@
+package File::Compare;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO);
+
+require Exporter;
+use Carp;
+
+$VERSION = '1.1001';
+@ISA = qw(Exporter);
+@EXPORT = qw(compare);
+@EXPORT_OK = qw(cmp);
+
+$Too_Big = 1024 * 1024 * 2;
+
+sub VERSION {
+    # Version of File::Compare
+    return $File::Compare::VERSION;
+}
+
+sub compare {
+    croak("Usage: compare( file1, file2 [, buffersize]) ")
+      unless(@_ == 2 || @_ == 3);
+
+    my $from = shift;
+    my $to = shift;
+    my $closefrom=0;
+    my $closeto=0;
+    my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf);
+    local(*FROM, *TO);
+    local($\) = '';
+
+    croak("from undefined") unless (defined $from);
+    croak("to undefined") unless (defined $to);
+
+    if (ref($from) && 
+        (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
+	*FROM = *$from;
+    } elsif (ref(\$from) eq 'GLOB') {
+	*FROM = $from;
+    } else {
+	open(FROM,"<$from") or goto fail_open1;
+	binmode FROM;
+	$closefrom = 1;
+	$fromsize = -s FROM;
+    }
+
+    if (ref($to) &&
+        (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
+	*TO = *$to;
+    } elsif (ref(\$to) eq 'GLOB') {
+	*TO = $to;
+    } else {
+	open(TO,"<$to") or goto fail_open2;
+	binmode TO;
+	$closeto = 1;
+    }
+
+    if ($closefrom && $closeto) {
+	# If both are opened files we know they differ if their size differ
+	goto fail_inner if $fromsize != -s TO;
+    }
+
+    if (@_) {
+	$size = shift(@_) + 0;
+	croak("Bad buffer size for compare: $size\n") unless ($size > 0);
+    } else {
+	$size = $fromsize;
+	$size = 1024 if ($size < 512);
+	$size = $Too_Big if ($size > $Too_Big);
+    }
+
+    $fbuf = '';
+    $tbuf = '';
+    while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
+	unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) {
+            goto fail_inner;
+	}
+    }
+    goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0);
+
+    close(TO) || goto fail_open2 if $closeto;
+    close(FROM) || goto fail_open1 if $closefrom;
+
+    return 0;
+    
+  # All of these contortions try to preserve error messages...
+  fail_inner:
+    close(TO) || goto fail_open2 if $closeto;
+    close(FROM) || goto fail_open1 if $closefrom;
+
+    return 1;
+
+  fail_open2:
+    if ($closefrom) {
+	$status = $!;
+	$! = 0;
+	close FROM;
+	$! = $status unless $!;
+    }
+  fail_open1:
+    return -1;
+}
+
+*cmp = \&compare;
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Compare - Compare files or filehandles
+
+=head1 SYNOPSIS
+
+  	use File::Compare;
+
+	if (compare("file1","file2") == 0) {
+	    print "They're equal\n";
+	}
+
+=head1 DESCRIPTION
+
+The File::Compare::compare function compares the contents of two
+sources, each of which can be a file or a file handle.  It is exported
+from File::Compare by default.
+
+File::Compare::cmp is a synonym for File::Compare::compare.  It is
+exported from File::Compare only by request.
+
+=head1 RETURN
+
+File::Compare::compare return 0 if the files are equal, 1 if the
+files are unequal, or -1 if an error was encountered.
+
+=head1 AUTHOR
+
+File::Compare was written by Nick Ing-Simmons.
+Its original documentation was written by Chip Salzenberg.
+
+=cut
+
diff --git a/gnu/usr.bin/perl/lib/File/Copy.pm b/gnu/usr.bin/perl/lib/File/Copy.pm
index 68460130109..e95168e24b8 100644
--- a/gnu/usr.bin/perl/lib/File/Copy.pm
+++ b/gnu/usr.bin/perl/lib/File/Copy.pm
@@ -2,66 +2,94 @@
 # source code has been placed in the public domain by the author.
 # Please be kind and preserve the documentation.
 #
+# Additions copyright 1996 by Charles Bailey.  Permission is granted
+# to distribute the revised code under the same terms as Perl itself.
 
 package File::Copy;
 
-require Exporter;
+use strict;
 use Carp;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big
+	    &copy &syscopy &cp &mv);
+
+# Note that this module implements only *part* of the API defined by
+# the File/Copy.pm module of the File-Tools-2.0 package.  However, that
+# package has not yet been updated to work with Perl 5.004, and so it
+# would be a Bad Thing for the CPAN module to grab it and replace this
+# module.  Therefore, we set this module's version higher than 2.0.
+$VERSION = '2.02';
 
-@ISA=qw(Exporter);
-@EXPORT=qw(copy);
-@EXPORT_OK=qw(copy cp);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(copy move);
+@EXPORT_OK = qw(cp mv);
 
-$File::Copy::VERSION = '1.5';
-$File::Copy::Too_Big = 1024 * 1024 * 2;
+$Too_Big = 1024 * 1024 * 2;
 
-sub VERSION {
-    # Version of File::Copy
-    return $File::Copy::VERSION;
+sub _catname { #  Will be replaced by File::Spec when it arrives
+    my($from, $to) = @_;
+    if (not defined &basename) {
+	require File::Basename;
+	import  File::Basename 'basename';
+    }
+    if ($^O eq 'VMS')  { $to = VMS::Filespec::vmspath($to) . basename($from); }
+    elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); }
+    elsif ($to =~ m|\\|)   { $to .= '\\' . basename($from); }
+    else                   { $to .= '/' . basename($from); }
 }
 
 sub copy {
-    croak("Usage: copy( file1, file2 [, buffersize]) ")
+    croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
       unless(@_ == 2 || @_ == 3);
 
-    if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$to) ne 'GLOB' &&
-        !(defined ref $to and (ref($to) eq 'GLOB' ||
-          ref($to) eq 'FileHandle' || ref($to) eq 'VMS::Stdio')))
-        { return File::Copy::syscopy($_[0],$_[1]) }
-
     my $from = shift;
     my $to = shift;
-    my $recsep = $\;
-    my $closefrom=0;
-    my $closeto=0;
-    my ($size, $status, $r, $buf);
-    local(*FROM, *TO);
 
-    $\ = '';
+    my $from_a_handle = (ref($from)
+			 ? (ref($from) eq 'GLOB'
+			    || UNIVERSAL::isa($from, 'GLOB')
+                            || UNIVERSAL::isa($from, 'IO::Handle'))
+			 : (ref(\$from) eq 'GLOB'));
+    my $to_a_handle =   (ref($to)
+			 ? (ref($to) eq 'GLOB'
+			    || UNIVERSAL::isa($to, 'GLOB')
+                            || UNIVERSAL::isa($to, 'IO::Handle'))
+			 : (ref(\$to) eq 'GLOB'));
+
+    if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
+	$to = _catname($from, $to);
+    }
 
-    if (ref(\$from) eq 'GLOB') {
-	*FROM = $from;
-    } elsif (defined ref $from and
-	     (ref($from) eq 'GLOB' || ref($from) eq 'FileHandle' ||
-	      ref($from) eq 'VMS::Stdio')) {
-	*FROM = *$from;
-    } else {
-	open(FROM,"<$from")||goto(fail_open1);
-	binmode FROM;
-	$closefrom = 1;
+    if (defined &syscopy && \&syscopy != \&copy
+	&& !$to_a_handle
+	&& !($from_a_handle && $^O eq 'os2'))	# OS/2 cannot handle handles
+    {
+	return syscopy($from, $to);
     }
 
-    if (ref(\$to) eq 'GLOB') {
-	*TO = $to;
-    } elsif (defined ref $to and
-	     (ref($to) eq 'GLOB' || ref($to) eq 'FileHandle' ||
-	      ref($to) eq 'VMS::Stdio')) {
-	*TO = *$to;
+    my $closefrom = 0;
+    my $closeto = 0;
+    my ($size, $status, $r, $buf);
+    local(*FROM, *TO);
+    local($\) = '';
+
+    if ($from_a_handle) {
+	*FROM = *$from{FILEHANDLE};
     } else {
-	open(TO,">$to")||goto(fail_open2);
-	binmode TO;
-	$closeto=1;
-    }
+	$from = "./$from" if $from =~ /^\s/;
+	open(FROM, "< $from\0") or goto fail_open1;
+	binmode FROM or die "($!,$^E)";
+	$closefrom = 1;
+    } 
+ 
+    if ($to_a_handle) {
+	*TO = *$to{FILEHANDLE};
+    } else {        
+	$to = "./$to" if $to =~ /^\s/;
+	open(TO,"> $to\0") or goto fail_open2;
+	binmode TO or die "($!,$^E)";
+	$closeto = 1;
+    }  
 
     if (@_) {
 	$size = shift(@_) + 0;
@@ -69,19 +97,25 @@ sub copy {
     } else {
 	$size = -s FROM;
 	$size = 1024 if ($size < 512);
-	$size = $File::Copy::Too_Big if ($size > $File::Copy::Too_Big);
+	$size = $Too_Big if ($size > $Too_Big);
     }
 
-    $buf = '';
-    while(defined($r = read(FROM,$buf,$size)) && $r > 0) {
-	if (syswrite (TO,$buf,$r) != $r) {
-	    goto fail_inner;    
+    $! = 0;
+    for (;;) {
+	my ($r, $w, $t);
+	defined($r = sysread(FROM, $buf, $size))
+	    or goto fail_inner;
+	last unless $r;
+	for ($w = 0; $w < $r; $w += $t) {
+	    $t = syswrite(TO, $buf, $r - $w, $w)
+		or goto fail_inner;
 	}
     }
-    goto fail_inner unless(defined($r));
+
     close(TO) || goto fail_open2 if $closeto;
     close(FROM) || goto fail_open1 if $closefrom;
-    $\ = $recsep;
+
+    # Use this idiom to avoid uninitialized value warning.
     return 1;
     
     # All of these contortions try to preserve error messages...
@@ -100,14 +134,47 @@ sub copy {
 	$! = $status unless $!;
     }
   fail_open1:
-    $\ = $recsep;
     return 0;
 }
 
+sub move {
+    my($from,$to) = @_;
+    my($copied,$fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
+
+    if (-d $to && ! -d $from) {
+	$to = _catname($from, $to);
+    }
+
+    ($tosz1,$tomt1) = (stat($to))[7,9];
+    $fromsz = -s $from;
+    if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
+      # will not rename with overwrite
+      unlink $to;
+    }
+    return 1 if rename $from, $to;
+
+    ($sts,$ossts) = ($! + 0, $^E + 0);
+    # Did rename return an error even though it succeeded, because $to
+    # is on a remote NFS file system, and NFS lost the server's ack?
+    return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
+                (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
+                ($tosz1 != $tosz2 or $tomt1 != $tomt2) &&  #   and changed
+                $tosz2 == $fromsz;                         # it's all there
+ 
+    ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
+    return 1 if ($copied = copy($from,$to)) && unlink($from);
+  
+    ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
+    unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
+    ($!,$^E) = ($sts,$ossts);
+    return 0;
+}
 
 *cp = \&copy;
+*mv = \&move;
+
 # &syscopy is an XSUB under OS/2
-*syscopy = ($^O eq 'VMS' ? \&rmscopy : \&copy) unless $^O eq 'os2';
+*syscopy = ($^O eq 'VMS' ? \&rmscopy : \&copy) unless defined &syscopy;
 
 1;
 
@@ -123,6 +190,7 @@ File::Copy - Copy files or filehandles
 
 	copy("file1","file2");
   	copy("Copy.pm",\*STDOUT);'
+	move("/dev1/fileA","/dev2/fileB");
 
   	use POSIX;
 	use File::Copy cp;
@@ -132,16 +200,28 @@ File::Copy - Copy files or filehandles
 
 =head1 DESCRIPTION
 
-The File::Copy module provides a basic function C<copy> which takes two
+The File::Copy module provides two basic functions, C<copy> and
+C<move>, which are useful for getting the contents of a file from
+one place to another.
+
+=over 4
+
+=item *
+
+The C<copy> function takes two
 parameters: a file to copy from and a file to copy to. Either
 argument may be a string, a FileHandle reference or a FileHandle
 glob. Obviously, if the first argument is a filehandle of some
 sort, it will be read from, and if it is a file I<name> it will
 be opened for reading. Likewise, the second argument will be
-written to (and created if need be).  Note that passing in
+written to (and created if need be).
+
+B<Note that passing in
 files as handles instead of names may lead to loss of information
 on some operating systems; it is recommended that you use file
-names whenever possible.
+names whenever possible.>  Files are opened in binary mode where
+applicable.  To get a consistent behavour when copying from a
+filehandle to a file, use C<binmode> on the filehandle.
 
 An optional third parameter can be used to specify the buffer
 size used for copying. This is the number of bytes from the
@@ -153,6 +233,24 @@ upon the file, but will generally be the whole file (up to 2Mb), or
 You may use the syntax C<use File::Copy "cp"> to get at the
 "cp" alias for this function. The syntax is I<exactly> the same.
 
+=item *
+
+The C<move> function also takes two parameters: the current name
+and the intended name of the file to be moved.  If the destination
+already exists and is a directory, and the source is not a
+directory, then the source file will be renamed into the directory
+specified by the destination.
+
+If possible, move() will simply rename the file.  Otherwise, it copies
+the file to the new location and deletes the original.  If an error occurs
+during this copy-and-delete process, you may be left with a (possibly partial)
+copy of the file under the destination name.
+
+You may use the "mv" alias for this function in the same way that
+you may use the "cp" alias for C<copy>.
+
+=back
+
 File::Copy also provides the C<syscopy> routine, which copies the
 file specified in the first parameter to the file specified in the
 second parameter, preserving OS-specific attributes and file
@@ -161,25 +259,28 @@ C<copy> routine.  For VMS systems, this calls the C<rmscopy>
 routine (see below).  For OS/2 systems, this calls the C<syscopy>
 XSUB directly.
 
-=head2 Special behavior under VMS
+=head2 Special behavior if C<syscopy> is defined (VMS and OS/2)
 
-If the second argument to C<copy> is not a file handle for an
-already opened file, then C<copy> will perform an RMS copy of
+If both arguments to C<copy> are not file handles,
+then C<copy> will perform a "system copy" of
 the input file to a new output file, in order to preserve file
 attributes, indexed file structure, I<etc.>  The buffer size
-parameter is ignored.  If the second argument to C<copy> is a
-Perl handle to an opened file, then data is copied using Perl
+parameter is ignored.  If either argument to C<copy> is a
+handle to an opened file, then data is copied using Perl
 operators, and no effort is made to preserve file attributes
 or record structure.
 
-The RMS copy routine may also be called directly under VMS
-as C<File::Copy::rmscopy> (or C<File::Copy::syscopy>, which
-is just an alias for this routine).
+The system copy routine may also be called directly under VMS and OS/2
+as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
+is the routine that does the actual work for syscopy).
+
+=over 4
 
 =item rmscopy($from,$to[,$date_flag])
 
-The first and second arguments may be strings, typeglobs, or
-typeglob references; they are used in all cases to obtain the
+The first and second arguments may be strings, typeglobs, typeglob
+references, or objects inheriting from IO::Handle;
+they are used in all cases to obtain the
 I<filespec> of the input and output files, respectively.  The
 name and type of the input file are used as defaults for the
 output file, if necessary.
@@ -195,8 +296,8 @@ associated with an old version of that file after C<rmscopy>
 returns, not the newly created version.)
 
 The third parameter is an integer flag, which tells C<rmscopy>
-how to handle timestamps.  If it is < 0, none of the input file's
-timestamps are propagated to the output file.  If it is > 0, then
+how to handle timestamps.  If it is E<lt> 0, none of the input file's
+timestamps are propagated to the output file.  If it is E<gt> 0, then
 it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
 timestamps other than the revision date are propagated; if bit 1
 is set, the revision date is propagated.  If the third parameter
@@ -210,15 +311,17 @@ it defaults to 0.
 Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
 it sets C<$!>, deletes the output file, and returns 0.
 
+=back
+
 =head1 RETURN
 
-Returns 1 on success, 0 on failure. $! will be set if an error was
-encountered.
+All functions return 1 on success, 0 on failure.
+$! will be set if an error was encountered.
 
 =head1 AUTHOR
 
-File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995.
-The VMS-specific code was added by Charles Bailey
-I<E<lt>bailey@genetics.upenn.eduE<gt>> in March 1996.
+File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
+and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996.
 
 =cut
+
diff --git a/gnu/usr.bin/perl/lib/File/DosGlob.pm b/gnu/usr.bin/perl/lib/File/DosGlob.pm
new file mode 100644
index 00000000000..4597c715640
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/File/DosGlob.pm
@@ -0,0 +1,250 @@
+#!perl -w
+
+#
+# Documentation at the __END__
+#
+
+package File::DosGlob;
+
+unless (caller) {
+    $| = 1;
+    while (@ARGV) {
+	#
+	# We have to do this one by one for compatibility reasons.
+	# If an arg doesn't match anything, we are supposed to return
+	# the original arg.  I know, it stinks, eh?
+	#
+	my $arg = shift;
+	my @m = doglob(1,$arg);
+	print (@m ? join("\0", sort @m) : $arg);
+	print "\0" if @ARGV;
+    }
+}
+
+sub doglob {
+    my $cond = shift;
+    my @retval = ();
+    #print "doglob: ", join('|', @_), "\n";
+  OUTER:
+    for my $arg (@_) {
+        local $_ = $arg;
+	my @matched = ();
+	my @globdirs = ();
+	my $head = '.';
+	my $sepchr = '/';
+	next OUTER unless defined $_ and $_ ne '';
+	# if arg is within quotes strip em and do no globbing
+	if (/^"(.*)"$/) {
+	    $_ = $1;
+	    if ($cond eq 'd') { push(@retval, $_) if -d $_ }
+	    else              { push(@retval, $_) if -e $_ }
+	    next OUTER;
+	}
+	if (m|^(.*)([\\/])([^\\/]*)$|) {
+	    my $tail;
+	    ($head, $sepchr, $tail) = ($1,$2,$3);
+	    #print "div: |$head|$sepchr|$tail|\n";
+	    push (@retval, $_), next OUTER if $tail eq '';
+	    if ($head =~ /[*?]/) {
+		@globdirs = doglob('d', $head);
+		push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
+		    next OUTER if @globdirs;
+	    }
+	    $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
+	    $_ = $tail;
+	}
+	#
+	# If file component has no wildcards, we can avoid opendir
+	unless (/[*?]/) {
+	    $head = '' if $head eq '.';
+	    $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
+	    $head .= $_;
+	    if ($cond eq 'd') { push(@retval,$head) if -d $head }
+	    else              { push(@retval,$head) if -e $head }
+	    next OUTER;
+	}
+	opendir(D, $head) or next OUTER;
+	my @leaves = readdir D;
+	closedir D;
+	$head = '' if $head eq '.';
+	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
+
+	# escape regex metachars but not glob chars
+	s:([].+^\-\${}[|]):\\$1:g;
+	# and convert DOS-style wildcards to regex
+	s/\*/.*/g;
+	s/\?/.?/g;
+
+	#print "regex: '$_', head: '$head'\n";
+	my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }';
+	warn($@), next OUTER if $@;
+      INNER:
+	for my $e (@leaves) {
+	    next INNER if $e eq '.' or $e eq '..';
+	    next INNER if $cond eq 'd' and ! -d "$head$e";
+	    push(@matched, "$head$e"), next INNER if &$matchsub($e);
+	    #
+	    # [DOS compatibility special case]
+	    # Failed, add a trailing dot and try again, but only
+	    # if name does not have a dot in it *and* pattern
+	    # has a dot *and* name is shorter than 9 chars.
+	    #
+	    if (index($e,'.') == -1 and length($e) < 9
+	        and index($_,'\\.') != -1) {
+		push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
+	    }
+	}
+	push @retval, @matched if @matched;
+    }
+    return @retval;
+}
+
+#
+# this can be used to override CORE::glob in a specific
+# package by saying C<use File::DosGlob 'glob';> in that
+# namespace.
+#
+
+# context (keyed by second cxix arg provided by core)
+my %iter;
+my %entries;
+
+sub glob {
+    my $pat = shift;
+    my $cxix = shift;
+
+    # glob without args defaults to $_
+    $pat = $_ unless defined $pat;
+
+    # assume global context if not provided one
+    $cxix = '_G_' unless defined $cxix;
+    $iter{$cxix} = 0 unless exists $iter{$cxix};
+
+    # if we're just beginning, do it all first
+    if ($iter{$cxix} == 0) {
+	$entries{$cxix} = [doglob(1,$pat)];
+    }
+
+    # chuck it all out, quick or slow
+    if (wantarray) {
+	delete $iter{$cxix};
+	return @{delete $entries{$cxix}};
+    }
+    else {
+	if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
+	    return shift @{$entries{$cxix}};
+	}
+	else {
+	    # return undef for EOL
+	    delete $iter{$cxix};
+	    delete $entries{$cxix};
+	    return undef;
+	}
+    }
+}
+
+sub import {
+    my $pkg = shift;
+    my $callpkg = caller(0);
+    my $sym = shift;
+    *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym}
+	if defined($sym) and $sym eq 'glob';
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::DosGlob - DOS like globbing and then some
+
+perlglob.bat - a more capable perlglob.exe replacement
+
+=head1 SYNOPSIS
+
+    require 5.004;
+    
+    # override CORE::glob in current package
+    use File::DosGlob 'glob';
+    
+    @perlfiles = glob  "..\\pe?l/*.p?";
+    print <..\\pe?l/*.p?>;
+    
+    # from the command line (overrides only in main::)
+    > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
+    
+    > perlglob ../pe*/*p?
+
+=head1 DESCRIPTION
+
+A module that implements DOS-like globbing with a few enhancements.
+This file is also a portable replacement for perlglob.exe.  It
+is largely compatible with perlglob.exe (the M$ setargv.obj
+version) in all but one respect--it understands wildcards in
+directory components.
+
+For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
+that it will find something like '..\lib\File/DosGlob.pm' alright).
+Note that all path components are case-insensitive, and that
+backslashes and forward slashes are both accepted, and preserved.
+You may have to double the backslashes if you are putting them in
+literally, due to double-quotish parsing of the pattern by perl.
+
+When invoked as a program, it will print null-separated filenames
+to standard output.
+
+While one may replace perlglob.exe with this, usage by overriding
+CORE::glob via importation should be much more efficient, because
+it avoids launching a separate process, and is therefore strongly
+recommended.  Note that it is currently possible to override
+builtins like glob() only on a per-package basis, not "globally".
+Thus, every namespace that wants to override glob() must explicitly
+request the override.  See L<perlsub>.
+
+Extending it to csh patterns is left as an exercise to the reader.
+
+=head1 EXPORTS (by request only)
+
+glob()
+
+=head1 BUGS
+
+Should probably be built into the core, and needs to stop
+pandering to DOS habits.  Needs a dose of optimizium too.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy <gsar@umich.edu>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
+
+=item *
+
+A few dir-vs-file optimizations result in glob importation being
+10 times faster than using perlglob.exe, and using perlglob.bat is
+only twice as slow as perlglob.exe (GSAR 28-MAY-97)
+
+=item *
+
+Several cleanups prompted by lack of compatible perlglob.exe
+under Borland (GSAR 27-MAY-97)
+
+=item *
+
+Initial version (GSAR 20-FEB-97)
+
+=back
+
+=head1 SEE ALSO
+
+perl
+
+=cut
+
diff --git a/gnu/usr.bin/perl/lib/File/Find.pm b/gnu/usr.bin/perl/lib/File/Find.pm
index 02bacd8fc25..033cfe5e9de 100644
--- a/gnu/usr.bin/perl/lib/File/Find.pm
+++ b/gnu/usr.bin/perl/lib/File/Find.pm
@@ -31,6 +31,9 @@ C<"$File::Find::dir/$_">.  You are chdir()'d to $File::Find::dir when
 the function is called.  The function may set $File::Find::prune to
 prune the tree.
 
+File::Find assumes that you don't alter the $_ variable.  If you do then
+make sure you return it to its original value before exiting your function.
+
 This library is primarily for the C<find2perl> tool, which when fed, 
 
     find2perl / -name .nfs\* -mtime +7 \
@@ -62,6 +65,10 @@ that don't resolve:
 	-l && !-e && print "bogus link: $File::Find::name\n";
     } 
 
+=head1 BUGS
+
+There is no way to make find or finddepth follow symlinks.
+
 =cut
 
 @ISA = qw(Exporter);
@@ -70,27 +77,34 @@ that don't resolve:
 
 sub find {
     my $wanted = shift;
-    my $cwd = Cwd::fastcwd();
-    my ($topdir,$topdev,$topino,$topmode,$topnlink);
+    my $cwd = Cwd::cwd();
+    # Localize these rather than lexicalizing them for backwards
+    # compatibility.
+    local($topdir,$topdev,$topino,$topmode,$topnlink);
     foreach $topdir (@_) {
-	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+	(($topdev,$topino,$topmode,$topnlink) =
+	  ($Is_VMS ? stat($topdir) : lstat($topdir)))
 	  || (warn("Can't stat $topdir: $!\n"), next);
 	if (-d _) {
 	    if (chdir($topdir)) {
 		($dir,$_) = ($topdir,'.');
 		$name = $topdir;
+		$prune = 0;
 		&$wanted;
-		my $fixtopdir = $topdir;
-	        $fixtopdir =~ s,/$,, ;
-		$fixtopdir =~ s/\.dir$// if $Is_VMS; ;
-		&finddir($wanted,$fixtopdir,$topnlink);
+		if (!$prune) {
+		    my $fixtopdir = $topdir;
+	            $fixtopdir =~ s,/$,, ;
+		    $fixtopdir =~ s/\.dir$// if $Is_VMS;
+		    $fixtopdir =~ s/\\dir$// if $Is_NT;
+		    &finddir($wanted,$fixtopdir,$topnlink);
+		}
 	    }
 	    else {
 		warn "Can't cd to $topdir: $!\n";
 	    }
 	}
 	else {
-	    unless (($dir,$_) = File::Basename::fileparse($topdir)) {
+	    unless (($_,$dir) = File::Basename::fileparse($topdir)) {
 		($dir,$_) = ('.', $topdir);
 	    }
 	    $name = $topdir;
@@ -142,6 +156,7 @@ sub finddir {
 
 		    if (!$prune && chdir $_) {
 			$name =~ s/\.dir$// if $Is_VMS;
+			$name =~ s/\\dir$// if $Is_NT;
 			&finddir($wanted,$name,$nlink);
 			chdir '..';
 		    }
@@ -158,15 +173,19 @@ sub finddepth {
 
     $cwd = Cwd::fastcwd();;
 
-    my($topdir, $topdev, $topino, $topmode, $topnlink);
+    # Localize these rather than lexicalizing them for backwards
+    # compatibility.
+    local($topdir, $topdev, $topino, $topmode, $topnlink);
     foreach $topdir (@_) {
-	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+	(($topdev,$topino,$topmode,$topnlink) =
+	  ($Is_VMS ? stat($topdir) : lstat($topdir)))
 	  || (warn("Can't stat $topdir: $!\n"), next);
 	if (-d _) {
 	    if (chdir($topdir)) {
 		my $fixtopdir = $topdir;
 		$fixtopdir =~ s,/$,, ;
 		$fixtopdir =~ s/\.dir$// if $Is_VMS;
+		$fixtopdir =~ s/\\dir$// if $Is_NT;
 		&finddepthdir($wanted,$fixtopdir,$topnlink);
 		($dir,$_) = ($fixtopdir,'.');
 		$name = $fixtopdir;
@@ -177,9 +196,10 @@ sub finddepth {
 	    }
 	}
 	else {
-	    unless (($dir,$_) = File::Basename::fileparse($topdir)) {
+	    unless (($_,$dir) = File::Basename::fileparse($topdir)) {
 		($dir,$_) = ('.', $topdir);
 	    }
+	    $name = $topdir;
 	    chdir $dir && &$wanted;
 	}
 	chdir $cwd;
@@ -225,6 +245,7 @@ sub finddepthdir {
 
 		    if (chdir $_) {
 			$name =~ s/\.dir$// if $Is_VMS;
+			$name =~ s/\\dir$// if $Is_NT;
 			&finddepthdir($wanted,$name,$nlink);
 			chdir '..';
 		    }
@@ -247,9 +268,13 @@ if ($^O eq 'VMS') {
   $Is_VMS = 1;
   $dont_use_nlink = 1;
 }
+if ($^O =~ m:^mswin32:i) {
+  $Is_NT = 1;
+  $dont_use_nlink = 1;
+}
 
-$dont_use_nlink = 1 if $^O eq 'os2';
-$dont_use_nlink = 1 if $^O =~ m:^mswin32$:i ;
+$dont_use_nlink = 1
+    if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos';
 
 1;
 
diff --git a/gnu/usr.bin/perl/lib/File/Path.pm b/gnu/usr.bin/perl/lib/File/Path.pm
index 97cb66855dc..43856dfe7b9 100644
--- a/gnu/usr.bin/perl/lib/File/Path.pm
+++ b/gnu/usr.bin/perl/lib/File/Path.pm
@@ -14,9 +14,9 @@ C<rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);>
 
 =head1 DESCRIPTION
 
-The C<mkpath> function provides a convenient way to create directories, even if
-your C<mkdir> kernel call won't create more than one level of directory at a
-time.  C<mkpath> takes three arguments:
+The C<mkpath> function provides a convenient way to create directories, even
+if your C<mkdir> kernel call won't create more than one level of directory at
+a time.  C<mkpath> takes three arguments:
 
 =over 4
 
@@ -38,8 +38,8 @@ the numeric mode to use when creating the directories
 
 =back
 
-It returns a list of all directories (including intermediates, determined using
-the Unix '/' separator) created.
+It returns a list of all directories (including intermediates, determined
+using the Unix '/' separator) created.
 
 Similarly, the C<rmtree> function provides a convenient way to delete a
 subtree from the directory structure, much like the Unix command C<rm -r>.
@@ -69,34 +69,50 @@ 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)
+than VMS is settled.  (defaults to FALSE)
 
 =back
 
-It returns the number of files successfully deleted. Symlinks are
+It returns the number of files successfully deleted.  Symlinks are
 treated as ordinary files.
 
+B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure>
+in the face of failure or interruption.  Files and directories which
+were not deleted may be left with permissions reset to allow world
+read and write access.  Note also that the occurrence of errors in
+rmtree can be determined I<only> by trapping diagnostic messages
+using C<$SIG{__WARN__}>; it is not apparent from the return value.
+Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0>
+in situations where security is an issue.
+
 =head1 AUTHORS
 
-Tim Bunce <Tim.Bunce@ig.co.uk>
-Charles Bailey <bailey@genetics.upenn.edu>
+Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
+Charles Bailey <F<bailey@genetics.upenn.edu>>
 
 =head1 REVISION
 
-This module was last revised 14-Feb-1996, for perl 5.002. $VERSION is
-1.01.
+Current $VERSION is 1.04.
 
 =cut
 
-$VERSION = "1.01"; # That's my hobby-horse, A.K.
-
-require 5.000;
 use Carp;
-require Exporter;
+use File::Basename ();
+use DirHandle ();
+use Exporter ();
+use strict;
+
+use vars qw( $VERSION @ISA @EXPORT );
+$VERSION = "1.04";
 @ISA = qw( Exporter );
 @EXPORT = qw( mkpath rmtree );
 
-$Is_VMS = $^O eq 'VMS';
+my $Is_VMS = $^O eq 'VMS';
+
+# 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 'msdos' || $^O eq 'MSWin32'
+		       || $^O eq 'amigaos');
 
 sub mkpath {
     my($paths, $verbose, $mode) = @_;
@@ -106,17 +122,19 @@ sub mkpath {
     local($")="/";
     $mode = 0777 unless defined($mode);
     $paths = [$paths] unless ref $paths;
-    my(@created);
-    foreach $path (@$paths){
-        next if -d $path;
-        my(@p);
-        foreach(split(/\//, $path)){
-            push(@p, $_);
-            next if -d "@p/";
-            print "mkdir @p\n" if $verbose;
-	    mkdir("@p",$mode) || croak "mkdir @p: $!";
-            push(@created, "@p");
-        }
+    my(@created,$path);
+    foreach $path (@$paths) {
+	next if -d $path;
+	# Logic wants Unix paths, so go with the flow.
+	$path = VMS::Filespec::unixify($path) if $Is_VMS;
+	my $parent = File::Basename::dirname($path);
+	push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent);
+	print "mkdir $path\n" if $verbose;
+	unless (mkdir($path,$mode)) {
+	    # allow for another process to have created it meanwhile
+	    croak "mkdir $path: $!" unless -d $path;
+	}
+	push(@created, $path);
     }
     @created;
 }
@@ -126,40 +144,81 @@ sub rmtree {
     my(@files);
     my($count) = 0;
     $roots = [$roots] unless ref $roots;
+    $verbose ||= 0;
+    $safe ||= 0;
 
+    my($root);
     foreach $root (@{$roots}) {
-       $root =~ s#/$##;
-       if (not -l $root and -d _) { 
-           opendir(D,$root);
-           ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS;
-           @files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D));
-           closedir(D);
-           $count += rmtree(\@files,$verbose,$safe);
-           if ($safe &&
-               ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
-               print "skipped $root\n" if $verbose;
-               next;
-           }
-           print "rmdir $root\n" if $verbose;
-           (rmdir $root && ++$count) or carp "Can't remove directory $root: $!";
-        }
-        else { 
-           if ($safe &&
-               ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
-               print "skipped $root\n" if $verbose;
-               next;
-           }
-           print "unlink $root\n" if $verbose;
-           while (-e $root || -l $root) { # delete all versions under VMS
-               (unlink($root) && ++$count)
-                   or carp "Can't unlink file $root: $!";
-           }
-        }
+	$root =~ s#/$##;
+	(undef, undef, my $rp) = lstat $root or next;
+	$rp &= 07777;	# don't forget setuid, setgid, sticky bits
+	if ( -d _ ) {
+	    # notabene: 0777 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(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+	      or carp "Can't make directory $root read+writeable: $!"
+		unless $safe;
+
+	    my $d = DirHandle->new($root)
+	      or carp "Can't read $root: $!";
+	    @files = $d->read;
+	    $d->close;
+
+	    # 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$## if $Is_VMS;
+	    @files = map("$root/$_", grep $_!~/^\.{1,2}$/,@files);
+	    $count += rmtree(\@files,$verbose,$safe);
+	    if ($safe &&
+		($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+		print "skipped $root\n" if $verbose;
+		next;
+	    }
+	    chmod 0777, $root
+	      or carp "Can't make directory $root writeable: $!"
+		if $force_writeable;
+	    print "rmdir $root\n" if $verbose;
+	    if (rmdir $root) {
+		++$count;
+	    }
+	    else {
+		carp "Can't remove directory $root: $!";
+		chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+		    or carp("and can't restore permissions to "
+		            . sprintf("0%o",$rp) . "\n");
+	    }
+	}
+	else { 
+	    if ($safe &&
+		($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+		print "skipped $root\n" if $verbose;
+		next;
+	    }
+	    chmod 0666, $root
+	      or carp "Can't make file $root writeable: $!"
+		if $force_writeable;
+	    print "unlink $root\n" if $verbose;
+	    # delete all versions under VMS
+	    while (-e $root || -l $root) {
+		if (unlink $root) {
+		    ++$count;
+		}
+		else {
+		    carp "Can't unlink file $root: $!";
+		    if ($force_writeable) {
+			chmod $rp, $root
+			    or carp("and can't restore permissions to "
+			            . sprintf("0%o",$rp) . "\n");
+		    }
+		}
+	    }
+	}
     }
 
     $count;
 }
 
 1;
-
-__END__
diff --git a/gnu/usr.bin/perl/lib/File/stat.pm b/gnu/usr.bin/perl/lib/File/stat.pm
new file mode 100644
index 00000000000..f5d17f7da44
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/File/stat.pm
@@ -0,0 +1,113 @@
+package File::stat;
+use strict;
+
+BEGIN { 
+    use Exporter   ();
+    use vars       qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+    @EXPORT      = qw(stat lstat);
+    @EXPORT_OK   = qw( $st_dev	   $st_ino    $st_mode 
+		       $st_nlink   $st_uid    $st_gid 
+		       $st_rdev    $st_size 
+		       $st_atime   $st_mtime  $st_ctime 
+		       $st_blksize $st_blocks
+		    );
+    %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars      @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'File::stat' => [
+     map { $_ => '$' } qw{
+	 dev ino mode nlink uid gid rdev size
+	 atime mtime ctime blksize blocks
+     }
+];
+
+sub populate (@) {
+    return unless @_;
+    my $stob = new();
+    @$stob = (
+	$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
+        $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) 
+	    = @_;
+    return $stob;
+} 
+
+sub lstat ($)  { populate(CORE::lstat(shift)) }
+
+sub stat ($) {
+    my $arg = shift;
+    my $st = populate(CORE::stat $arg);
+    return $st if $st;
+    no strict 'refs';
+    require Symbol;
+    return populate(CORE::stat \*{Symbol::qualify($arg)});
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::stat - by-name interface to Perl's built-in stat() functions
+
+=head1 SYNOPSIS
+
+ use File::stat;
+ $st = stat($file) or die "No $file: $!";
+ if ( ($st->mode & 0111) && $st->nlink > 1) ) {
+     print "$file is executable with lotsa links\n";
+ } 
+
+ use File::stat qw(:FIELDS);
+ stat($file) or die "No $file: $!";
+ if ( ($st_mode & 0111) && $st_nlink > 1) ) {
+     print "$file is executable with lotsa links\n";
+ } 
+
+=head1 DESCRIPTION
+
+This module's default exports override the core stat() 
+and lstat() functions, replacing them with versions that return 
+"File::stat" objects.  This object has methods that
+return the similarly named structure field name from the
+stat(2) function; namely,
+dev,
+ino,
+mode,
+nlink,
+uid,
+gid,
+rdev,
+size,
+atime,
+mtime,
+ctime,
+blksize,
+and
+blocks.  
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag.  (Note that this still
+overrides your stat() and lstat() functions.)  Access these fields as
+variables named with a preceding C<st_> in front their method names.
+Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
+the fields.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen