This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
byteperl is now part of the ByteLoader ext
[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
1f47e8e2
CB
25=cut
26
27sub 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
58sub 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
99Concatenates a list of file specifications, and returns the result as a
100VMS-syntax directory specification.
101
102=cut
103
104sub 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
125Concatenates a list of file specifications, and returns the result as a
126VMS-syntax directory specification.
127
128=cut
129
130sub 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 153Returns a string representation of the current directory: '[]'
270d1e39
GS
154
155=cut
156
157sub curdir {
158 return '[]';
159}
160
99804bbb
GS
161=item devnull (override)
162
cbc7acb0 163Returns a string representation of the null device: '_NLA0:'
99804bbb
GS
164
165=cut
166
167sub devnull {
cbc7acb0 168 return "_NLA0:";
99804bbb
GS
169}
170
270d1e39
GS
171=item rootdir (override)
172
cbc7acb0 173Returns a string representation of the root directory: 'SYS$DISK:[000000]'
270d1e39
GS
174
175=cut
176
177sub rootdir {
cbc7acb0
JD
178 return 'SYS$DISK:[000000]';
179}
180
181=item tmpdir (override)
182
183Returns a string representation of the first writable directory
184from the following list or '' if none are writable:
185
186 /sys$scratch
187 $ENV{TMPDIR}
188
189=cut
190
191my $tmpdir;
192sub 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 205Returns a string representation of the parent directory: '[-]'
270d1e39
GS
206
207=cut
208
209sub updir {
210 return '[-]';
211}
212
213=item path (override)
214
215Translate logical name DCL$PATH as a searchlist, rather than trying
216to C<split> string value of C<$ENV{'PATH'}>.
217
218=cut
219
220sub 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
228Checks for VMS directory spec as well as Unix separators.
229
230=cut
231
232sub 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
245L<File::Spec>
246
247=cut
248
2491;