1 files changed, 138 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;