1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
package File::Basename;
require 5.000;
use Config;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_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 {
my($old) = $Fileparse_fstype;
$Fileparse_fstype = $_[0] if $_[0];
$old;
}
# 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/' (note trailing slash)
# $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{'DEFAULT'} unless $dirpath;
}
}
if ($fstype =~ /^MSDOS/i) {
($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
$dirpath = '.' unless $dirpath;
}
elsif ($fstype =~ /^MAC/i) {
($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
}
elsif ($fstype !~ /^VMS/i) { # default to Unix
($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
$dirpath = '.' unless $dirpath;
}
if (@suffices) {
foreach $suffix (@suffices) {
if ($basename =~ /($suffix)$/) {
$tail = $1 . $tail;
$basename = $`;
}
}
}
wantarray ? ($basename,$dirpath,$tail) : $basename;
}
# basename() - returns first element of list returned by fileparse()
sub basename {
my($name) = shift;
(fileparse($name, map("\Q$_\E",@_)))[0];
}
# dirname() - returns device and directory portion of file specification
# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
# filespecs except for names ending with a separator, e.g., "/xx/yy/".
# 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 ($_[0] =~ 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;
|
