Commit | Line | Data |
---|---|---|
270d1e39 GS |
1 | |
2 | package File::Spec::VMS; | |
3 | ||
4 | use Carp qw( &carp ); | |
5 | use Config; | |
6 | require Exporter; | |
7 | use VMS::Filespec; | |
8 | use File::Basename; | |
9 | ||
10 | use File::Spec; | |
11 | use vars qw($Revision); | |
12 | $Revision = '5.3901 (6-Mar-1997)'; | |
13 | ||
14 | @ISA = qw(File::Spec::Unix); | |
15 | ||
16 | Exporter::import('File::Spec', '$Verbose'); | |
17 | ||
18 | =head1 NAME | |
19 | ||
20 | File::Spec::VMS - methods for VMS file specs | |
21 | ||
22 | =head1 SYNOPSIS | |
23 | ||
24 | use File::Spec::VMS; # Done internally by File::Spec if needed | |
25 | ||
26 | =head1 DESCRIPTION | |
27 | ||
28 | See File::Spec::Unix for a documentation of the methods provided | |
29 | there. This package overrides the implementation of these methods, not | |
30 | the semantics. | |
31 | ||
32 | =head2 Methods always loaded | |
33 | ||
34 | =over | |
35 | ||
36 | =item catdir | |
37 | ||
38 | Concatenates a list of file specifications, and returns the result as a | |
39 | VMS-syntax directory specification. | |
40 | ||
41 | =cut | |
42 | ||
43 | sub catdir { | |
44 | my($self,@dirs) = @_; | |
45 | my($dir) = pop @dirs; | |
46 | @dirs = grep($_,@dirs); | |
47 | my($rslt); | |
48 | if (@dirs) { | |
49 | my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); | |
50 | my($spath,$sdir) = ($path,$dir); | |
51 | $spath =~ s/.dir$//; $sdir =~ s/.dir$//; | |
52 | $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; | |
53 | $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); | |
54 | } | |
55 | else { | |
56 | if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } | |
57 | else { $rslt = vmspath($dir); } | |
58 | } | |
59 | print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; | |
60 | $rslt; | |
61 | } | |
62 | ||
63 | =item catfile | |
64 | ||
65 | Concatenates a list of file specifications, and returns the result as a | |
66 | VMS-syntax directory specification. | |
67 | ||
68 | =cut | |
69 | ||
70 | sub catfile { | |
71 | my($self,@files) = @_; | |
72 | my($file) = pop @files; | |
73 | @files = grep($_,@files); | |
74 | my($rslt); | |
75 | if (@files) { | |
76 | my($path) = (@files == 1 ? $files[0] : $self->catdir(@files)); | |
77 | my($spath) = $path; | |
78 | $spath =~ s/.dir$//; | |
79 | if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } | |
80 | else { | |
81 | $rslt = $self->eliminate_macros($spath); | |
82 | $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); | |
83 | } | |
84 | } | |
85 | else { $rslt = vmsify($file); } | |
86 | print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; | |
87 | $rslt; | |
88 | } | |
89 | ||
90 | =item curdir (override) | |
91 | ||
92 | Returns a string representing of the current directory. | |
93 | ||
94 | =cut | |
95 | ||
96 | sub curdir { | |
97 | return '[]'; | |
98 | } | |
99 | ||
100 | =item rootdir (override) | |
101 | ||
102 | Returns a string representing of the root directory. | |
103 | ||
104 | =cut | |
105 | ||
106 | sub rootdir { | |
107 | return ''; | |
108 | } | |
109 | ||
110 | =item updir (override) | |
111 | ||
112 | Returns a string representing of the parent directory. | |
113 | ||
114 | =cut | |
115 | ||
116 | sub updir { | |
117 | return '[-]'; | |
118 | } | |
119 | ||
120 | =item path (override) | |
121 | ||
122 | Translate logical name DCL$PATH as a searchlist, rather than trying | |
123 | to C<split> string value of C<$ENV{'PATH'}>. | |
124 | ||
125 | =cut | |
126 | ||
127 | sub path { | |
128 | my(@dirs,$dir,$i); | |
129 | while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } | |
130 | @dirs; | |
131 | } | |
132 | ||
133 | =item file_name_is_absolute (override) | |
134 | ||
135 | Checks for VMS directory spec as well as Unix separators. | |
136 | ||
137 | =cut | |
138 | ||
139 | sub file_name_is_absolute { | |
140 | my($self,$file) = @_; | |
141 | # If it's a logical name, expand it. | |
142 | $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; | |
143 | $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; | |
144 | } | |
145 | ||
146 | 1; | |
147 | __END__ | |
148 |