Commit | Line | Data |
---|---|---|
270d1e39 GS |
1 | package File::Spec::VMS; |
2 | ||
cbc7acb0 JD |
3 | use strict; |
4 | use vars qw(@ISA); | |
5 | require File::Spec::Unix; | |
270d1e39 GS |
6 | @ISA = qw(File::Spec::Unix); |
7 | ||
cbc7acb0 JD |
8 | use File::Basename; |
9 | use VMS::Filespec; | |
270d1e39 GS |
10 | |
11 | =head1 NAME | |
12 | ||
13 | File::Spec::VMS - methods for VMS file specs | |
14 | ||
15 | =head1 SYNOPSIS | |
16 | ||
cbc7acb0 | 17 | require File::Spec::VMS; # Done internally by File::Spec if needed |
270d1e39 GS |
18 | |
19 | =head1 DESCRIPTION | |
20 | ||
21 | See File::Spec::Unix for a documentation of the methods provided | |
22 | there. This package overrides the implementation of these methods, not | |
23 | the semantics. | |
24 | ||
25 | =head2 Methods always loaded | |
26 | ||
27 | =over | |
28 | ||
29 | =item catdir | |
30 | ||
31 | Concatenates a list of file specifications, and returns the result as a | |
32 | VMS-syntax directory specification. | |
33 | ||
34 | =cut | |
35 | ||
36 | sub catdir { | |
cbc7acb0 JD |
37 | my ($self,@dirs) = @_; |
38 | my $dir = pop @dirs; | |
270d1e39 | 39 | @dirs = grep($_,@dirs); |
cbc7acb0 | 40 | my $rslt; |
270d1e39 | 41 | if (@dirs) { |
cbc7acb0 JD |
42 | my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); |
43 | my ($spath,$sdir) = ($path,$dir); | |
44 | $spath =~ s/.dir$//; $sdir =~ s/.dir$//; | |
45 | $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; | |
46 | $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); | |
270d1e39 | 47 | } |
cbc7acb0 JD |
48 | else { |
49 | if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } | |
50 | else { $rslt = vmspath($dir); } | |
270d1e39 | 51 | } |
cbc7acb0 | 52 | return $rslt; |
270d1e39 GS |
53 | } |
54 | ||
55 | =item catfile | |
56 | ||
57 | Concatenates a list of file specifications, and returns the result as a | |
58 | VMS-syntax directory specification. | |
59 | ||
60 | =cut | |
61 | ||
62 | sub catfile { | |
cbc7acb0 JD |
63 | my ($self,@files) = @_; |
64 | my $file = pop @files; | |
270d1e39 | 65 | @files = grep($_,@files); |
cbc7acb0 | 66 | my $rslt; |
270d1e39 | 67 | if (@files) { |
cbc7acb0 JD |
68 | my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); |
69 | my $spath = $path; | |
70 | $spath =~ s/.dir$//; | |
71 | if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { | |
72 | $rslt = "$spath$file"; | |
73 | } | |
74 | else { | |
75 | $rslt = $self->eliminate_macros($spath); | |
76 | $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); | |
77 | } | |
270d1e39 GS |
78 | } |
79 | else { $rslt = vmsify($file); } | |
cbc7acb0 | 80 | return $rslt; |
270d1e39 GS |
81 | } |
82 | ||
83 | =item curdir (override) | |
84 | ||
cbc7acb0 | 85 | Returns a string representation of the current directory: '[]' |
270d1e39 GS |
86 | |
87 | =cut | |
88 | ||
89 | sub curdir { | |
90 | return '[]'; | |
91 | } | |
92 | ||
99804bbb GS |
93 | =item devnull (override) |
94 | ||
cbc7acb0 | 95 | Returns a string representation of the null device: '_NLA0:' |
99804bbb GS |
96 | |
97 | =cut | |
98 | ||
99 | sub devnull { | |
cbc7acb0 | 100 | return "_NLA0:"; |
99804bbb GS |
101 | } |
102 | ||
270d1e39 GS |
103 | =item rootdir (override) |
104 | ||
cbc7acb0 | 105 | Returns a string representation of the root directory: 'SYS$DISK:[000000]' |
270d1e39 GS |
106 | |
107 | =cut | |
108 | ||
109 | sub rootdir { | |
cbc7acb0 JD |
110 | return 'SYS$DISK:[000000]'; |
111 | } | |
112 | ||
113 | =item tmpdir (override) | |
114 | ||
115 | Returns a string representation of the first writable directory | |
116 | from the following list or '' if none are writable: | |
117 | ||
118 | /sys$scratch | |
119 | $ENV{TMPDIR} | |
120 | ||
121 | =cut | |
122 | ||
123 | my $tmpdir; | |
124 | sub tmpdir { | |
125 | return $tmpdir if defined $tmpdir; | |
126 | foreach ('/sys$scratch', $ENV{TMPDIR}) { | |
127 | next unless defined && -d && -w _; | |
128 | $tmpdir = $_; | |
129 | last; | |
130 | } | |
131 | $tmpdir = '' unless defined $tmpdir; | |
132 | return $tmpdir; | |
270d1e39 GS |
133 | } |
134 | ||
135 | =item updir (override) | |
136 | ||
cbc7acb0 | 137 | Returns a string representation of the parent directory: '[-]' |
270d1e39 GS |
138 | |
139 | =cut | |
140 | ||
141 | sub updir { | |
142 | return '[-]'; | |
143 | } | |
144 | ||
145 | =item path (override) | |
146 | ||
147 | Translate logical name DCL$PATH as a searchlist, rather than trying | |
148 | to C<split> string value of C<$ENV{'PATH'}>. | |
149 | ||
150 | =cut | |
151 | ||
152 | sub path { | |
cbc7acb0 | 153 | my (@dirs,$dir,$i); |
270d1e39 | 154 | while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } |
cbc7acb0 | 155 | return @dirs; |
270d1e39 GS |
156 | } |
157 | ||
158 | =item file_name_is_absolute (override) | |
159 | ||
160 | Checks for VMS directory spec as well as Unix separators. | |
161 | ||
162 | =cut | |
163 | ||
164 | sub file_name_is_absolute { | |
cbc7acb0 | 165 | my ($self,$file) = @_; |
270d1e39 | 166 | # If it's a logical name, expand it. |
cbc7acb0 JD |
167 | $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file}; |
168 | return scalar($file =~ m!^/! || | |
169 | $file =~ m![<\[][^.\-\]>]! || | |
170 | $file =~ /:[^<\[]/); | |
270d1e39 GS |
171 | } |
172 | ||
cbc7acb0 | 173 | =back |
270d1e39 | 174 | |
cbc7acb0 JD |
175 | =head1 SEE ALSO |
176 | ||
177 | L<File::Spec> | |
178 | ||
179 | =cut | |
180 | ||
181 | 1; |