perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

3 files changed, 474 insertions, 0 deletions

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
new file mode 100644
index 0000000000..9e2e25e889
--- /dev/null
+++ b/lib/File/Basename.pm
@@ -0,0 +1,138 @@
+package File::Basename;
+
+require 5.000;
+use Config;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(fileparse set_fileparse_fstype basename dirname);
+
+#   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
+
+sub fileparse_set_fstype {
+  $Fileparse_fstype = $_[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 %Config array).  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', and
+#               $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 
+
+
+sub fileparse {
+  my($fullname,@suffices) = @_;
+  my($fstype) = $Fileparse_fstype;
+  my($dirpath,$tail,$suffix,$idx);
+
+  if ($fstype =~ /^VMS/i) {
+    if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
+    else {
+      ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
+      $dirpath = $ENV{'PATH'} unless $dirpath;
+    }
+  }
+  if ($fstype =~ /^MSDOS/i) {
+    ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
+    $dirpath = '.' unless $dirpath;
+  }
+  elsif ($fstype =~ /^MAC/i) {
+    ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
+  }
+  else {  # default to Unix
+    ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
+    $dirpath = '.' unless $dirpath;
+  }
+
+  if (@suffices) {
+    foreach $suffix (@suffices) {
+      if ($basename =~ /($suffix)$/) {
+        $tail = $1 . $tail;
+        $basename = $`;
+      }
+    }
+  }
+
+  ($basename,$dirpath,$tail);
+
+}
+
+
+#   basename() - returns first element of list returned by fileparse()
+
+sub basename {
+  (fileparse(@_))[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
+#        by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
+#        the last directory name if the filespec ends in a '/' or '\'), is lost.
+
+sub dirname {
+    my($basename,$dirname) = fileparse($_[0]);
+    my($fstype) = $Fileparse_fstype;
+
+    if ($fstype =~ /VMS/i) { 
+        if (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 = '.' unless $dirname;
+    }
+    else { 
+        if ( $dirname eq '/') { return $dirname }
+        chop $dirname;
+        $dirname =~ s:[^/]+$:: unless $basename;
+        $dirname = '.' unless $dirname;
+    }
+
+    $dirname;
+}
+
+$Fileparse_fstype = $Config{'osname'};
+
+1;
diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm
new file mode 100644
index 0000000000..d3dfa70084
--- /dev/null
+++ b/lib/File/CheckTree.pm
@@ -0,0 +1,112 @@
+package File::CheckTree;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(validate);
+
+# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
+
+# The validate routine takes a single multiline string consisting of
+# lines containing a filename plus a file test to try on it.  (The
+# file test may also be a 'cd', causing subsequent relative filenames
+# to be interpreted relative to that directory.)  After the file test
+# you may put '|| die' to make it a fatal error if the file test fails.
+# The default is '|| warn'.  The file test may optionally have a ! prepended
+# to test for the opposite condition.  If you do a cd and then list some
+# relative filenames, you may want to indent them slightly for readability.
+# If you supply your own "die" or "warn" message, you can use $file to
+# interpolate the filename.
+
+# Filetests may be bunched:  -rwx tests for all of -r, -w and -x.
+# Only the first failed test of the bunch will produce a warning.
+
+# The routine returns the number of warnings issued.
+
+# Usage:
+#	use File::CheckTree;
+#	$warnings += validate('
+#	/vmunix			-e || die
+#	/boot			-e || die
+#	/bin			cd
+#	    csh			-ex
+#	    csh			!-ug
+#	    sh			-ex
+#	    sh			!-ug
+#	/usr			-d || warn "What happened to $file?\n"
+#	');
+
+sub validate {
+    local($file,$test,$warnings,$oldwarnings);
+    foreach $check (split(/\n/,$_[0])) {
+	next if $check =~ /^#/;
+	next if $check =~ /^$/;
+	($file,$test) = split(' ',$check,2);
+	if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
+	    $testlist = $2;
+	    @testlist = split(//,$testlist);
+	}
+	else {
+	    @testlist = ('Z');
+	}
+	$oldwarnings = $warnings;
+	foreach $one (@testlist) {
+	    $this = $test;
+	    $this =~ s/(-\w\b)/$1 \$file/g;
+	    $this =~ s/-Z/-$one/;
+	    $this .= ' || warn' unless $this =~ /\|\|/;
+	    $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/;
+	    $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
+	    eval $this;
+	    last if $warnings > $oldwarnings;
+	}
+    }
+    $warnings;
+}
+
+sub valmess {
+    local($disposition,$this) = @_;
+    $file = $cwd . '/' . $file unless $file =~ m|^/|;
+    if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
+	$neg = $1;
+	$tmp = $2;
+	$tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
+	$tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
+	$tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
+	$tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
+	$tmp eq 'R' && ($mess = "$file is not readable by you.");
+	$tmp eq 'W' && ($mess = "$file is not writable by you.");
+	$tmp eq 'X' && ($mess = "$file is not executable by you.");
+	$tmp eq 'O' && ($mess = "$file is not owned by you.");
+	$tmp eq 'e' && ($mess = "$file does not exist.");
+	$tmp eq 'z' && ($mess = "$file does not have zero size.");
+	$tmp eq 's' && ($mess = "$file does not have non-zero size.");
+	$tmp eq 'f' && ($mess = "$file is not a plain file.");
+	$tmp eq 'd' && ($mess = "$file is not a directory.");
+	$tmp eq 'l' && ($mess = "$file is not a symbolic link.");
+	$tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
+	$tmp eq 'S' && ($mess = "$file is not a socket.");
+	$tmp eq 'b' && ($mess = "$file is not a block special file.");
+	$tmp eq 'c' && ($mess = "$file is not a character special file.");
+	$tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
+	$tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
+	$tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
+	$tmp eq 'T' && ($mess = "$file is not a text file.");
+	$tmp eq 'B' && ($mess = "$file is not a binary file.");
+	if ($neg eq '!') {
+	    $mess =~ s/ is not / should not be / ||
+	    $mess =~ s/ does not / should not / ||
+	    $mess =~ s/ not / /;
+	}
+	print stderr $mess,"\n";
+    }
+    else {
+	$this =~ s/\$file/'$file'/g;
+	print stderr "Can't do $this.\n";
+    }
+    if ($disposition eq 'die') { exit 1; }
+    ++$warnings;
+}
+
+1;
+
diff --git a/lib/File/Find.pm b/lib/File/Find.pm
new file mode 100644
index 0000000000..612f14525a
--- /dev/null
+++ b/lib/File/Find.pm
@@ -0,0 +1,224 @@
+package File::Find;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(find finddepth);
+
+# Usage:
+#	use File::Find;
+#
+#	find(\&wanted, '/foo','/bar');
+#
+#	sub wanted { ... }
+#		where wanted does whatever you want.  $dir contains the
+#		current directory name, and $_ the current filename within
+#		that directory.  $name contains "$dir/$_".  You are cd'ed
+#		to $dir when the function is called.  The function may
+#		set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+#   find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+#	sub wanted {
+#	    /^\.nfs.*$/ &&
+#	    (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+#	    int(-M _) > 7 &&
+#	    unlink($_)
+#	    ||
+#	    ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+#	    $dev < 0 &&
+#	    ($prune = 1);
+#	}
+#
+# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
+
+sub find {
+    my $wanted = shift;
+    chop($cwd = `pwd`);
+    foreach $topdir (@_) {
+	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+	  || (warn("Can't stat $topdir: $!\n"), next);
+	if (-d _) {
+	    if (chdir($topdir)) {
+		($dir,$_) = ($topdir,'.');
+		$name = $topdir;
+		&$wanted;
+		($fixtopdir = $topdir) =~ s,/$,, ;
+		&finddir($wanted,$fixtopdir,$topnlink);
+	    }
+	    else {
+		warn "Can't cd to $topdir: $!\n";
+	    }
+	}
+	else {
+	    unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+		($dir,$_) = ('.', $topdir);
+	    }
+	    $name = $topdir;
+	    chdir $dir && &$wanted;
+	}
+	chdir $cwd;
+    }
+}
+
+sub finddir {
+    local($wanted,$dir,$nlink) = @_;
+    local($dev,$ino,$mode,$subcount);
+    local($name);
+
+    # Get the list of files in the current directory.
+
+    opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
+    local(@filenames) = readdir(DIR);
+    closedir(DIR);
+
+    if ($nlink == 2 && !$dont_use_nlink) {  # This dir has no subdirectories.
+	for (@filenames) {
+	    next if $_ eq '.';
+	    next if $_ eq '..';
+	    $name = "$dir/$_";
+	    $nlink = 0;
+	    &$wanted;
+	}
+    }
+    else {                    # This dir has subdirectories.
+	$subcount = $nlink - 2;
+	for (@filenames) {
+	    next if $_ eq '.';
+	    next if $_ eq '..';
+	    $nlink = $prune = 0;
+	    $name = "$dir/$_";
+	    &$wanted;
+	    if ($subcount > 0 || $dont_use_nlink) {    # Seen all the subdirs?
+
+		# Get link count and check for directoriness.
+
+		($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+		
+		if (-d _) {
+
+		    # It really is a directory, so do it recursively.
+
+		    if (!$prune && chdir $_) {
+			&finddir($wanted,$name,$nlink);
+			chdir '..';
+		    }
+		    --$subcount;
+		}
+	    }
+	}
+    }
+}
+
+# Usage:
+#	use File::Find;
+#
+#	finddepth(\&wanted, '/foo','/bar');
+#
+#	sub wanted { ... }
+#		where wanted does whatever you want.  $dir contains the
+#		current directory name, and $_ the current filename within
+#		that directory.  $name contains "$dir/$_".  You are cd'ed
+#		to $dir when the function is called.  The function may
+#		set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+#   find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+#	sub wanted {
+#	    /^\.nfs.*$/ &&
+#	    (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+#	    int(-M _) > 7 &&
+#	    unlink($_)
+#	    ||
+#	    ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+#	    $dev < 0 &&
+#	    ($prune = 1);
+#	}
+
+sub finddepth {
+    my $wanted = shift;
+    chop($cwd = `pwd`);
+    foreach $topdir (@_) {
+	(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+	  || (warn("Can't stat $topdir: $!\n"), next);
+	if (-d _) {
+	    if (chdir($topdir)) {
+		($fixtopdir = $topdir) =~ s,/$,, ;
+		&finddepthdir($wanted,$fixtopdir,$topnlink);
+		($dir,$_) = ($fixtopdir,'.');
+		$name = $fixtopdir;
+		&$wanted;
+	    }
+	    else {
+		warn "Can't cd to $topdir: $!\n";
+	    }
+	}
+	else {
+	    unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+		($dir,$_) = ('.', $topdir);
+	    }
+	    chdir $dir && &$wanted;
+	}
+	chdir $cwd;
+    }
+}
+
+sub finddepthdir {
+    my($wanted,$dir,$nlink) = @_;
+    my($dev,$ino,$mode,$subcount);
+    my($name);
+
+    # Get the list of files in the current directory.
+
+    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+    my(@filenames) = readdir(DIR);
+    closedir(DIR);
+
+    if ($nlink == 2) {        # This dir has no subdirectories.
+	for (@filenames) {
+	    next if $_ eq '.';
+	    next if $_ eq '..';
+	    $name = "$dir/$_";
+	    $nlink = 0;
+	    &$wanted;
+	}
+    }
+    else {                    # This dir has subdirectories.
+	$subcount = $nlink - 2;
+	for (@filenames) {
+	    next if $_ eq '.';
+	    next if $_ eq '..';
+	    $nlink = $prune = 0;
+	    $name = "$dir/$_";
+	    if ($subcount > 0) {    # Seen all the subdirs?
+
+		# Get link count and check for directoriness.
+
+		($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+		
+		if (-d _) {
+
+		    # It really is a directory, so do it recursively.
+
+		    if (!$prune && chdir $_) {
+			&finddepthdir($wanted,$name,$nlink);
+			chdir '..';
+		    }
+		    --$subcount;
+		}
+	    }
+	    &$wanted;
+	}
+    }
+}
+
+1;
+