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 | ||
a45bd81d GS |
25 | =over |
26 | ||
377875b9 CB |
27 | =item eliminate_macros |
28 | ||
29 | Expands MM[KS]/Make macros in a text string, using the contents of | |
30 | identically named elements of C<%$self>, and returns the result | |
31 | as a file specification in Unix syntax. | |
32 | ||
1f47e8e2 CB |
33 | =cut |
34 | ||
35 | sub eliminate_macros { | |
36 | my($self,$path) = @_; | |
37 | return '' unless $path; | |
38 | $self = {} unless ref $self; | |
39 | my($npath) = unixify($path); | |
40 | my($complex) = 0; | |
41 | my($head,$macro,$tail); | |
42 | ||
43 | # perform m##g in scalar context so it acts as an iterator | |
44 | while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) { | |
45 | if ($self->{$2}) { | |
46 | ($head,$macro,$tail) = ($1,$2,$3); | |
47 | if (ref $self->{$macro}) { | |
48 | if (ref $self->{$macro} eq 'ARRAY') { | |
49 | $macro = join ' ', @{$self->{$macro}}; | |
50 | } | |
51 | else { | |
52 | print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), | |
53 | "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; | |
54 | $macro = "\cB$macro\cB"; | |
55 | $complex = 1; | |
56 | } | |
57 | } | |
58 | else { ($macro = unixify($self->{$macro})) =~ s#/$##; } | |
59 | $npath = "$head$macro$tail"; | |
60 | } | |
61 | } | |
62 | if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; } | |
63 | $npath; | |
64 | } | |
65 | ||
377875b9 CB |
66 | =item fixpath |
67 | ||
68 | Catchall routine to clean up problem MM[SK]/Make macros. Expands macros | |
69 | in any directory specification, in order to avoid juxtaposing two | |
70 | VMS-syntax directories when MM[SK] is run. Also expands expressions which | |
71 | are all macro, so that we can tell how long the expansion is, and avoid | |
72 | overrunning DCL's command buffer when MM[KS] is running. | |
73 | ||
74 | If optional second argument has a TRUE value, then the return string is | |
75 | a VMS-syntax directory specification, if it is FALSE, the return string | |
76 | is a VMS-syntax file specification, and if it is not specified, fixpath() | |
77 | checks to see whether it matches the name of a directory in the current | |
78 | default directory, and returns a directory or file specification accordingly. | |
79 | ||
80 | =cut | |
81 | ||
1f47e8e2 CB |
82 | sub fixpath { |
83 | my($self,$path,$force_path) = @_; | |
84 | return '' unless $path; | |
85 | $self = bless {} unless ref $self; | |
86 | my($fixedpath,$prefix,$name); | |
87 | ||
88 | if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { | |
89 | if ($force_path or $path =~ /(?:DIR\)|\])$/) { | |
90 | $fixedpath = vmspath($self->eliminate_macros($path)); | |
91 | } | |
92 | else { | |
93 | $fixedpath = vmsify($self->eliminate_macros($path)); | |
94 | } | |
95 | } | |
96 | elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) { | |
97 | my($vmspre) = $self->eliminate_macros("\$($prefix)"); | |
98 | # is it a dir or just a name? | |
99 | $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : ''; | |
100 | $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; | |
101 | $fixedpath = vmspath($fixedpath) if $force_path; | |
102 | } | |
103 | else { | |
104 | $fixedpath = $path; | |
105 | $fixedpath = vmspath($fixedpath) if $force_path; | |
106 | } | |
107 | # No hints, so we try to guess | |
108 | if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { | |
109 | $fixedpath = vmspath($fixedpath) if -d $fixedpath; | |
110 | } | |
111 | # Trim off root dirname if it's had other dirs inserted in front of it. | |
112 | $fixedpath =~ s/\.000000([\]>])/$1/; | |
113 | $fixedpath; | |
114 | } | |
115 | ||
a45bd81d | 116 | =back |
1f47e8e2 | 117 | |
270d1e39 GS |
118 | =head2 Methods always loaded |
119 | ||
120 | =over | |
121 | ||
122 | =item catdir | |
123 | ||
124 | Concatenates a list of file specifications, and returns the result as a | |
125 | VMS-syntax directory specification. | |
126 | ||
127 | =cut | |
128 | ||
129 | sub catdir { | |
cbc7acb0 JD |
130 | my ($self,@dirs) = @_; |
131 | my $dir = pop @dirs; | |
270d1e39 | 132 | @dirs = grep($_,@dirs); |
cbc7acb0 | 133 | my $rslt; |
270d1e39 | 134 | if (@dirs) { |
cbc7acb0 JD |
135 | my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); |
136 | my ($spath,$sdir) = ($path,$dir); | |
137 | $spath =~ s/.dir$//; $sdir =~ s/.dir$//; | |
138 | $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; | |
139 | $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); | |
270d1e39 | 140 | } |
cbc7acb0 JD |
141 | else { |
142 | if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } | |
143 | else { $rslt = vmspath($dir); } | |
270d1e39 | 144 | } |
cbc7acb0 | 145 | return $rslt; |
270d1e39 GS |
146 | } |
147 | ||
148 | =item catfile | |
149 | ||
150 | Concatenates a list of file specifications, and returns the result as a | |
151 | VMS-syntax directory specification. | |
152 | ||
153 | =cut | |
154 | ||
155 | sub catfile { | |
cbc7acb0 JD |
156 | my ($self,@files) = @_; |
157 | my $file = pop @files; | |
270d1e39 | 158 | @files = grep($_,@files); |
cbc7acb0 | 159 | my $rslt; |
270d1e39 | 160 | if (@files) { |
cbc7acb0 JD |
161 | my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); |
162 | my $spath = $path; | |
163 | $spath =~ s/.dir$//; | |
164 | if ($spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { | |
165 | $rslt = "$spath$file"; | |
166 | } | |
167 | else { | |
168 | $rslt = $self->eliminate_macros($spath); | |
169 | $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); | |
170 | } | |
270d1e39 GS |
171 | } |
172 | else { $rslt = vmsify($file); } | |
cbc7acb0 | 173 | return $rslt; |
270d1e39 GS |
174 | } |
175 | ||
176 | =item curdir (override) | |
177 | ||
cbc7acb0 | 178 | Returns a string representation of the current directory: '[]' |
270d1e39 GS |
179 | |
180 | =cut | |
181 | ||
182 | sub curdir { | |
183 | return '[]'; | |
184 | } | |
185 | ||
99804bbb GS |
186 | =item devnull (override) |
187 | ||
cbc7acb0 | 188 | Returns a string representation of the null device: '_NLA0:' |
99804bbb GS |
189 | |
190 | =cut | |
191 | ||
192 | sub devnull { | |
cbc7acb0 | 193 | return "_NLA0:"; |
99804bbb GS |
194 | } |
195 | ||
270d1e39 GS |
196 | =item rootdir (override) |
197 | ||
cbc7acb0 | 198 | Returns a string representation of the root directory: 'SYS$DISK:[000000]' |
270d1e39 GS |
199 | |
200 | =cut | |
201 | ||
202 | sub rootdir { | |
cbc7acb0 JD |
203 | return 'SYS$DISK:[000000]'; |
204 | } | |
205 | ||
206 | =item tmpdir (override) | |
207 | ||
208 | Returns a string representation of the first writable directory | |
209 | from the following list or '' if none are writable: | |
210 | ||
211 | /sys$scratch | |
212 | $ENV{TMPDIR} | |
213 | ||
214 | =cut | |
215 | ||
216 | my $tmpdir; | |
217 | sub tmpdir { | |
218 | return $tmpdir if defined $tmpdir; | |
219 | foreach ('/sys$scratch', $ENV{TMPDIR}) { | |
220 | next unless defined && -d && -w _; | |
221 | $tmpdir = $_; | |
222 | last; | |
223 | } | |
224 | $tmpdir = '' unless defined $tmpdir; | |
225 | return $tmpdir; | |
270d1e39 GS |
226 | } |
227 | ||
228 | =item updir (override) | |
229 | ||
cbc7acb0 | 230 | Returns a string representation of the parent directory: '[-]' |
270d1e39 GS |
231 | |
232 | =cut | |
233 | ||
234 | sub updir { | |
235 | return '[-]'; | |
236 | } | |
237 | ||
238 | =item path (override) | |
239 | ||
240 | Translate logical name DCL$PATH as a searchlist, rather than trying | |
241 | to C<split> string value of C<$ENV{'PATH'}>. | |
242 | ||
243 | =cut | |
244 | ||
245 | sub path { | |
cbc7acb0 | 246 | my (@dirs,$dir,$i); |
270d1e39 | 247 | while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } |
cbc7acb0 | 248 | return @dirs; |
270d1e39 GS |
249 | } |
250 | ||
251 | =item file_name_is_absolute (override) | |
252 | ||
253 | Checks for VMS directory spec as well as Unix separators. | |
254 | ||
255 | =cut | |
256 | ||
257 | sub file_name_is_absolute { | |
cbc7acb0 | 258 | my ($self,$file) = @_; |
270d1e39 | 259 | # If it's a logical name, expand it. |
cbc7acb0 JD |
260 | $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file}; |
261 | return scalar($file =~ m!^/! || | |
262 | $file =~ m![<\[][^.\-\]>]! || | |
263 | $file =~ /:[^<\[]/); | |
270d1e39 GS |
264 | } |
265 | ||
cbc7acb0 | 266 | =back |
270d1e39 | 267 | |
cbc7acb0 JD |
268 | =head1 SEE ALSO |
269 | ||
270 | L<File::Spec> | |
271 | ||
272 | =cut | |
273 | ||
274 | 1; |