line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package File::Spec::VMS; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
2142
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
77
|
|
4
|
2
|
|
|
2
|
|
11
|
use Cwd (); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
134
|
|
5
|
|
|
|
|
|
|
require File::Spec::Unix; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '3.75'; |
8
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our @ISA = qw(File::Spec::Unix); |
11
|
|
|
|
|
|
|
|
12
|
2
|
|
|
2
|
|
16
|
use File::Basename; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
202
|
|
13
|
2
|
|
|
2
|
|
304
|
use VMS::Filespec; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
105
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 NAME |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
File::Spec::VMS - methods for VMS file specs |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 SYNOPSIS |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
require File::Spec::VMS; # Done internally by File::Spec if needed |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
=head1 DESCRIPTION |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
See File::Spec::Unix for a documentation of the methods provided |
26
|
|
|
|
|
|
|
there. This package overrides the implementation of these methods, not |
27
|
|
|
|
|
|
|
the semantics. |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
The default behavior is to allow either VMS or Unix syntax on input and to |
30
|
|
|
|
|
|
|
return VMS syntax on output unless Unix syntax has been explicitly requested |
31
|
|
|
|
|
|
|
via the C CRTL feature. |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=over 4 |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=cut |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# Need to look up the feature settings. The preferred way is to use the |
38
|
|
|
|
|
|
|
# VMS::Feature module, but that may not be available to dual life modules. |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
my $use_feature; |
41
|
|
|
|
|
|
|
BEGIN { |
42
|
1
|
50
|
|
1
|
|
3
|
if (eval { local $SIG{__DIE__}; |
|
1
|
|
|
|
|
5
|
|
43
|
1
|
|
|
|
|
5
|
local @INC = @INC; |
44
|
1
|
50
|
|
|
|
4
|
pop @INC if $INC[-1] eq '.'; |
45
|
1
|
|
|
|
|
3858
|
require VMS::Feature; }) { |
46
|
0
|
|
|
|
|
0
|
$use_feature = 1; |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# Need to look up the UNIX report mode. This may become a dynamic mode |
51
|
|
|
|
|
|
|
# in the future. |
52
|
|
|
|
|
|
|
sub _unix_rpt { |
53
|
131
|
|
|
131
|
|
164
|
my $unix_rpt; |
54
|
131
|
50
|
|
|
|
229
|
if ($use_feature) { |
55
|
0
|
|
|
|
|
0
|
$unix_rpt = VMS::Feature::current("filename_unix_report"); |
56
|
|
|
|
|
|
|
} else { |
57
|
131
|
|
50
|
|
|
415
|
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; |
58
|
131
|
|
|
|
|
208
|
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i; |
59
|
|
|
|
|
|
|
} |
60
|
131
|
|
|
|
|
253
|
return $unix_rpt; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=item canonpath (override) |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
Removes redundant portions of file specifications and returns results |
66
|
|
|
|
|
|
|
in native syntax unless Unix filename reporting has been enabled. |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=cut |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub canonpath { |
72
|
91
|
|
|
91
|
1
|
23437
|
my($self,$path) = @_; |
73
|
|
|
|
|
|
|
|
74
|
91
|
50
|
|
|
|
199
|
return undef unless defined $path; |
75
|
|
|
|
|
|
|
|
76
|
91
|
|
|
|
|
206
|
my $unix_rpt = $self->_unix_rpt; |
77
|
|
|
|
|
|
|
|
78
|
91
|
100
|
|
|
|
253
|
if ($path =~ m|/|) { |
79
|
1
|
|
|
|
|
9
|
my $pathify = $path =~ m|/\Z(?!\n)|; |
80
|
1
|
|
|
|
|
19
|
$path = $self->SUPER::canonpath($path); |
81
|
|
|
|
|
|
|
|
82
|
1
|
50
|
|
|
|
4
|
return $path if $unix_rpt; |
83
|
1
|
50
|
|
|
|
21
|
$path = $pathify ? vmspath($path) : vmsify($path); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
90
|
|
|
|
|
143
|
$path =~ s/(? ==> [ and ] |
87
|
90
|
|
|
|
|
123
|
$path =~ s/(?/]/; |
88
|
90
|
|
|
|
|
128
|
$path =~ s/(? .][ |
89
|
90
|
|
|
|
|
165
|
$path =~ s/(? [ |
90
|
90
|
|
|
|
|
153
|
$path =~ s/(? [ |
91
|
90
|
|
|
|
|
113
|
$path =~ s/(? ] |
92
|
90
|
|
|
|
|
131
|
$path =~ s/(? foo.bar |
93
|
90
|
|
|
|
|
189
|
1 while ($path =~ s/(?
|
94
|
|
|
|
|
|
|
# That loop does the following |
95
|
|
|
|
|
|
|
# with any amount of dashes: |
96
|
|
|
|
|
|
|
# .-.-. ==> .--. |
97
|
|
|
|
|
|
|
# [-.-. ==> [--. |
98
|
|
|
|
|
|
|
# .-.-] ==> .--] |
99
|
|
|
|
|
|
|
# [-.-] ==> [--] |
100
|
90
|
|
|
|
|
318
|
1 while ($path =~ s/(?
|
101
|
|
|
|
|
|
|
# That loop does the following |
102
|
|
|
|
|
|
|
# with any amount (minimum 2) |
103
|
|
|
|
|
|
|
# of dashes: |
104
|
|
|
|
|
|
|
# .foo.--. ==> .-. |
105
|
|
|
|
|
|
|
# .foo.--] ==> .-] |
106
|
|
|
|
|
|
|
# [foo.--. ==> [-. |
107
|
|
|
|
|
|
|
# [foo.--] ==> [-] |
108
|
|
|
|
|
|
|
# |
109
|
|
|
|
|
|
|
# And then, the remaining cases |
110
|
90
|
|
|
|
|
140
|
$path =~ s/(? [- |
111
|
90
|
|
|
|
|
156
|
$path =~ s/(? . |
112
|
90
|
|
|
|
|
155
|
$path =~ s/(? [ |
113
|
90
|
|
|
|
|
189
|
$path =~ s/(? ] |
114
|
|
|
|
|
|
|
# [foo.-] ==> [000000] |
115
|
90
|
|
|
|
|
143
|
$path =~ s/(?
|
116
|
|
|
|
|
|
|
# [] ==> |
117
|
90
|
50
|
|
|
|
209
|
$path =~ s/(?
|
118
|
90
|
50
|
|
|
|
496
|
return $unix_rpt ? unixify($path) : $path; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=item catdir (override) |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
Concatenates a list of file specifications, and returns the result as a |
124
|
|
|
|
|
|
|
native directory specification unless the Unix filename reporting feature |
125
|
|
|
|
|
|
|
has been enabled. No check is made for "impossible" cases (e.g. elements |
126
|
|
|
|
|
|
|
other than the first being absolute filespecs). |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=cut |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub catdir { |
131
|
27
|
|
|
27
|
1
|
5746
|
my $self = shift; |
132
|
27
|
|
|
|
|
38
|
my $dir = pop; |
133
|
|
|
|
|
|
|
|
134
|
27
|
|
|
|
|
49
|
my $unix_rpt = $self->_unix_rpt; |
135
|
|
|
|
|
|
|
|
136
|
27
|
50
|
|
|
|
55
|
my @dirs = grep {defined() && length()} @_; |
|
33
|
|
|
|
|
112
|
|
137
|
|
|
|
|
|
|
|
138
|
27
|
|
|
|
|
34
|
my $rslt; |
139
|
27
|
100
|
|
|
|
52
|
if (@dirs) { |
140
|
24
|
100
|
|
|
|
57
|
my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); |
141
|
19
|
|
|
|
|
37
|
my ($spath,$sdir) = ($path,$dir); |
142
|
19
|
|
|
|
|
39
|
$spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; |
|
19
|
|
|
|
|
28
|
|
143
|
|
|
|
|
|
|
|
144
|
19
|
50
|
|
|
|
37
|
if ($unix_rpt) { |
145
|
0
|
0
|
|
|
|
0
|
$spath = unixify($spath) unless $spath =~ m#/#; |
146
|
0
|
0
|
|
|
|
0
|
$sdir= unixify($sdir) unless $sdir =~ m#/#; |
147
|
0
|
|
|
|
|
0
|
return $self->SUPER::catdir($spath, $sdir) |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
19
|
|
|
|
|
217
|
$rslt = vmspath( unixify($spath) . '/' . unixify($sdir)); |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# Special case for VMS absolute directory specs: these will have |
153
|
|
|
|
|
|
|
# had device prepended during trip through Unix syntax in |
154
|
|
|
|
|
|
|
# eliminate_macros(), since Unix syntax has no way to express |
155
|
|
|
|
|
|
|
# "absolute from the top of this device's directory tree". |
156
|
0
|
0
|
|
|
|
0
|
if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } |
|
0
|
|
|
|
|
0
|
|
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
} else { |
159
|
|
|
|
|
|
|
# Single directory. Return an empty string on null input; otherwise |
160
|
|
|
|
|
|
|
# just return a canonical path. |
161
|
|
|
|
|
|
|
|
162
|
3
|
100
|
66
|
|
|
16
|
if (not defined $dir or not length $dir) { |
163
|
1
|
|
|
|
|
3
|
$rslt = ''; |
164
|
|
|
|
|
|
|
} else { |
165
|
2
|
50
|
|
|
|
29
|
$rslt = $unix_rpt ? $dir : vmspath($dir); |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
} |
168
|
1
|
|
|
|
|
4
|
return $self->canonpath($rslt); |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=item catfile (override) |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
Concatenates a list of directory specifications with a filename specification |
174
|
|
|
|
|
|
|
to build a path. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=cut |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
sub catfile { |
179
|
13
|
|
|
13
|
1
|
6703
|
my $self = shift; |
180
|
13
|
|
|
|
|
25
|
my $tfile = pop(); |
181
|
13
|
|
|
|
|
34
|
my $file = $self->canonpath($tfile); |
182
|
13
|
50
|
|
|
|
32
|
my @files = grep {defined() && length()} @_; |
|
21
|
|
|
|
|
72
|
|
183
|
|
|
|
|
|
|
|
184
|
13
|
|
|
|
|
29
|
my $unix_rpt = $self->_unix_rpt; |
185
|
|
|
|
|
|
|
|
186
|
13
|
|
|
|
|
18
|
my $rslt; |
187
|
13
|
100
|
|
|
|
28
|
if (@files) { |
188
|
11
|
100
|
|
|
|
33
|
my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); |
189
|
1
|
|
|
|
|
3
|
my $spath = $path; |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# Something building a VMS path in pieces may try to pass a |
192
|
|
|
|
|
|
|
# directory name in filename format, so normalize it. |
193
|
1
|
|
|
|
|
4
|
$spath =~ s/\.dir\Z(?!\n)//i; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# If the spath ends with a directory delimiter and the file is bare, |
196
|
|
|
|
|
|
|
# then just concatenate them. |
197
|
1
|
50
|
33
|
|
|
7
|
if ($spath =~ /^(?]+\)\Z(?!\n)/s && basename($file) eq $file) { |
198
|
0
|
|
|
|
|
0
|
$rslt = "$spath$file"; |
199
|
|
|
|
|
|
|
} else { |
200
|
1
|
|
|
|
|
13
|
$rslt = unixify($spath); |
201
|
0
|
0
|
0
|
|
|
0
|
$rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); |
202
|
0
|
0
|
|
|
|
0
|
$rslt = vmsify($rslt) unless $unix_rpt; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
else { |
206
|
|
|
|
|
|
|
# Only passed a single file? |
207
|
2
|
50
|
33
|
|
|
12
|
my $xfile = (defined($file) && length($file)) ? $file : ''; |
208
|
|
|
|
|
|
|
|
209
|
2
|
50
|
|
|
|
25
|
$rslt = $unix_rpt ? $xfile : vmsify($xfile); |
210
|
|
|
|
|
|
|
} |
211
|
0
|
0
|
|
|
|
0
|
return $self->canonpath($rslt) unless $unix_rpt; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# In Unix report mode, do not strip off redundant path information. |
214
|
0
|
|
|
|
|
0
|
return $rslt; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=item curdir (override) |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
Returns a string representation of the current directory: '[]' or '.' |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=cut |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub curdir { |
225
|
0
|
|
|
0
|
1
|
0
|
my $self = shift @_; |
226
|
0
|
0
|
|
|
|
0
|
return '.' if ($self->_unix_rpt); |
227
|
0
|
|
|
|
|
0
|
return '[]'; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=item devnull (override) |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
Returns a string representation of the null device: '_NLA0:' or '/dev/null' |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=cut |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub devnull { |
237
|
0
|
|
|
0
|
1
|
0
|
my $self = shift @_; |
238
|
0
|
0
|
|
|
|
0
|
return '/dev/null' if ($self->_unix_rpt); |
239
|
0
|
|
|
|
|
0
|
return "_NLA0:"; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
=item rootdir (override) |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
Returns a string representation of the root directory: 'SYS$DISK:[000000]' |
245
|
|
|
|
|
|
|
or '/' |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
=cut |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
sub rootdir { |
250
|
0
|
|
|
0
|
1
|
0
|
my $self = shift @_; |
251
|
0
|
0
|
|
|
|
0
|
if ($self->_unix_rpt) { |
252
|
|
|
|
|
|
|
# Root may exist, try it first. |
253
|
0
|
|
|
|
|
0
|
my $try = '/'; |
254
|
0
|
|
|
|
|
0
|
my ($dev1, $ino1) = stat('/'); |
255
|
0
|
|
|
|
|
0
|
my ($dev2, $ino2) = stat('.'); |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# Perl falls back to '.' if it can not determine '/' |
258
|
0
|
0
|
0
|
|
|
0
|
if (($dev1 != $dev2) || ($ino1 != $ino2)) { |
259
|
0
|
|
|
|
|
0
|
return $try; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
# Fall back to UNIX format sys$disk. |
262
|
0
|
|
|
|
|
0
|
return '/sys$disk/'; |
263
|
|
|
|
|
|
|
} |
264
|
0
|
|
|
|
|
0
|
return 'SYS$DISK:[000000]'; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=item tmpdir (override) |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
Returns a string representation of the first writable directory |
270
|
|
|
|
|
|
|
from the following list or '' if none are writable: |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
/tmp if C is enabled. |
273
|
|
|
|
|
|
|
sys$scratch: |
274
|
|
|
|
|
|
|
$ENV{TMPDIR} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
If running under taint mode, and if $ENV{TMPDIR} |
277
|
|
|
|
|
|
|
is tainted, it is not used. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=cut |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub tmpdir { |
282
|
0
|
|
|
0
|
1
|
0
|
my $self = shift @_; |
283
|
0
|
|
|
|
|
0
|
my $tmpdir = $self->_cached_tmpdir('TMPDIR'); |
284
|
0
|
0
|
|
|
|
0
|
return $tmpdir if defined $tmpdir; |
285
|
0
|
0
|
|
|
|
0
|
if ($self->_unix_rpt) { |
286
|
0
|
|
|
|
|
0
|
$tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
else { |
289
|
0
|
|
|
|
|
0
|
$tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); |
290
|
|
|
|
|
|
|
} |
291
|
0
|
|
|
|
|
0
|
$self->_cache_tmpdir($tmpdir, 'TMPDIR'); |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=item updir (override) |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Returns a string representation of the parent directory: '[-]' or '..' |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=cut |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
sub updir { |
301
|
0
|
|
|
0
|
1
|
0
|
my $self = shift @_; |
302
|
0
|
0
|
|
|
|
0
|
return '..' if ($self->_unix_rpt); |
303
|
0
|
|
|
|
|
0
|
return '[-]'; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=item case_tolerant (override) |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
VMS file specification syntax is case-tolerant. |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=cut |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub case_tolerant { |
313
|
1
|
|
|
1
|
1
|
595
|
return 1; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
=item path (override) |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
Translate logical name DCL$PATH as a searchlist, rather than trying |
319
|
|
|
|
|
|
|
to C string value of C<$ENV{'PATH'}>. |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=cut |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
sub path { |
324
|
0
|
|
|
0
|
1
|
0
|
my (@dirs,$dir,$i); |
325
|
0
|
|
|
|
|
0
|
while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } |
|
0
|
|
|
|
|
0
|
|
326
|
0
|
|
|
|
|
0
|
return @dirs; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
=item file_name_is_absolute (override) |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
Checks for VMS directory spec as well as Unix separators. |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
=cut |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
sub file_name_is_absolute { |
336
|
46
|
|
|
46
|
1
|
1944
|
my ($self,$file) = @_; |
337
|
|
|
|
|
|
|
# If it's a logical name, expand it. |
338
|
46
|
|
33
|
|
|
140
|
$file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; |
339
|
46
|
|
100
|
|
|
270
|
return scalar($file =~ m!^/!s || |
340
|
|
|
|
|
|
|
$file =~ m![<\[][^.\-\]>]! || |
341
|
|
|
|
|
|
|
$file =~ /^[A-Za-z0-9_\$\-\~]+(?
|
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=item splitpath (override) |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
($volume,$directories,$file) = File::Spec->splitpath( $path ); |
347
|
|
|
|
|
|
|
($volume,$directories,$file) = File::Spec->splitpath( $path, |
348
|
|
|
|
|
|
|
$no_file ); |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
Passing a true value for C<$no_file> indicates that the path being |
351
|
|
|
|
|
|
|
split only contains directory components, even on systems where you |
352
|
|
|
|
|
|
|
can usually (when not supporting a foreign syntax) tell the difference |
353
|
|
|
|
|
|
|
between directories and files at a glance. |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
=cut |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
sub splitpath { |
358
|
81
|
|
|
81
|
1
|
22396
|
my($self,$path, $nofile) = @_; |
359
|
81
|
|
|
|
|
169
|
my($dev,$dir,$file) = ('','',''); |
360
|
81
|
|
|
|
|
772
|
my $vmsify_path = vmsify($path); |
361
|
|
|
|
|
|
|
|
362
|
0
|
0
|
|
|
|
0
|
if ( $nofile ) { |
363
|
|
|
|
|
|
|
#vmsify('d1/d2/d3') returns '[.d1.d2]d3' |
364
|
|
|
|
|
|
|
#vmsify('/d1/d2/d3') returns 'd1:[d2]d3' |
365
|
0
|
0
|
|
|
|
0
|
if( $vmsify_path =~ /(.*)\](.+)/ ){ |
366
|
0
|
|
|
|
|
0
|
$vmsify_path = $1.'.'.$2.']'; |
367
|
|
|
|
|
|
|
} |
368
|
0
|
|
|
|
|
0
|
$vmsify_path =~ /(.+:)?(.*)/s; |
369
|
0
|
0
|
|
|
|
0
|
$dir = defined $2 ? $2 : ''; # dir can be '0' |
370
|
0
|
|
0
|
|
|
0
|
return ($1 || '',$dir,$file); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
else { |
373
|
0
|
|
|
|
|
0
|
$vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; |
374
|
0
|
|
0
|
|
|
0
|
return ($1 || '',$2 || '',$3); |
|
|
|
0
|
|
|
|
|
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
=item splitdir (override) |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
Split a directory specification into the components. |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
=cut |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub splitdir { |
385
|
15
|
|
|
15
|
1
|
7382
|
my($self,$dirspec) = @_; |
386
|
15
|
|
|
|
|
29
|
my @dirs = (); |
387
|
15
|
100
|
66
|
|
|
79
|
return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); |
388
|
|
|
|
|
|
|
|
389
|
14
|
|
|
|
|
29
|
$dirspec =~ s/(? ==> [ and ] |
390
|
14
|
|
|
|
|
21
|
$dirspec =~ s/(?/]/; |
391
|
14
|
|
|
|
|
25
|
$dirspec =~ s/(? .][ |
392
|
14
|
|
|
|
|
24
|
$dirspec =~ s/(? [ |
393
|
14
|
|
|
|
|
24
|
$dirspec =~ s/(? [ |
394
|
14
|
|
|
|
|
21
|
$dirspec =~ s/(? ] |
395
|
14
|
|
|
|
|
22
|
$dirspec =~ s/(? foo.bar |
396
|
14
|
|
|
|
|
54
|
while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} |
397
|
|
|
|
|
|
|
# That loop does the following |
398
|
|
|
|
|
|
|
# with any amount of dashes: |
399
|
|
|
|
|
|
|
# .--. ==> .-.-. |
400
|
|
|
|
|
|
|
# [--. ==> [-.-. |
401
|
|
|
|
|
|
|
# .--] ==> .-.-] |
402
|
|
|
|
|
|
|
# [--] ==> [-.-] |
403
|
14
|
100
|
|
|
|
49
|
$dirspec = "[$dirspec]" unless $dirspec =~ /(?
|
404
|
14
|
|
|
|
|
41
|
$dirspec =~ s/^(\[|<)\./$1/; |
405
|
14
|
|
|
|
|
142
|
@dirs = split /(?
|
406
|
0
|
|
|
|
|
0
|
$dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; |
|
0
|
|
|
|
|
0
|
|
407
|
0
|
|
|
|
|
0
|
@dirs; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=item catpath (override) |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
Construct a complete filespec. |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
=cut |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub catpath { |
418
|
13
|
|
|
13
|
1
|
6044
|
my($self,$dev,$dir,$file) = @_; |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
# We look for a volume in $dev, then in $dir, but not both |
421
|
13
|
|
|
|
|
46
|
my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); |
422
|
0
|
0
|
|
|
|
0
|
$dev = $dir_volume unless length $dev; |
423
|
0
|
0
|
|
|
|
0
|
$dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; |
424
|
|
|
|
|
|
|
|
425
|
0
|
0
|
|
|
|
0
|
if ($dev =~ m|^(?
|
|
0
|
|
|
|
|
0
|
|
426
|
0
|
0
|
0
|
|
|
0
|
else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } |
427
|
0
|
0
|
0
|
|
|
0
|
if (length($dev) or length($dir)) { |
428
|
0
|
0
|
|
|
|
0
|
$dir = "[$dir]" unless $dir =~ /(?
|
429
|
0
|
|
|
|
|
0
|
$dir = vmspath($dir); |
430
|
|
|
|
|
|
|
} |
431
|
0
|
0
|
0
|
|
|
0
|
$dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>'); |
|
|
|
0
|
|
|
|
|
432
|
0
|
|
|
|
|
0
|
"$dev$dir$file"; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
=item abs2rel (override) |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
Attempt to convert an absolute file specification to a relative specification. |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
=cut |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
sub abs2rel { |
442
|
18
|
|
|
18
|
1
|
8567
|
my $self = shift; |
443
|
18
|
|
|
|
|
40
|
my($path,$base) = @_; |
444
|
|
|
|
|
|
|
|
445
|
18
|
50
|
33
|
|
|
84
|
$base = Cwd::getcwd() unless defined $base and length $base; |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# If there is no device or directory syntax on $base, make sure it |
448
|
|
|
|
|
|
|
# is treated as a directory. |
449
|
18
|
100
|
|
|
|
78
|
$base = vmspath($base) unless $base =~ m{(?
|
450
|
|
|
|
|
|
|
|
451
|
16
|
|
|
|
|
36
|
for ($path, $base) { $_ = $self->rel2abs($_) } |
|
32
|
|
|
|
|
65
|
|
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# Are we even starting $path on the same (node::)device as $base? Note that |
454
|
|
|
|
|
|
|
# logical paths or nodename differences may be on the "same device" |
455
|
|
|
|
|
|
|
# but the comparison that ignores device differences so as to concatenate |
456
|
|
|
|
|
|
|
# [---] up directory specs is not even a good idea in cases where there is |
457
|
|
|
|
|
|
|
# a logical path difference between $path and $base nodename and/or device. |
458
|
|
|
|
|
|
|
# Hence we fall back to returning the absolute $path spec |
459
|
|
|
|
|
|
|
# if there is a case blind device (or node) difference of any sort |
460
|
|
|
|
|
|
|
# and we do not even try to call $parse() or consult %ENV for $trnlnm() |
461
|
|
|
|
|
|
|
# (this module needs to run on non VMS platforms after all). |
462
|
|
|
|
|
|
|
|
463
|
16
|
|
|
|
|
38
|
my ($path_volume, $path_directories, $path_file) = $self->splitpath($path); |
464
|
0
|
|
|
|
|
0
|
my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); |
465
|
0
|
0
|
|
|
|
0
|
return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume); |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# Now, remove all leading components that are the same |
468
|
0
|
|
|
|
|
0
|
my @pathchunks = $self->splitdir( $path_directories ); |
469
|
0
|
|
|
|
|
0
|
my $pathchunks = @pathchunks; |
470
|
0
|
0
|
|
|
|
0
|
unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; |
471
|
0
|
|
|
|
|
0
|
my @basechunks = $self->splitdir( $base_directories ); |
472
|
0
|
|
|
|
|
0
|
my $basechunks = @basechunks; |
473
|
0
|
0
|
|
|
|
0
|
unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; |
474
|
|
|
|
|
|
|
|
475
|
0
|
|
0
|
|
|
0
|
while ( @pathchunks && |
|
|
|
0
|
|
|
|
|
476
|
|
|
|
|
|
|
@basechunks && |
477
|
|
|
|
|
|
|
lc( $pathchunks[0] ) eq lc( $basechunks[0] ) |
478
|
|
|
|
|
|
|
) { |
479
|
0
|
|
|
|
|
0
|
shift @pathchunks ; |
480
|
0
|
|
|
|
|
0
|
shift @basechunks ; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
# @basechunks now contains the directories to climb out of, |
484
|
|
|
|
|
|
|
# @pathchunks now has the directories to descend in to. |
485
|
0
|
0
|
0
|
|
|
0
|
if ((@basechunks > 0) || ($basechunks != $pathchunks)) { |
486
|
0
|
|
|
|
|
0
|
$path_directories = join '.', ('-' x @basechunks, @pathchunks) ; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
else { |
489
|
0
|
|
|
|
|
0
|
$path_directories = join '.', @pathchunks; |
490
|
|
|
|
|
|
|
} |
491
|
0
|
|
|
|
|
0
|
$path_directories = '['.$path_directories.']'; |
492
|
0
|
|
|
|
|
0
|
return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
=item rel2abs (override) |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
Return an absolute file specification from a relative one. |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
=cut |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub rel2abs { |
503
|
38
|
|
|
38
|
1
|
2918
|
my $self = shift ; |
504
|
38
|
|
|
|
|
65
|
my ($path,$base ) = @_; |
505
|
38
|
50
|
|
|
|
69
|
return undef unless defined $path; |
506
|
38
|
50
|
|
|
|
90
|
if ($path =~ m/\//) { |
507
|
0
|
0
|
0
|
|
|
0
|
$path = ( -d $path || $path =~ m/\/\z/ # educated guessing about |
508
|
|
|
|
|
|
|
? vmspath($path) # whether it's a directory |
509
|
|
|
|
|
|
|
: vmsify($path) ); |
510
|
|
|
|
|
|
|
} |
511
|
38
|
50
|
66
|
|
|
89
|
$base = vmspath($base) if defined $base && $base =~ m/\//; |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# Clean up and split up $path |
514
|
38
|
100
|
|
|
|
77
|
if ( ! $self->file_name_is_absolute( $path ) ) { |
515
|
|
|
|
|
|
|
# Figure out the effective $base and clean it up. |
516
|
5
|
50
|
33
|
|
|
25
|
if ( !defined( $base ) || $base eq '' ) { |
|
|
50
|
|
|
|
|
|
517
|
0
|
|
|
|
|
0
|
$base = Cwd::getcwd(); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
elsif ( ! $self->file_name_is_absolute( $base ) ) { |
520
|
0
|
|
|
|
|
0
|
$base = $self->rel2abs( $base ) ; |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
else { |
523
|
5
|
|
|
|
|
12
|
$base = $self->canonpath( $base ) ; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
# Split up paths |
527
|
5
|
|
|
|
|
14
|
my ( $path_directories, $path_file ) = |
528
|
|
|
|
|
|
|
($self->splitpath( $path ))[1,2] ; |
529
|
|
|
|
|
|
|
|
530
|
0
|
|
|
|
|
0
|
my ( $base_volume, $base_directories ) = |
531
|
|
|
|
|
|
|
$self->splitpath( $base ) ; |
532
|
|
|
|
|
|
|
|
533
|
0
|
0
|
0
|
|
|
0
|
$path_directories = '' if $path_directories eq '[]' || |
534
|
|
|
|
|
|
|
$path_directories eq '<>'; |
535
|
0
|
|
|
|
|
0
|
my $sep = '' ; |
536
|
0
|
0
|
0
|
|
|
0
|
$sep = '.' |
537
|
|
|
|
|
|
|
if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && |
538
|
|
|
|
|
|
|
$path_directories =~ m{^[^.\[<]}s |
539
|
|
|
|
|
|
|
) ; |
540
|
0
|
|
|
|
|
0
|
$base_directories = "$base_directories$sep$path_directories"; |
541
|
0
|
|
|
|
|
0
|
$base_directories =~ s{\.?[\]>][\[<]\.?}{.}; |
542
|
|
|
|
|
|
|
|
543
|
0
|
|
|
|
|
0
|
$path = $self->catpath( $base_volume, $base_directories, $path_file ); |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
33
|
|
|
|
|
83
|
return $self->canonpath( $path ) ; |
547
|
|
|
|
|
|
|
} |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
=back |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=head1 COPYRIGHT |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
Copyright (c) 2004-14 by the Perl 5 Porters. All rights reserved. |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify |
557
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
=head1 SEE ALSO |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
See L and L. This package overrides the |
562
|
|
|
|
|
|
|
implementation of these methods, not the semantics. |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
An explanation of VMS file specs can be found at |
565
|
|
|
|
|
|
|
L. |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=cut |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
1; |