Perl 5.001perl-5.001

[See the Changes file for a list of changes]

4 files changed, 61 insertions, 31 deletions

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 9e2e25e889..5e09ae4977 100644
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -4,7 +4,7 @@ require 5.000;
 use Config;
 require Exporter;
 @ISA = qw(Exporter);
-@EXPORT = qw(fileparse set_fileparse_fstype basename dirname);
+@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
 
 #   fileparse_set_fstype() - specify OS-based rules used in future
 #                            calls to routines in this package
@@ -13,7 +13,9 @@ require Exporter;
 #       Any other name uses Unix-style rules
 
 sub fileparse_set_fstype {
-  $Fileparse_fstype = $_[0];
+  my($old) = $Fileparse_fstype;
+  $Fileparse_fstype = $_[0] if $_[0];
+  $old;
 }
 
 #   fileparse() - parse file specification
@@ -46,7 +48,7 @@ sub fileparse_set_fstype {
 #   ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
 #                                       '\.book\d+');
 #   would yield $base == 'draft',
-#               $path == '/virgil/aeneid', and
+#               $path == '/virgil/aeneid/'  (note trailing slash)
 #               $tail == '.book7'.
 #   Similarly, on a system running VMS,
 #   ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
@@ -66,7 +68,7 @@ sub fileparse {
     if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
     else {
       ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
-      $dirpath = $ENV{'PATH'} unless $dirpath;
+      $dirpath = $ENV{'DEFAULT'} unless $dirpath;
     }
   }
   if ($fstype =~ /^MSDOS/i) {
@@ -76,7 +78,7 @@ sub fileparse {
   elsif ($fstype =~ /^MAC/i) {
     ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
   }
-  else {  # default to Unix
+  elsif ($fstype !~ /^VMS/i) {  # default to Unix
     ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
     $dirpath = '.' unless $dirpath;
   }
@@ -90,7 +92,7 @@ sub fileparse {
     }
   }
 
-  ($basename,$dirpath,$tail);
+  wantarray ? ($basename,$dirpath,$tail) : $basename;
 
 }
 
@@ -98,13 +100,15 @@ sub fileparse {
 #   basename() - returns first element of list returned by fileparse()
 
 sub basename {
-  (fileparse(@_))[0];
+  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
-#        filespecs.  This differs from the second element of the list returned
+#        filespecs except for names ending with a separator, e.g., "/xx/yy/".
+#        This differs from the second element of the list returned
 #        by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
 #        the last directory name if the filespec ends in a '/' or '\'), is lost.
 
@@ -113,14 +117,14 @@ sub dirname {
     my($fstype) = $Fileparse_fstype;
 
     if ($fstype =~ /VMS/i) { 
-        if (m#/#) { $fstype = '' }
+        if ($_[0] =~ m#/#) { $fstype = '' }
         else { return $dirname }
     }
     if ($fstype =~ /MacOS/i) { return $dirname }
     elsif ($fstype =~ /MSDOS/i) { 
         if ( $dirname =~ /:\\$/) { return $dirname }
         chop $dirname;
-        $dirname =~ s:[^/]+$:: unless $basename;
+        $dirname =~ s:[^\\]+$:: unless $basename;
         $dirname = '.' unless $dirname;
     }
     else { 
diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm
index d3dfa70084..a440bda71e 100644
--- a/lib/File/CheckTree.pm
+++ b/lib/File/CheckTree.pm
@@ -98,11 +98,11 @@ sub valmess {
 	    $mess =~ s/ does not / should not / ||
 	    $mess =~ s/ not / /;
 	}
-	print stderr $mess,"\n";
+	print STDERR $mess,"\n";
     }
     else {
 	$this =~ s/\$file/'$file'/g;
-	print stderr "Can't do $this.\n";
+	print STDERR "Can't do $this.\n";
     }
     if ($disposition eq 'die') { exit 1; }
     ++$warnings;
diff --git a/lib/File/Find.pm b/lib/File/Find.pm
index 612f14525a..c7b0051ce2 100644
--- a/lib/File/Find.pm
+++ b/lib/File/Find.pm
@@ -1,9 +1,12 @@
 package File::Find;
 require 5.000;
 require Exporter;
+use Config;
+use Cwd;
+use File::Basename;
 
 @ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
+@EXPORT = qw(find finddepth $name $dir);
 
 # Usage:
 #	use File::Find;
@@ -38,7 +41,7 @@ require Exporter;
 
 sub find {
     my $wanted = shift;
-    chop($cwd = `pwd`);
+    my $cwd = fastcwd();
     foreach $topdir (@_) {
 	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
 	  || (warn("Can't stat $topdir: $!\n"), next);
@@ -48,6 +51,7 @@ sub find {
 		$name = $topdir;
 		&$wanted;
 		($fixtopdir = $topdir) =~ s,/$,, ;
+		$fixtopdir =~ s/\.dir$// if $Is_VMS; ;
 		&finddir($wanted,$fixtopdir,$topnlink);
 	    }
 	    else {
@@ -55,7 +59,7 @@ sub find {
 	    }
 	}
 	else {
-	    unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+	    unless (($dir,$_) = fileparse($topdir)) {
 		($dir,$_) = ('.', $topdir);
 	    }
 	    $name = $topdir;
@@ -97,13 +101,15 @@ sub finddir {
 
 		# Get link count and check for directoriness.
 
-		($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+		($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_))
+		    unless ($nlink || $dont_use_nlink);
 		
 		if (-d _) {
 
 		    # It really is a directory, so do it recursively.
 
 		    if (!$prune && chdir $_) {
+			$name =~ s/\.dir$// if $Is_VMS;
 			&finddir($wanted,$name,$nlink);
 			chdir '..';
 		    }
@@ -145,13 +151,14 @@ sub finddir {
 
 sub finddepth {
     my $wanted = shift;
-    chop($cwd = `pwd`);
+    $cwd = fastcwd();;
     foreach $topdir (@_) {
 	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
 	  || (warn("Can't stat $topdir: $!\n"), next);
 	if (-d _) {
 	    if (chdir($topdir)) {
 		($fixtopdir = $topdir) =~ s,/$,, ;
+		$fixtopdir =~ s/\.dir$// if $Is_VMS;
 		&finddepthdir($wanted,$fixtopdir,$topnlink);
 		($dir,$_) = ($fixtopdir,'.');
 		$name = $fixtopdir;
@@ -162,7 +169,7 @@ sub finddepth {
 	    }
 	}
 	else {
-	    unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+	    unless (($dir,$_) = fileparse($topdir)) {
 		($dir,$_) = ('.', $topdir);
 	    }
 	    chdir $dir && &$wanted;
@@ -182,7 +189,7 @@ sub finddepthdir {
     my(@filenames) = readdir(DIR);
     closedir(DIR);
 
-    if ($nlink == 2) {        # This dir has no subdirectories.
+    if ($nlink == 2 && !$dont_use_nlink) {   # This dir has no subdirectories.
 	for (@filenames) {
 	    next if $_ eq '.';
 	    next if $_ eq '..';
@@ -198,17 +205,18 @@ sub finddepthdir {
 	    next if $_ eq '..';
 	    $nlink = $prune = 0;
 	    $name = "$dir/$_";
-	    if ($subcount > 0) {    # Seen all the subdirs?
+	    if ($subcount > 0 || $dont_use_nlink) {    # Seen all the subdirs?
 
 		# Get link count and check for directoriness.
 
-		($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+		($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_));
 		
 		if (-d _) {
 
 		    # It really is a directory, so do it recursively.
 
 		    if (!$prune && chdir $_) {
+			$name =~ s/\.dir$// if $Is_VMS;
 			&finddepthdir($wanted,$name,$nlink);
 			chdir '..';
 		    }
@@ -220,5 +228,10 @@ sub finddepthdir {
     }
 }
 
+if ($Config{'osname'} eq 'VMS') {
+  $Is_VMS = 1;
+  $dont_use_nlink = 1;
+}
+
 1;
 
diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 30f550d7f4..ec117b8de9 100644
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -58,17 +58,19 @@ Unix file specification syntax.
 =item *
 
 a boolean value, which if TRUE will cause C<rmtree> to
-print a message each time it tries to delete a file,
-giving the name of the file, and indicating whether
-it's using C<rmdir> or C<unlink> to remove it.
+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 write access.
-This will change in the future when a criterion for
-'delete permission' is settled. (defaults to FALSE)
+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
 
@@ -81,7 +83,7 @@ Charles Bailey <bailey@genetics.upenn.edu>
 
 =head1 REVISION
 
-This document was last revised 29-Jan-1995, for perl 5.001
+This document was last revised 08-Mar-1995, for perl 5.001
 
 =cut
 
@@ -92,6 +94,8 @@ require Exporter;
 @ISA = qw( Exporter );
 @EXPORT = qw( mkpath rmtree );
 
+$Is_VMS = $Config{'osname'} eq 'VMS';
+
 sub mkpath{
     my($paths, $verbose, $mode) = @_;
     # $paths   -- either a path string or ref to list of paths
@@ -102,7 +106,7 @@ sub mkpath{
     $paths = [$paths] unless ref $paths;
     my(@created);
     foreach $path (@$paths){
-	next if -d $path;
+        next if -d $path;
         my(@p);
         foreach(split(/\//, $path)){
             push(@p, $_);
@@ -124,15 +128,24 @@ sub rmtree {
        $root =~ s#/$##;
        if (-d $root) { 
            opendir(D,$root);
+           $root =~ s#\.dir$## if $Is_VMS;
            @files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D));
            closedir(D);
            $count += rmtree(\@files,$verbose,$safe);
-           next if ($safe && !(-w $root));
+           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 { 
-           next if ($safe && !(-w $root));
+           if ($safe &&
+               ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+               print "skipped $root\n" if $verbose;
+               next;
+           }
            print "unlink $root\n" if $verbose;
            (unlink($root) && ++$count) or carp "Can't unlink file $root: $!";
         }