lib/File/Basename.pm

   1 package File::Basename;
   2
   3 require 5.000;
   4 use Config;
   5 require Exporter;
   6 @ISA = qw(Exporter);
   7 @EXPORT = qw(fileparse set_fileparse_fstype basename dirname);
   8
   9 #   fileparse_set_fstype() - specify OS-based rules used in future
  10 #                            calls to routines in this package
  11 #
  12 #   Currently recognized values: VMS, MSDOS, MacOS
  13 #       Any other name uses Unix-style rules
  14
  15 sub fileparse_set_fstype {
  16   $Fileparse_fstype = $_[0];
  17 }
  18
  19 #   fileparse() - parse file specification
  20 #
  21 #   calling sequence:
  22 #     ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist);
  23 #     where  $filespec    is the file specification to be parsed, and
  24 #            @excludelist is a list of patterns which should be removed
  25 #                         from the end of $filename.
  26 #            $filename    is the part of $filespec after $prefix (i.e. the
  27 #                         name of the file).  The elements of @excludelist
  28 #                         are compared to $filename, and if an
  29 #            $prefix     is the path portion $filespec, up to and including
  30 #                        the end of the last directory name
  31 #            $tail        any characters removed from $filename because they
  32 #                         matched an element of @excludelist.
  33 #
  34 #   fileparse() first removes the directory specification from $filespec,
  35 #   according to the syntax of the OS (code is provided below to handle
  36 #   VMS, Unix, MSDOS and MacOS; you can pick the one you want using
  37 #   fileparse_set_fstype(), or you can accept the default, which is
  38 #   based on the information in the %Config array).  It then compares
  39 #   each element of @excludelist to $filename, and if that element is a
  40 #   suffix of $filename, it is removed from $filename and prepended to
  41 #   $tail.  By specifying the elements of @excludelist in the right order,
  42 #   you can 'nibble back' $filename to extract the portion of interest
  43 #   to you.
  44 #
  45 #   For example, on a system running Unix,
  46 #   ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
  47 #                                       '\.book\d+');
  48 #   would yield $base == 'draft',
  49 #               $path == '/virgil/aeneid', and
  50 #               $tail == '.book7'.
  51 #   Similarly, on a system running VMS,
  52 #   ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
  53 #   would yield $name == 'Rhetoric';
  54 #               $dir == 'Doc_Root:[Help]', and
  55 #               $type == '.Rnh'.
  56 #
  57 #   Version 2.2  13-Oct-1994  Charles Bailey  bailey@genetics.upenn.edu
  58
  59
  60 sub fileparse {
  61   my($fullname,@suffices) = @_;
  62   my($fstype) = $Fileparse_fstype;
  63   my($dirpath,$tail,$suffix,$idx);
  64
  65   if ($fstype =~ /^VMS/i) {
  66     if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
  67     else {
  68       ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
  69       $dirpath = $ENV{'PATH'} unless $dirpath;
  70     }
  71   }
  72   if ($fstype =~ /^MSDOS/i) {
  73     ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
  74     $dirpath = '.' unless $dirpath;
  75   }
  76   elsif ($fstype =~ /^MAC/i) {
  77     ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
  78   }
  79   else {  # default to Unix
  80     ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
  81     $dirpath = '.' unless $dirpath;
  82   }
  83
  84   if (@suffices) {
  85     foreach $suffix (@suffices) {
  86       if ($basename =~ /($suffix)$/) {
  87         $tail = $1 . $tail;
  88         $basename = $`;
  89       }
  90     }
  91   }
  92
  93   ($basename,$dirpath,$tail);
  94
  95 }
  96
  97
  98 #   basename() - returns first element of list returned by fileparse()
  99
 100 sub basename {
 101   (fileparse(@_))[0];
 102 }
 103
 104
 105 #    dirname() - returns device and directory portion of file specification
 106 #        Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
 107 #        filespecs.  This differs from the second element of the list returned
 108 #        by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
 109 #        the last directory name if the filespec ends in a '/' or '\'), is lost.
 110
 111 sub dirname {
 112     my($basename,$dirname) = fileparse($_[0]);
 113     my($fstype) = $Fileparse_fstype;
 114
 115     if ($fstype =~ /VMS/i) {
 116         if (m#/#) { $fstype = '' }
 117         else { return $dirname }
 118     }
 119     if ($fstype =~ /MacOS/i) { return $dirname }
 120     elsif ($fstype =~ /MSDOS/i) {
 121         if ( $dirname =~ /:\\$/) { return $dirname }
 122         chop $dirname;
 123         $dirname =~ s:[^/]+$:: unless $basename;
 124         $dirname = '.' unless $dirname;
 125     }
 126     else {
 127         if ( $dirname eq '/') { return $dirname }
 128         chop $dirname;
 129         $dirname =~ s:[^/]+$:: unless $basename;
 130         $dirname = '.' unless $dirname;
 131     }
 132
 133     $dirname;
 134 }
 135
 136 $Fileparse_fstype = $Config{'osname'};
 137
 138 1;