Commit | Line | Data |
---|---|---|
bb4e9162 YST |
1 | package Module::Build::Platform::VMS; |
2 | ||
3 | use strict; | |
7a827510 | 4 | use vars qw($VERSION); |
66e531b6 | 5 | $VERSION = '0.31_04'; |
7a827510 | 6 | $VERSION = eval $VERSION; |
bb4e9162 YST |
7 | use Module::Build::Base; |
8 | ||
9 | use vars qw(@ISA); | |
10 | @ISA = qw(Module::Build::Base); | |
11 | ||
12 | ||
13 | ||
14 | =head1 NAME | |
15 | ||
16 | Module::Build::Platform::VMS - Builder class for VMS platforms | |
17 | ||
18 | =head1 DESCRIPTION | |
19 | ||
20 | This module inherits from C<Module::Build::Base> and alters a few | |
21 | minor details of its functionality. Please see L<Module::Build> for | |
22 | the general docs. | |
23 | ||
24 | =head2 Overridden Methods | |
25 | ||
26 | =over 4 | |
27 | ||
77e96e88 | 28 | =item _set_defaults |
bb4e9162 YST |
29 | |
30 | Change $self->{build_script} to 'Build.com' so @Build works. | |
31 | ||
32 | =cut | |
33 | ||
77e96e88 RGS |
34 | sub _set_defaults { |
35 | my $self = shift; | |
36 | $self->SUPER::_set_defaults(@_); | |
bb4e9162 YST |
37 | |
38 | $self->{properties}{build_script} = 'Build.com'; | |
bb4e9162 YST |
39 | } |
40 | ||
41 | ||
42 | =item cull_args | |
43 | ||
44 | '@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing | |
45 | people to write '@Build "foo"' we'll dispatch case-insensitively. | |
46 | ||
47 | =cut | |
48 | ||
49 | sub cull_args { | |
50 | my $self = shift; | |
51 | my($action, $args) = $self->SUPER::cull_args(@_); | |
52 | my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions; | |
53 | ||
54 | die "Ambiguous action '$action'. Could be one of @possible_actions" | |
55 | if @possible_actions > 1; | |
56 | ||
57 | return ($possible_actions[0], $args); | |
58 | } | |
59 | ||
60 | ||
61 | =item manpage_separator | |
62 | ||
63 | Use '__' instead of '::'. | |
64 | ||
65 | =cut | |
66 | ||
67 | sub manpage_separator { | |
68 | return '__'; | |
69 | } | |
70 | ||
71 | ||
72 | =item prefixify | |
73 | ||
74 | Prefixify taking into account VMS' filepath syntax. | |
75 | ||
76 | =cut | |
77 | ||
78 | # Translated from ExtUtils::MM_VMS::prefixify() | |
79 | sub _prefixify { | |
80 | my($self, $path, $sprefix, $type) = @_; | |
81 | my $rprefix = $self->prefix; | |
82 | ||
83 | $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n"); | |
84 | ||
85 | # Translate $(PERLPREFIX) to a real path. | |
bb4e9162 YST |
86 | $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix; |
87 | $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix; | |
88 | ||
89 | $self->log_verbose(" rprefix translated to $rprefix\n". | |
90 | " sprefix translated to $sprefix\n"); | |
91 | ||
92 | if( length $path == 0 ) { | |
93 | $self->log_verbose(" no path to prefixify.\n") | |
94 | } | |
95 | elsif( !File::Spec->file_name_is_absolute($path) ) { | |
96 | $self->log_verbose(" path is relative, not prefixifying.\n"); | |
97 | } | |
98 | elsif( $sprefix eq $rprefix ) { | |
99 | $self->log_verbose(" no new prefix.\n"); | |
100 | } | |
101 | else { | |
102 | my($path_vol, $path_dirs) = File::Spec->splitpath( $path ); | |
77e96e88 | 103 | my $vms_prefix = $self->config('vms_prefix'); |
bb4e9162 YST |
104 | if( $path_vol eq $vms_prefix.':' ) { |
105 | $self->log_verbose(" $vms_prefix: seen\n"); | |
106 | ||
107 | $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; | |
108 | $path = $self->_catprefix($rprefix, $path_dirs); | |
109 | } | |
110 | else { | |
111 | $self->log_verbose(" cannot prefixify.\n"); | |
112 | return $self->prefix_relpaths($self->installdirs, $type); | |
113 | } | |
114 | } | |
115 | ||
116 | $self->log_verbose(" now $path\n"); | |
117 | ||
118 | return $path; | |
119 | } | |
120 | ||
77e96e88 RGS |
121 | =item _quote_args |
122 | ||
123 | Command-line arguments (but not the command itself) must be quoted | |
124 | to ensure case preservation. | |
125 | ||
126 | =cut | |
bb4e9162 | 127 | |
a314697d RS |
128 | sub _quote_args { |
129 | # Returns a string that can become [part of] a command line with | |
77e96e88 RGS |
130 | # proper quoting so that the subprocess sees this same list of args, |
131 | # or if we get a single arg that is an array reference, quote the | |
132 | # elements of it and return the reference. | |
a314697d | 133 | my ($self, @args) = @_; |
77e96e88 RGS |
134 | my $got_arrayref = (scalar(@args) == 1 |
135 | && UNIVERSAL::isa($args[0], 'ARRAY')) | |
136 | ? 1 | |
137 | : 0; | |
138 | ||
738349a8 SH |
139 | # Do not quote qualifiers that begin with '/'. |
140 | map { if (!/^\//) { | |
141 | $_ =~ s/\"/""/g; # escape C<"> by doubling | |
142 | $_ = q(").$_.q("); | |
143 | } | |
144 | } | |
145 | ($got_arrayref ? @{$args[0]} | |
146 | : @args | |
147 | ); | |
77e96e88 RGS |
148 | |
149 | return $got_arrayref ? $args[0] | |
150 | : join(' ', @args); | |
a314697d RS |
151 | } |
152 | ||
77e96e88 RGS |
153 | =item have_forkpipe |
154 | ||
155 | There is no native fork(), so some constructs depending on it are not | |
156 | available. | |
157 | ||
158 | =cut | |
159 | ||
dc8021d3 | 160 | sub have_forkpipe { 0 } |
a314697d | 161 | |
77e96e88 RGS |
162 | =item _backticks |
163 | ||
164 | Override to ensure that we quote the arguments but not the command. | |
165 | ||
166 | =cut | |
167 | ||
168 | sub _backticks { | |
169 | # The command must not be quoted but the arguments to it must be. | |
170 | my ($self, @cmd) = @_; | |
171 | my $cmd = shift @cmd; | |
172 | my $args = $self->_quote_args(@cmd); | |
173 | return `$cmd $args`; | |
174 | } | |
175 | ||
176 | =item do_system | |
177 | ||
178 | Override to ensure that we quote the arguments but not the command. | |
179 | ||
180 | =cut | |
181 | ||
182 | sub do_system { | |
183 | # The command must not be quoted but the arguments to it must be. | |
184 | my ($self, @cmd) = @_; | |
185 | $self->log_info("@cmd\n"); | |
186 | my $cmd = shift @cmd; | |
187 | my $args = $self->_quote_args(@cmd); | |
188 | return !system("$cmd $args"); | |
189 | } | |
190 | ||
191 | =item _infer_xs_spec | |
192 | ||
193 | Inherit the standard version but tweak the library file name to be | |
194 | something Dynaloader can find. | |
195 | ||
196 | =cut | |
197 | ||
198 | sub _infer_xs_spec { | |
199 | my $self = shift; | |
200 | my $file = shift; | |
201 | ||
202 | my $spec = $self->SUPER::_infer_xs_spec($file); | |
203 | ||
204 | # Need to create with the same name as DynaLoader will load with. | |
205 | if (defined &DynaLoader::mod2fname) { | |
f82d2ab4 CB |
206 | my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext'); |
207 | $file =~ tr/:/_/; | |
208 | $file = DynaLoader::mod2fname([$file]); | |
d9103e67 | 209 | $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file); |
77e96e88 RGS |
210 | } |
211 | ||
212 | return $spec; | |
213 | } | |
214 | ||
d9103e67 CB |
215 | =item rscan_dir |
216 | ||
217 | Inherit the standard version but remove dots at end of name. This may not be | |
218 | necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect. | |
219 | ||
220 | =cut | |
221 | ||
222 | sub rscan_dir { | |
223 | my ($self, $dir, $pattern) = @_; | |
224 | ||
225 | my $result = $self->SUPER::rscan_dir( $dir, $pattern ); | |
226 | ||
227 | for my $file (@$result) { $file =~ s/\.$//; } | |
228 | return $result; | |
229 | } | |
230 | ||
f82d2ab4 CB |
231 | =item dist_dir |
232 | ||
233 | Inherit the standard version but replace embedded dots with underscores because | |
234 | a dot is the directory delimiter on VMS. | |
235 | ||
236 | =cut | |
237 | ||
238 | sub dist_dir { | |
239 | my $self = shift; | |
240 | ||
241 | my $dist_dir = $self->SUPER::dist_dir; | |
242 | $dist_dir =~ s/\./_/g; | |
243 | return $dist_dir; | |
244 | } | |
245 | ||
246 | =item man3page_name | |
247 | ||
248 | Inherit the standard version but chop the extra manpage delimiter off the front if | |
249 | there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'. | |
250 | ||
251 | =cut | |
252 | ||
253 | sub man3page_name { | |
254 | my $self = shift; | |
255 | ||
256 | my $mpname = $self->SUPER::man3page_name( shift ); | |
d1bd4ef0 JM |
257 | my $sep = $self->manpage_separator; |
258 | $mpname =~ s/^$sep//; | |
f82d2ab4 CB |
259 | return $mpname; |
260 | } | |
261 | ||
01f3e2c1 | 262 | =item expand_test_dir |
f82d2ab4 | 263 | |
01f3e2c1 CB |
264 | Inherit the standard version but relativize the paths as the native glob() doesn't |
265 | do that for us. | |
f82d2ab4 | 266 | |
01f3e2c1 CB |
267 | =cut |
268 | ||
269 | sub expand_test_dir { | |
270 | my ($self, $dir) = @_; | |
271 | ||
272 | my @reldirs = $self->SUPER::expand_test_dir( $dir ); | |
273 | ||
274 | for my $eachdir (@reldirs) { | |
275 | my ($v,$d,$f) = File::Spec->splitpath( $eachdir ); | |
276 | my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) ); | |
277 | $eachdir = File::Spec->catfile( $reldir, $f ); | |
278 | } | |
279 | return @reldirs; | |
f82d2ab4 | 280 | } |
d9103e67 | 281 | |
3776488a JM |
282 | =item _detildefy |
283 | ||
284 | The home-grown glob() does not currently handle tildes, so provide limited support | |
285 | here. Expect only UNIX format file specifications for now. | |
286 | ||
287 | =cut | |
288 | ||
289 | sub _detildefy { | |
290 | my ($self, $arg) = @_; | |
291 | ||
292 | # Apparently double ~ are not translated. | |
293 | return $arg if ($arg =~ /^~~/); | |
294 | ||
295 | # Apparently ~ followed by whitespace are not translated. | |
296 | return $arg if ($arg =~ /^~ /); | |
297 | ||
298 | if ($arg =~ /^~/) { | |
299 | my $spec = $arg; | |
300 | ||
301 | # Remove the tilde | |
302 | $spec =~ s/^~//; | |
303 | ||
304 | # Remove any slash folloing the tilde if present. | |
305 | $spec =~ s#^/##; | |
306 | ||
307 | # break up the paths for the merge | |
308 | my $home = VMS::Filespec::unixify($ENV{HOME}); | |
309 | ||
310 | # Trivial case of just ~ by it self | |
311 | if ($spec eq '') { | |
312 | return $home; | |
313 | } | |
314 | ||
315 | my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home); | |
316 | if ($hdir eq '') { | |
317 | # Someone has tampered with $ENV{HOME} | |
318 | # So hfile is probably the directory since this should be | |
319 | # a path. | |
320 | $hdir = $hfile; | |
321 | } | |
322 | ||
323 | my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec); | |
324 | ||
325 | my @hdirs = File::Spec::Unix->splitdir($hdir); | |
326 | my @dirs = File::Spec::Unix->splitdir($dir); | |
327 | ||
328 | my $newdirs; | |
329 | ||
330 | # Two cases of tilde handling | |
331 | if ($arg =~ m#^~/#) { | |
332 | ||
333 | # Simple case, just merge together | |
334 | $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs); | |
335 | ||
336 | } else { | |
337 | ||
338 | # Complex case, need to add an updir - No delimiters | |
339 | my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir); | |
340 | ||
341 | $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs); | |
342 | ||
343 | } | |
344 | ||
345 | # Now put the two cases back together | |
346 | $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file); | |
347 | ||
348 | } else { | |
349 | return $arg; | |
350 | } | |
351 | ||
352 | } | |
353 | ||
fca1d8b3 CB |
354 | =item find_perl_interpreter |
355 | ||
7a827510 RGS |
356 | On VMS, $^X returns the fully qualified absolute path including version |
357 | number. It's logically impossible to improve on it for getting the perl | |
358 | we're currently running, and attempting to manipulate it is usually | |
359 | lossy. | |
fca1d8b3 CB |
360 | |
361 | =cut | |
362 | ||
363 | sub find_perl_interpreter { return $^X; } | |
364 | ||
738349a8 SH |
365 | =item localize_file_path |
366 | ||
367 | Convert the file path to the local syntax | |
368 | ||
369 | =cut | |
370 | ||
371 | sub localize_file_path { | |
372 | my ($self, $path) = @_; | |
373 | $path =~ s/\.\z//; | |
374 | return VMS::Filespec::vmsify($path); | |
375 | } | |
376 | ||
377 | =item localize_dir_path | |
378 | ||
379 | Convert the directory path to the local syntax | |
380 | ||
381 | =cut | |
382 | ||
383 | sub localize_dir_path { | |
384 | my ($self, $path) = @_; | |
385 | return VMS::Filespec::vmspath($path); | |
386 | } | |
387 | ||
bb4e9162 YST |
388 | =back |
389 | ||
390 | =head1 AUTHOR | |
391 | ||
f82d2ab4 CB |
392 | Michael G Schwern <schwern@pobox.com> |
393 | Ken Williams <kwilliams@cpan.org> | |
394 | Craig A. Berry <craigberry@mac.com> | |
bb4e9162 YST |
395 | |
396 | =head1 SEE ALSO | |
397 | ||
398 | perl(1), Module::Build(3), ExtUtils::MakeMaker(3) | |
399 | ||
400 | =cut | |
401 | ||
402 | 1; | |
403 | __END__ |