This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix incompatibility with bison generated parser (from
[perl5.git] / lib / File / Spec / VMS.pm
CommitLineData
270d1e39
GS
1package File::Spec::VMS;
2
cbc7acb0
JD
3use strict;
4use vars qw(@ISA);
5require File::Spec::Unix;
270d1e39
GS
6@ISA = qw(File::Spec::Unix);
7
cbc7acb0
JD
8use File::Basename;
9use VMS::Filespec;
270d1e39
GS
10
11=head1 NAME
12
13File::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
21See File::Spec::Unix for a documentation of the methods provided
22there. This package overrides the implementation of these methods, not
23the semantics.
24
a45bd81d
GS
25=over
26
377875b9
CB
27=item eliminate_macros
28
29Expands MM[KS]/Make macros in a text string, using the contents of
30identically named elements of C<%$self>, and returns the result
31as a file specification in Unix syntax.
32
1f47e8e2
CB
33=cut
34
35sub 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
68Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
69in any directory specification, in order to avoid juxtaposing two
70VMS-syntax directories when MM[SK] is run. Also expands expressions which
71are all macro, so that we can tell how long the expansion is, and avoid
72overrunning DCL's command buffer when MM[KS] is running.
73
74If optional second argument has a TRUE value, then the return string is
75a VMS-syntax directory specification, if it is FALSE, the return string
76is a VMS-syntax file specification, and if it is not specified, fixpath()
77checks to see whether it matches the name of a directory in the current
78default directory, and returns a directory or file specification accordingly.
79
80=cut
81
1f47e8e2
CB
82sub 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
124Concatenates a list of file specifications, and returns the result as a
125VMS-syntax directory specification.
126
127=cut
128
129sub 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
150Concatenates a list of file specifications, and returns the result as a
151VMS-syntax directory specification.
152
153=cut
154
155sub 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 178Returns a string representation of the current directory: '[]'
270d1e39
GS
179
180=cut
181
182sub curdir {
183 return '[]';
184}
185
99804bbb
GS
186=item devnull (override)
187
cbc7acb0 188Returns a string representation of the null device: '_NLA0:'
99804bbb
GS
189
190=cut
191
192sub devnull {
cbc7acb0 193 return "_NLA0:";
99804bbb
GS
194}
195
270d1e39
GS
196=item rootdir (override)
197
cbc7acb0 198Returns a string representation of the root directory: 'SYS$DISK:[000000]'
270d1e39
GS
199
200=cut
201
202sub rootdir {
cbc7acb0
JD
203 return 'SYS$DISK:[000000]';
204}
205
206=item tmpdir (override)
207
208Returns a string representation of the first writable directory
209from the following list or '' if none are writable:
210
211 /sys$scratch
212 $ENV{TMPDIR}
213
214=cut
215
216my $tmpdir;
217sub 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 230Returns a string representation of the parent directory: '[-]'
270d1e39
GS
231
232=cut
233
234sub updir {
235 return '[-]';
236}
237
238=item path (override)
239
240Translate logical name DCL$PATH as a searchlist, rather than trying
241to C<split> string value of C<$ENV{'PATH'}>.
242
243=cut
244
245sub 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
253Checks for VMS directory spec as well as Unix separators.
254
255=cut
256
257sub 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
270L<File::Spec>
271
272=cut
273
2741;