1 | # Perl hooks into the routines in vms.c for interconversion |
---|
2 | # of VMS and Unix file specification syntax. |
---|
3 | # |
---|
4 | # Version: see $VERSION below |
---|
5 | # Author: Charles Bailey bailey@newman.upenn.edu |
---|
6 | # Revised: 08-Mar-1995 |
---|
7 | |
---|
8 | =head1 NAME |
---|
9 | |
---|
10 | VMS::Filespec - convert between VMS and Unix file specification syntax |
---|
11 | |
---|
12 | =head1 SYNOPSIS |
---|
13 | |
---|
14 | use VMS::Filespec; |
---|
15 | $fullspec = rmsexpand('[.VMS]file.specification'[, 'default:[file.spec]']); |
---|
16 | $vmsspec = vmsify('/my/Unix/file/specification'); |
---|
17 | $unixspec = unixify('my:[VMS]file.specification'); |
---|
18 | $path = pathify('my:[VMS.or.Unix.directory]specification.dir'); |
---|
19 | $dirfile = fileify('my:[VMS.or.Unix.directory.specification]'); |
---|
20 | $vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir'); |
---|
21 | $unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir'); |
---|
22 | candelete('my:[VMS.or.Unix]file.specification'); |
---|
23 | |
---|
24 | =head1 DESCRIPTION |
---|
25 | |
---|
26 | This package provides routines to simplify conversion between VMS and |
---|
27 | Unix syntax when processing file specifications. This is useful when |
---|
28 | porting scripts designed to run under either OS, and also allows you |
---|
29 | to take advantage of conveniences provided by either syntax (I<e.g.> |
---|
30 | ability to easily concatenate Unix-style specifications). In |
---|
31 | addition, it provides an additional file test routine, C<candelete>, |
---|
32 | which determines whether you have delete access to a file. |
---|
33 | |
---|
34 | If you're running under VMS, the routines in this package are special, |
---|
35 | in that they're automatically made available to any Perl script, |
---|
36 | whether you're running F<miniperl> or the full F<perl>. The C<use |
---|
37 | VMS::Filespec> or C<require VMS::Filespec; import VMS::Filespec ...> |
---|
38 | statement can be used to import the function names into the current |
---|
39 | package, but they're always available if you use the fully qualified |
---|
40 | name, whether or not you've mentioned the F<.pm> file in your script. |
---|
41 | If you're running under another OS and have installed this package, it |
---|
42 | behaves like a normal Perl extension (in fact, you're using Perl |
---|
43 | substitutes to emulate the necessary VMS system calls). |
---|
44 | |
---|
45 | Each of these routines accepts a file specification in either VMS or |
---|
46 | Unix syntax, and returns the converted file specification, or C<undef> |
---|
47 | if an error occurs. The conversions are, for the most part, simply |
---|
48 | string manipulations; the routines do not check the details of syntax |
---|
49 | (e.g. that only legal characters are used). There is one exception: |
---|
50 | when running under VMS, conversions from VMS syntax use the $PARSE |
---|
51 | service to expand specifications, so illegal syntax, or a relative |
---|
52 | directory specification which extends above the tope of the current |
---|
53 | directory path (e.g [---.foo] when in dev:[dir.sub]) will cause |
---|
54 | errors. In general, any legal file specification will be converted |
---|
55 | properly, but garbage input tends to produce garbage output. |
---|
56 | |
---|
57 | Each of these routines is prototyped as taking a single scalar |
---|
58 | argument, so you can use them as unary operators in complex |
---|
59 | expressions (as long as you don't use the C<&> form of |
---|
60 | subroutine call, which bypasses prototype checking). |
---|
61 | |
---|
62 | |
---|
63 | The routines provided are: |
---|
64 | |
---|
65 | =head2 rmsexpand |
---|
66 | |
---|
67 | Uses the RMS $PARSE and $SEARCH services to expand the input |
---|
68 | specification to its fully qualified form, except that a null type |
---|
69 | or version is not added unless it was present in either the original |
---|
70 | file specification or the default specification passed to C<rmsexpand>. |
---|
71 | (If the file does not exist, the input specification is expanded as much |
---|
72 | as possible.) If an error occurs, returns C<undef> and sets C<$!> |
---|
73 | and C<$^E>. |
---|
74 | |
---|
75 | =head2 vmsify |
---|
76 | |
---|
77 | Converts a file specification to VMS syntax. |
---|
78 | |
---|
79 | =head2 unixify |
---|
80 | |
---|
81 | Converts a file specification to Unix syntax. |
---|
82 | |
---|
83 | =head2 pathify |
---|
84 | |
---|
85 | Converts a directory specification to a path - that is, a string you |
---|
86 | can prepend to a file name to form a valid file specification. If the |
---|
87 | input file specification uses VMS syntax, the returned path does, too; |
---|
88 | likewise for Unix syntax (Unix paths are guaranteed to end with '/'). |
---|
89 | Note that this routine will insist that the input be a legal directory |
---|
90 | file specification; the file type and version, if specified, must be |
---|
91 | F<.DIR;1>. For compatibility with Unix usage, the type and version |
---|
92 | may also be omitted. |
---|
93 | |
---|
94 | =head2 fileify |
---|
95 | |
---|
96 | Converts a directory specification to the file specification of the |
---|
97 | directory file - that is, a string you can pass to functions like |
---|
98 | C<stat> or C<rmdir> to manipulate the directory file. If the |
---|
99 | input directory specification uses VMS syntax, the returned file |
---|
100 | specification does, too; likewise for Unix syntax. As with |
---|
101 | C<pathify>, the input file specification must have a type and |
---|
102 | version of F<.DIR;1>, or the type and version must be omitted. |
---|
103 | |
---|
104 | =head2 vmspath |
---|
105 | |
---|
106 | Acts like C<pathify>, but insures the returned path uses VMS syntax. |
---|
107 | |
---|
108 | =head2 unixpath |
---|
109 | |
---|
110 | Acts like C<pathify>, but insures the returned path uses Unix syntax. |
---|
111 | |
---|
112 | =head2 candelete |
---|
113 | |
---|
114 | Determines whether you have delete access to a file. If you do, C<candelete> |
---|
115 | returns true. If you don't, or its argument isn't a legal file specification, |
---|
116 | C<candelete> returns FALSE. Unlike other file tests, the argument to |
---|
117 | C<candelete> must be a file name (not a FileHandle), and, since it's an XSUB, |
---|
118 | it's a list operator, so you need to be careful about parentheses. Both of |
---|
119 | these restrictions may be removed in the future if the functionality of |
---|
120 | C<candelete> becomes part of the Perl core. |
---|
121 | |
---|
122 | =head1 REVISION |
---|
123 | |
---|
124 | This document was last revised 22-Feb-1996, for Perl 5.002. |
---|
125 | |
---|
126 | =cut |
---|
127 | |
---|
128 | package VMS::Filespec; |
---|
129 | require 5.002; |
---|
130 | |
---|
131 | our $VERSION = '1.1'; |
---|
132 | |
---|
133 | # If you want to use this package on a non-VMS system, |
---|
134 | # uncomment the following line. |
---|
135 | # use AutoLoader; |
---|
136 | require Exporter; |
---|
137 | |
---|
138 | @ISA = qw( Exporter ); |
---|
139 | @EXPORT = qw( &vmsify &unixify &pathify &fileify |
---|
140 | &vmspath &unixpath &candelete &rmsexpand ); |
---|
141 | |
---|
142 | 1; |
---|
143 | |
---|
144 | |
---|
145 | __END__ |
---|
146 | |
---|
147 | |
---|
148 | # The autosplit routines here are provided for use by non-VMS systems |
---|
149 | # They are not guaranteed to function identically to the XSUBs of the |
---|
150 | # same name, since they do not have access to the RMS system routine |
---|
151 | # sys$parse() (in particular, no real provision is made for handling |
---|
152 | # of complex DECnet node specifications). However, these routines |
---|
153 | # should be adequate for most purposes. |
---|
154 | |
---|
155 | # A sort-of sys$parse() replacement |
---|
156 | sub rmsexpand ($;$) { |
---|
157 | my($fspec,$defaults) = @_; |
---|
158 | if (!$fspec) { return undef } |
---|
159 | my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver); |
---|
160 | |
---|
161 | $fspec =~ s/:$//; |
---|
162 | $defaults = [] unless $defaults; |
---|
163 | $defaults = [ $defaults ] unless ref($defaults) && ref($defaults) eq 'ARRAY'; |
---|
164 | |
---|
165 | while ($fspec !~ m#[:>\]]# && $ENV{$fspec}) { $fspec = $ENV{$fspec} } |
---|
166 | |
---|
167 | if ($fspec =~ /:/) { |
---|
168 | my($dev,$devtrn,$base); |
---|
169 | ($dev,$base) = split(/:/,$fspec); |
---|
170 | $devtrn = $dev; |
---|
171 | while ($devtrn = $ENV{$devtrn}) { |
---|
172 | if ($devtrn =~ /(.)([:>\]])$/) { |
---|
173 | $dev .= ':', last if $1 eq '.'; |
---|
174 | $dev = $devtrn, last; |
---|
175 | } |
---|
176 | } |
---|
177 | $fspec = $dev . $base; |
---|
178 | } |
---|
179 | |
---|
180 | ($node,$dev,$dir,$name,$type,$ver) = $fspec =~ |
---|
181 | /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/; |
---|
182 | foreach ((@$defaults,$ENV{'DEFAULT'})) { |
---|
183 | last if $node && $ver && $type && $dev && $dir && $name; |
---|
184 | ($dnode,$ddev,$ddir,$dname,$dtype,$dver) = |
---|
185 | /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/; |
---|
186 | $node = $dnode if $dnode && !$node; |
---|
187 | $dev = $ddev if $ddev && !$dev; |
---|
188 | $dir = $ddir if $ddir && !$dir; |
---|
189 | $name = $dname if $dname && !$name; |
---|
190 | $type = $dtype if $dtype && !$type; |
---|
191 | $ver = $dver if $dver && !$ver; |
---|
192 | } |
---|
193 | # do this the long way to keep -w happy |
---|
194 | $fspec = ''; |
---|
195 | $fspec .= $node if $node; |
---|
196 | $fspec .= $dev if $dev; |
---|
197 | $fspec .= $dir if $dir; |
---|
198 | $fspec .= $name if $name; |
---|
199 | $fspec .= $type if $type; |
---|
200 | $fspec .= $ver if $ver; |
---|
201 | $fspec; |
---|
202 | } |
---|
203 | |
---|
204 | sub vmsify ($) { |
---|
205 | my($fspec) = @_; |
---|
206 | my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs); |
---|
207 | |
---|
208 | if ($fspec =~ m#^\.(\.?)/?$#) { return $1 ? '[-]' : '[]'; } |
---|
209 | return $fspec if $fspec !~ m#/#; |
---|
210 | ($hasdev,$dir,$base) = $fspec =~ m#(/?)(.*)/(.*)#; |
---|
211 | @dirs = split(m#/#,$dir); |
---|
212 | if ($base eq '.') { $base = ''; } |
---|
213 | elsif ($base eq '..') { |
---|
214 | push @dirs,$base; |
---|
215 | $base = ''; |
---|
216 | } |
---|
217 | foreach (@dirs) { |
---|
218 | next unless $_; # protect against // in input |
---|
219 | next if $_ eq '.'; |
---|
220 | if ($_ eq '..') { |
---|
221 | if (@realdirs && $realdirs[$#realdirs] ne '-') { pop @realdirs } |
---|
222 | else { push @realdirs, '-' } |
---|
223 | } |
---|
224 | else { push @realdirs, $_; } |
---|
225 | } |
---|
226 | if ($hasdev) { |
---|
227 | $dev = shift @realdirs; |
---|
228 | @realdirs = ('000000') unless @realdirs; |
---|
229 | $base = '' unless $base; # keep -w happy |
---|
230 | $dev . ':[' . join('.',@realdirs) . "]$base"; |
---|
231 | } |
---|
232 | else { |
---|
233 | '[' . join('',map($_ eq '-' ? $_ : ".$_",@realdirs)) . "]$base"; |
---|
234 | } |
---|
235 | } |
---|
236 | |
---|
237 | sub unixify ($) { |
---|
238 | my($fspec) = @_; |
---|
239 | |
---|
240 | return $fspec if $fspec !~ m#[:>\]]#; |
---|
241 | return '.' if ($fspec eq '[]' || $fspec eq '<>'); |
---|
242 | if ($fspec =~ m#^[<\[](\.|-+)(.*)# ) { |
---|
243 | $fspec = ($1 eq '.' ? '' : "$1.") . $2; |
---|
244 | my($dir,$base) = split(/[\]>]/,$fspec); |
---|
245 | my(@dirs) = grep($_,split(m#\.#,$dir)); |
---|
246 | if ($dirs[0] =~ /^-/) { |
---|
247 | my($steps) = shift @dirs; |
---|
248 | for (1..length($steps)) { unshift @dirs, '..'; } |
---|
249 | } |
---|
250 | join('/',@dirs) . "/$base"; |
---|
251 | } |
---|
252 | else { |
---|
253 | $fspec = rmsexpand($fspec,'_N_O_T_:[_R_E_A_L_]'); |
---|
254 | $fspec =~ s/.*_N_O_T_:(?:\[_R_E_A_L_\])?//; |
---|
255 | my($dev,$dir,$base) = $fspec =~ m#([^:<\[]*):?[<\[](.*)[>\]](.*)#; |
---|
256 | my(@dirs) = split(m#\.#,$dir); |
---|
257 | if ($dirs[0] && $dirs[0] =~ /^-/) { |
---|
258 | my($steps) = shift @dirs; |
---|
259 | for (1..length($steps)) { unshift @dirs, '..'; } |
---|
260 | } |
---|
261 | "/$dev/" . join('/',@dirs) . "/$base"; |
---|
262 | } |
---|
263 | } |
---|
264 | |
---|
265 | |
---|
266 | sub fileify ($) { |
---|
267 | my($path) = @_; |
---|
268 | |
---|
269 | if (!$path) { return undef } |
---|
270 | if ($path eq '/') { return 'sys$disk:[000000]'; } |
---|
271 | if ($path =~ /(.+)\.([^:>\]]*)$/) { |
---|
272 | $path = $1; |
---|
273 | if ($2 !~ /^dir(?:;1)?$/i) { return undef } |
---|
274 | } |
---|
275 | |
---|
276 | if ($path !~ m#[/>\]]#) { |
---|
277 | $path =~ s/:$//; |
---|
278 | while ($ENV{$path}) { |
---|
279 | ($path = $ENV{$path}) =~ s/:$//; |
---|
280 | last if $path =~ m#[/>\]]#; |
---|
281 | } |
---|
282 | } |
---|
283 | if ($path =~ m#[>\]]#) { |
---|
284 | my($dir,$sep,$base) = $path =~ /(.*)([>\]])(.*)/; |
---|
285 | $sep =~ tr/<[/>]/; |
---|
286 | if ($base) { |
---|
287 | "$dir$sep$base.dir;1"; |
---|
288 | } |
---|
289 | else { |
---|
290 | if ($dir !~ /\./) { $dir =~ s/([<\[])/${1}000000./; } |
---|
291 | $dir =~ s#\.(\w+)$#$sep$1#; |
---|
292 | $dir =~ s/^.$sep//; |
---|
293 | "$dir.dir;1"; |
---|
294 | } |
---|
295 | } |
---|
296 | else { |
---|
297 | $path =~ s#/$##; |
---|
298 | "$path.dir;1"; |
---|
299 | } |
---|
300 | } |
---|
301 | |
---|
302 | sub pathify ($) { |
---|
303 | my($fspec) = @_; |
---|
304 | |
---|
305 | if (!$fspec) { return undef } |
---|
306 | if ($fspec =~ m#[/>\]]$#) { return $fspec; } |
---|
307 | if ($fspec =~ m#(.+)\.([^/>\]]*)$# && $2 && $2 ne '.') { |
---|
308 | $fspec = $1; |
---|
309 | if ($2 !~ /^dir(?:;1)?$/i) { return undef } |
---|
310 | } |
---|
311 | |
---|
312 | if ($fspec !~ m#[/>\]]#) { |
---|
313 | $fspec =~ s/:$//; |
---|
314 | while ($ENV{$fspec}) { |
---|
315 | if ($ENV{$fspec} =~ m#[>\]]$#) { return $ENV{$fspec} } |
---|
316 | else { $fspec = $ENV{$fspec} =~ s/:$// } |
---|
317 | } |
---|
318 | } |
---|
319 | |
---|
320 | if ($fspec !~ m#[>\]]#) { "$fspec/"; } |
---|
321 | else { |
---|
322 | if ($fspec =~ /([^>\]]+)([>\]])(.+)/) { "$1.$3$2"; } |
---|
323 | else { $fspec; } |
---|
324 | } |
---|
325 | } |
---|
326 | |
---|
327 | sub vmspath ($) { |
---|
328 | pathify(vmsify($_[0])); |
---|
329 | } |
---|
330 | |
---|
331 | sub unixpath ($) { |
---|
332 | pathify(unixify($_[0])); |
---|
333 | } |
---|
334 | |
---|
335 | sub candelete ($) { |
---|
336 | my($fspec) = @_; |
---|
337 | my($parent); |
---|
338 | |
---|
339 | return '' unless -w $fspec; |
---|
340 | $fspec =~ s#/$##; |
---|
341 | if ($fspec =~ m#/#) { |
---|
342 | ($parent = $fspec) =~ s#/[^/]+$#; |
---|
343 | return (-w $parent); |
---|
344 | } |
---|
345 | elsif ($parent = fileify($fspec)) { # fileify() here to expand lnms |
---|
346 | $parent =~ s/[>\]][^>\]]+//; |
---|
347 | return (-w fileify($parent)); |
---|
348 | } |
---|
349 | else { return (-w '[-]'); } |
---|
350 | } |
---|