Commit | Line | Data |
270d1e39 |
1 | package File::Spec::VMS; |
2 | |
cbc7acb0 |
3 | use strict; |
4 | use vars qw(@ISA); |
5 | require File::Spec::Unix; |
270d1e39 |
6 | @ISA = qw(File::Spec::Unix); |
7 | |
cbc7acb0 |
8 | use File::Basename; |
9 | use VMS::Filespec; |
270d1e39 |
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 |
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 |
37 | my ($self,@dirs) = @_; |
38 | my $dir = pop @dirs; |
270d1e39 |
39 | @dirs = grep($_,@dirs); |
cbc7acb0 |
40 | my $rslt; |
270d1e39 |
41 | if (@dirs) { |
cbc7acb0 |
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 |
48 | else { |
49 | if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } |
50 | else { $rslt = vmspath($dir); } |
270d1e39 |
51 | } |
cbc7acb0 |
52 | return $rslt; |
270d1e39 |
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 |
63 | my ($self,@files) = @_; |
64 | my $file = pop @files; |
270d1e39 |
65 | @files = grep($_,@files); |
cbc7acb0 |
66 | my $rslt; |
270d1e39 |
67 | if (@files) { |
cbc7acb0 |
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 |
78 | } |
79 | else { $rslt = vmsify($file); } |
cbc7acb0 |
80 | return $rslt; |
270d1e39 |
81 | } |
82 | |
83 | =item curdir (override) |
84 | |
cbc7acb0 |
85 | Returns a string representation of the current directory: '[]' |
270d1e39 |
86 | |
87 | =cut |
88 | |
89 | sub curdir { |
90 | return '[]'; |
91 | } |
92 | |
99804bbb |
93 | =item devnull (override) |
94 | |
cbc7acb0 |
95 | Returns a string representation of the null device: '_NLA0:' |
99804bbb |
96 | |
97 | =cut |
98 | |
99 | sub devnull { |
cbc7acb0 |
100 | return "_NLA0:"; |
99804bbb |
101 | } |
102 | |
270d1e39 |
103 | =item rootdir (override) |
104 | |
cbc7acb0 |
105 | Returns a string representation of the root directory: 'SYS$DISK:[000000]' |
270d1e39 |
106 | |
107 | =cut |
108 | |
109 | sub rootdir { |
cbc7acb0 |
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 |
133 | } |
134 | |
135 | =item updir (override) |
136 | |
cbc7acb0 |
137 | Returns a string representation of the parent directory: '[-]' |
270d1e39 |
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 |
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 |
167 | $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ && $ENV{$file}; |
168 | return scalar($file =~ m!^/! || |
169 | $file =~ m![<\[][^.\-\]>]! || |
170 | $file =~ /:[^<\[]/); |
270d1e39 |
171 | } |
172 | |
cbc7acb0 |
173 | =back |
270d1e39 |
174 | |
cbc7acb0 |
175 | =head1 SEE ALSO |
176 | |
177 | L<File::Spec> |
178 | |
179 | =cut |
180 | |
181 | 1; |