1 package File::Basename;
7 @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
9 # fileparse_set_fstype() - specify OS-based rules used in future
10 # calls to routines in this package
12 # Currently recognized values: VMS, MSDOS, MacOS
13 # Any other name uses Unix-style rules
15 sub fileparse_set_fstype {
16 my($old) = $Fileparse_fstype;
17 $Fileparse_fstype = $_[0] if $_[0];
21 # fileparse() - parse file specification
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.
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
47 # For example, on a system running Unix,
48 # ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
50 # would yield $base == 'draft',
51 # $path == '/virgil/aeneid/' (note trailing slash)
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
59 # Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu
63 my($fullname,@suffices) = @_;
64 my($fstype) = $Fileparse_fstype;
65 my($dirpath,$tail,$suffix,$idx);
67 if ($fstype =~ /^VMS/i) {
68 if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
70 ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
71 $dirpath = $ENV{'DEFAULT'} unless $dirpath;
74 if ($fstype =~ /^MSDOS/i) {
75 ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
76 $dirpath = '.' unless $dirpath;
78 elsif ($fstype =~ /^MAC/i) {
79 ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
81 elsif ($fstype !~ /^VMS/i) { # default to Unix
82 ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
83 $dirpath = '.' unless $dirpath;
87 foreach $suffix (@suffices) {
88 if ($basename =~ /($suffix)$/) {
95 wantarray ? ($basename,$dirpath,$tail) : $basename;
100 # basename() - returns first element of list returned by fileparse()
104 (fileparse($name, map("\Q$_\E",@_)))[0];
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.
116 my($basename,$dirname) = fileparse($_[0]);
117 my($fstype) = $Fileparse_fstype;
119 if ($fstype =~ /VMS/i) {
120 if ($_[0] =~ m#/#) { $fstype = '' }
121 else { return $dirname }
123 if ($fstype =~ /MacOS/i) { return $dirname }
124 elsif ($fstype =~ /MSDOS/i) {
125 if ( $dirname =~ /:\\$/) { return $dirname }
127 $dirname =~ s:[^\\]+$:: unless $basename;
128 $dirname = '.' unless $dirname;
131 if ( $dirname eq '/') { return $dirname }
133 $dirname =~ s:[^/]+$:: unless $basename;
134 $dirname = '.' unless $dirname;
140 $Fileparse_fstype = $Config{'osname'};