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