Commit | Line | Data |
a0d0e21e |
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; |