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