Commit | Line | Data |
---|---|---|
bb4e9162 YST |
1 | package Module::Build::Platform::VMS; |
2 | ||
3 | use strict; | |
7a827510 | 4 | use vars qw($VERSION); |
c341c67b | 5 | $VERSION = '0.36'; |
7a827510 | 6 | $VERSION = eval $VERSION; |
bb4e9162 | 7 | use Module::Build::Base; |
074f7b78 | 8 | use Config; |
bb4e9162 YST |
9 | |
10 | use vars qw(@ISA); | |
11 | @ISA = qw(Module::Build::Base); | |
12 | ||
13 | ||
14 | ||
15 | =head1 NAME | |
16 | ||
17 | Module::Build::Platform::VMS - Builder class for VMS platforms | |
18 | ||
19 | =head1 DESCRIPTION | |
20 | ||
21 | This module inherits from C<Module::Build::Base> and alters a few | |
22 | minor details of its functionality. Please see L<Module::Build> for | |
23 | the general docs. | |
24 | ||
25 | =head2 Overridden Methods | |
26 | ||
27 | =over 4 | |
28 | ||
77e96e88 | 29 | =item _set_defaults |
bb4e9162 YST |
30 | |
31 | Change $self->{build_script} to 'Build.com' so @Build works. | |
32 | ||
33 | =cut | |
34 | ||
77e96e88 RGS |
35 | sub _set_defaults { |
36 | my $self = shift; | |
37 | $self->SUPER::_set_defaults(@_); | |
bb4e9162 YST |
38 | |
39 | $self->{properties}{build_script} = 'Build.com'; | |
bb4e9162 YST |
40 | } |
41 | ||
42 | ||
43 | =item cull_args | |
44 | ||
45 | '@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing | |
46 | people to write '@Build "foo"' we'll dispatch case-insensitively. | |
47 | ||
48 | =cut | |
49 | ||
50 | sub cull_args { | |
51 | my $self = shift; | |
52 | my($action, $args) = $self->SUPER::cull_args(@_); | |
53 | my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions; | |
54 | ||
55 | die "Ambiguous action '$action'. Could be one of @possible_actions" | |
56 | if @possible_actions > 1; | |
57 | ||
58 | return ($possible_actions[0], $args); | |
59 | } | |
60 | ||
61 | ||
62 | =item manpage_separator | |
63 | ||
64 | Use '__' instead of '::'. | |
65 | ||
66 | =cut | |
67 | ||
68 | sub manpage_separator { | |
69 | return '__'; | |
70 | } | |
71 | ||
72 | ||
73 | =item prefixify | |
74 | ||
75 | Prefixify taking into account VMS' filepath syntax. | |
76 | ||
77 | =cut | |
78 | ||
79 | # Translated from ExtUtils::MM_VMS::prefixify() | |
80 | sub _prefixify { | |
81 | my($self, $path, $sprefix, $type) = @_; | |
82 | my $rprefix = $self->prefix; | |
83 | ||
84 | $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n"); | |
85 | ||
86 | # Translate $(PERLPREFIX) to a real path. | |
bb4e9162 YST |
87 | $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix; |
88 | $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix; | |
89 | ||
90 | $self->log_verbose(" rprefix translated to $rprefix\n". | |
91 | " sprefix translated to $sprefix\n"); | |
92 | ||
93 | if( length $path == 0 ) { | |
94 | $self->log_verbose(" no path to prefixify.\n") | |
95 | } | |
96 | elsif( !File::Spec->file_name_is_absolute($path) ) { | |
97 | $self->log_verbose(" path is relative, not prefixifying.\n"); | |
98 | } | |
99 | elsif( $sprefix eq $rprefix ) { | |
100 | $self->log_verbose(" no new prefix.\n"); | |
101 | } | |
102 | else { | |
103 | my($path_vol, $path_dirs) = File::Spec->splitpath( $path ); | |
77e96e88 | 104 | my $vms_prefix = $self->config('vms_prefix'); |
bb4e9162 YST |
105 | if( $path_vol eq $vms_prefix.':' ) { |
106 | $self->log_verbose(" $vms_prefix: seen\n"); | |
107 | ||
108 | $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; | |
109 | $path = $self->_catprefix($rprefix, $path_dirs); | |
110 | } | |
111 | else { | |
112 | $self->log_verbose(" cannot prefixify.\n"); | |
113 | return $self->prefix_relpaths($self->installdirs, $type); | |
114 | } | |
115 | } | |
116 | ||
117 | $self->log_verbose(" now $path\n"); | |
118 | ||
119 | return $path; | |
120 | } | |
121 | ||
77e96e88 RGS |
122 | =item _quote_args |
123 | ||
124 | Command-line arguments (but not the command itself) must be quoted | |
125 | to ensure case preservation. | |
126 | ||
127 | =cut | |
bb4e9162 | 128 | |
a314697d RS |
129 | sub _quote_args { |
130 | # Returns a string that can become [part of] a command line with | |
77e96e88 RGS |
131 | # proper quoting so that the subprocess sees this same list of args, |
132 | # or if we get a single arg that is an array reference, quote the | |
133 | # elements of it and return the reference. | |
a314697d | 134 | my ($self, @args) = @_; |
074f7b78 DG |
135 | my $got_arrayref = (scalar(@args) == 1 |
136 | && UNIVERSAL::isa($args[0], 'ARRAY')) | |
137 | ? 1 | |
77e96e88 RGS |
138 | : 0; |
139 | ||
738349a8 | 140 | # Do not quote qualifiers that begin with '/'. |
074f7b78 | 141 | map { if (!/^\//) { |
738349a8 SH |
142 | $_ =~ s/\"/""/g; # escape C<"> by doubling |
143 | $_ = q(").$_.q("); | |
144 | } | |
145 | } | |
074f7b78 | 146 | ($got_arrayref ? @{$args[0]} |
738349a8 SH |
147 | : @args |
148 | ); | |
77e96e88 | 149 | |
074f7b78 | 150 | return $got_arrayref ? $args[0] |
77e96e88 | 151 | : join(' ', @args); |
a314697d RS |
152 | } |
153 | ||
77e96e88 RGS |
154 | =item have_forkpipe |
155 | ||
156 | There is no native fork(), so some constructs depending on it are not | |
157 | available. | |
158 | ||
159 | =cut | |
160 | ||
dc8021d3 | 161 | sub have_forkpipe { 0 } |
a314697d | 162 | |
77e96e88 RGS |
163 | =item _backticks |
164 | ||
165 | Override to ensure that we quote the arguments but not the command. | |
166 | ||
167 | =cut | |
168 | ||
169 | sub _backticks { | |
170 | # The command must not be quoted but the arguments to it must be. | |
171 | my ($self, @cmd) = @_; | |
172 | my $cmd = shift @cmd; | |
173 | my $args = $self->_quote_args(@cmd); | |
174 | return `$cmd $args`; | |
175 | } | |
176 | ||
613f422f DG |
177 | =item find_command |
178 | ||
179 | Local an executable program | |
180 | ||
181 | =cut | |
182 | ||
183 | sub find_command { | |
184 | my ($self, $command) = @_; | |
185 | ||
186 | # a lot of VMS executables have a symbol defined | |
187 | # check those first | |
188 | if ( $^O eq 'VMS' ) { | |
189 | require VMS::DCLsym; | |
190 | my $syms = VMS::DCLsym->new; | |
191 | return $command if scalar $syms->getsym( uc $command ); | |
192 | } | |
193 | ||
194 | $self->SUPER::find_command($command); | |
195 | } | |
196 | ||
197 | # _maybe_command copied from ExtUtils::MM_VMS::maybe_command | |
198 | ||
199 | =item _maybe_command (override) | |
200 | ||
201 | Follows VMS naming conventions for executable files. | |
202 | If the name passed in doesn't exactly match an executable file, | |
203 | appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> | |
204 | to check for DCL procedure. If this fails, checks directories in DCL$PATH | |
205 | and finally F<Sys$System:> for an executable file having the name specified, | |
206 | with or without the F<.Exe>-equivalent suffix. | |
207 | ||
208 | =cut | |
209 | ||
210 | sub _maybe_command { | |
211 | my($self,$file) = @_; | |
212 | return $file if -x $file && ! -d _; | |
213 | my(@dirs) = (''); | |
214 | my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); | |
215 | ||
216 | if ($file !~ m![/:>\]]!) { | |
217 | for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { | |
218 | my $dir = $ENV{"DCL\$PATH;$i"}; | |
219 | $dir .= ':' unless $dir =~ m%[\]:]$%; | |
220 | push(@dirs,$dir); | |
221 | } | |
222 | push(@dirs,'Sys$System:'); | |
223 | foreach my $dir (@dirs) { | |
224 | my $sysfile = "$dir$file"; | |
225 | foreach my $ext (@exts) { | |
226 | return $file if -x "$sysfile$ext" && ! -d _; | |
227 | } | |
228 | } | |
229 | } | |
230 | return; | |
231 | } | |
232 | ||
77e96e88 RGS |
233 | =item do_system |
234 | ||
235 | Override to ensure that we quote the arguments but not the command. | |
236 | ||
237 | =cut | |
238 | ||
239 | sub do_system { | |
240 | # The command must not be quoted but the arguments to it must be. | |
241 | my ($self, @cmd) = @_; | |
613f422f | 242 | $self->log_verbose("@cmd\n"); |
77e96e88 RGS |
243 | my $cmd = shift @cmd; |
244 | my $args = $self->_quote_args(@cmd); | |
245 | return !system("$cmd $args"); | |
246 | } | |
247 | ||
86bddcbf NC |
248 | =item oneliner |
249 | ||
250 | Override to ensure that we do not quote the command. | |
251 | ||
252 | =cut | |
253 | ||
254 | sub oneliner { | |
255 | my $self = shift; | |
256 | my $oneliner = $self->SUPER::oneliner(@_); | |
257 | ||
258 | $oneliner =~ s/^\"\S+\"//; | |
259 | ||
260 | return "MCR $^X $oneliner"; | |
261 | } | |
262 | ||
77e96e88 RGS |
263 | =item _infer_xs_spec |
264 | ||
074f7b78 | 265 | Inherit the standard version but tweak the library file name to be |
77e96e88 RGS |
266 | something Dynaloader can find. |
267 | ||
268 | =cut | |
269 | ||
270 | sub _infer_xs_spec { | |
271 | my $self = shift; | |
272 | my $file = shift; | |
273 | ||
274 | my $spec = $self->SUPER::_infer_xs_spec($file); | |
275 | ||
276 | # Need to create with the same name as DynaLoader will load with. | |
277 | if (defined &DynaLoader::mod2fname) { | |
f82d2ab4 CB |
278 | my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext'); |
279 | $file =~ tr/:/_/; | |
280 | $file = DynaLoader::mod2fname([$file]); | |
d9103e67 | 281 | $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file); |
77e96e88 RGS |
282 | } |
283 | ||
284 | return $spec; | |
285 | } | |
286 | ||
d9103e67 CB |
287 | =item rscan_dir |
288 | ||
94410036 DG |
289 | Inherit the standard version but remove dots at end of name. |
290 | If the extended character set is in effect, do not remove dots from filenames | |
291 | with Unix path delimiters. | |
d9103e67 CB |
292 | |
293 | =cut | |
294 | ||
295 | sub rscan_dir { | |
296 | my ($self, $dir, $pattern) = @_; | |
297 | ||
298 | my $result = $self->SUPER::rscan_dir( $dir, $pattern ); | |
299 | ||
94410036 DG |
300 | for my $file (@$result) { |
301 | if (!_efs() && ($file =~ m#/#)) { | |
302 | $file =~ s/\.$//; | |
303 | } | |
304 | } | |
d9103e67 CB |
305 | return $result; |
306 | } | |
307 | ||
f82d2ab4 CB |
308 | =item dist_dir |
309 | ||
074f7b78 | 310 | Inherit the standard version but replace embedded dots with underscores because |
f82d2ab4 CB |
311 | a dot is the directory delimiter on VMS. |
312 | ||
313 | =cut | |
314 | ||
315 | sub dist_dir { | |
316 | my $self = shift; | |
317 | ||
318 | my $dist_dir = $self->SUPER::dist_dir; | |
94410036 | 319 | $dist_dir =~ s/\./_/g unless _efs(); |
f82d2ab4 CB |
320 | return $dist_dir; |
321 | } | |
322 | ||
323 | =item man3page_name | |
324 | ||
074f7b78 | 325 | Inherit the standard version but chop the extra manpage delimiter off the front if |
f82d2ab4 CB |
326 | there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'. |
327 | ||
328 | =cut | |
329 | ||
330 | sub man3page_name { | |
331 | my $self = shift; | |
332 | ||
333 | my $mpname = $self->SUPER::man3page_name( shift ); | |
d1bd4ef0 JM |
334 | my $sep = $self->manpage_separator; |
335 | $mpname =~ s/^$sep//; | |
f82d2ab4 CB |
336 | return $mpname; |
337 | } | |
338 | ||
01f3e2c1 | 339 | =item expand_test_dir |
f82d2ab4 | 340 | |
01f3e2c1 CB |
341 | Inherit the standard version but relativize the paths as the native glob() doesn't |
342 | do that for us. | |
f82d2ab4 | 343 | |
01f3e2c1 CB |
344 | =cut |
345 | ||
346 | sub expand_test_dir { | |
347 | my ($self, $dir) = @_; | |
348 | ||
349 | my @reldirs = $self->SUPER::expand_test_dir( $dir ); | |
350 | ||
351 | for my $eachdir (@reldirs) { | |
352 | my ($v,$d,$f) = File::Spec->splitpath( $eachdir ); | |
353 | my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) ); | |
354 | $eachdir = File::Spec->catfile( $reldir, $f ); | |
355 | } | |
356 | return @reldirs; | |
f82d2ab4 | 357 | } |
d9103e67 | 358 | |
3776488a JM |
359 | =item _detildefy |
360 | ||
361 | The home-grown glob() does not currently handle tildes, so provide limited support | |
362 | here. Expect only UNIX format file specifications for now. | |
363 | ||
364 | =cut | |
365 | ||
366 | sub _detildefy { | |
367 | my ($self, $arg) = @_; | |
368 | ||
369 | # Apparently double ~ are not translated. | |
370 | return $arg if ($arg =~ /^~~/); | |
371 | ||
372 | # Apparently ~ followed by whitespace are not translated. | |
373 | return $arg if ($arg =~ /^~ /); | |
374 | ||
375 | if ($arg =~ /^~/) { | |
376 | my $spec = $arg; | |
377 | ||
378 | # Remove the tilde | |
379 | $spec =~ s/^~//; | |
380 | ||
23837600 | 381 | # Remove any slash following the tilde if present. |
3776488a JM |
382 | $spec =~ s#^/##; |
383 | ||
384 | # break up the paths for the merge | |
385 | my $home = VMS::Filespec::unixify($ENV{HOME}); | |
386 | ||
94410036 DG |
387 | # In the default VMS mode, the trailing slash is present. |
388 | # In Unix report mode it is not. The parsing logic assumes that | |
389 | # it is present. | |
390 | $home .= '/' unless $home =~ m#/$#; | |
391 | ||
3776488a JM |
392 | # Trivial case of just ~ by it self |
393 | if ($spec eq '') { | |
86bddcbf | 394 | $home =~ s#/$##; |
3776488a JM |
395 | return $home; |
396 | } | |
397 | ||
398 | my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home); | |
399 | if ($hdir eq '') { | |
400 | # Someone has tampered with $ENV{HOME} | |
401 | # So hfile is probably the directory since this should be | |
402 | # a path. | |
403 | $hdir = $hfile; | |
404 | } | |
405 | ||
406 | my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec); | |
407 | ||
408 | my @hdirs = File::Spec::Unix->splitdir($hdir); | |
409 | my @dirs = File::Spec::Unix->splitdir($dir); | |
410 | ||
411 | my $newdirs; | |
412 | ||
413 | # Two cases of tilde handling | |
414 | if ($arg =~ m#^~/#) { | |
415 | ||
416 | # Simple case, just merge together | |
417 | $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs); | |
418 | ||
419 | } else { | |
420 | ||
421 | # Complex case, need to add an updir - No delimiters | |
422 | my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir); | |
423 | ||
424 | $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs); | |
425 | ||
426 | } | |
074f7b78 | 427 | |
3776488a JM |
428 | # Now put the two cases back together |
429 | $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file); | |
430 | ||
3776488a | 431 | } |
94410036 | 432 | return $arg; |
3776488a JM |
433 | |
434 | } | |
435 | ||
fca1d8b3 CB |
436 | =item find_perl_interpreter |
437 | ||
7a827510 RGS |
438 | On VMS, $^X returns the fully qualified absolute path including version |
439 | number. It's logically impossible to improve on it for getting the perl | |
440 | we're currently running, and attempting to manipulate it is usually | |
441 | lossy. | |
fca1d8b3 CB |
442 | |
443 | =cut | |
444 | ||
94410036 DG |
445 | sub find_perl_interpreter { |
446 | return VMS::Filespec::vmsify($^X); | |
447 | } | |
fca1d8b3 | 448 | |
738349a8 SH |
449 | =item localize_file_path |
450 | ||
451 | Convert the file path to the local syntax | |
452 | ||
453 | =cut | |
454 | ||
455 | sub localize_file_path { | |
456 | my ($self, $path) = @_; | |
94410036 | 457 | $path = VMS::Filespec::vmsify($path); |
738349a8 | 458 | $path =~ s/\.\z//; |
94410036 | 459 | return $path; |
738349a8 SH |
460 | } |
461 | ||
462 | =item localize_dir_path | |
463 | ||
464 | Convert the directory path to the local syntax | |
465 | ||
466 | =cut | |
467 | ||
468 | sub localize_dir_path { | |
469 | my ($self, $path) = @_; | |
470 | return VMS::Filespec::vmspath($path); | |
471 | } | |
472 | ||
86bddcbf NC |
473 | =item ACTION_clean |
474 | ||
475 | The home-grown glob() expands a bit too aggressively when given a bare name, | |
476 | so default in a zero-length extension. | |
477 | ||
478 | =cut | |
479 | ||
480 | sub ACTION_clean { | |
481 | my ($self) = @_; | |
482 | foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) { | |
483 | $self->delete_filetree($item); | |
484 | } | |
485 | } | |
486 | ||
94410036 DG |
487 | |
488 | # Need to look up the feature settings. The preferred way is to use the | |
489 | # VMS::Feature module, but that may not be available to dual life modules. | |
490 | ||
491 | my $use_feature; | |
492 | BEGIN { | |
493 | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { | |
494 | $use_feature = 1; | |
495 | } | |
496 | } | |
497 | ||
498 | # Need to look up the UNIX report mode. This may become a dynamic mode | |
499 | # in the future. | |
500 | sub _unix_rpt { | |
501 | my $unix_rpt; | |
502 | if ($use_feature) { | |
503 | $unix_rpt = VMS::Feature::current("filename_unix_report"); | |
504 | } else { | |
505 | my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; | |
074f7b78 | 506 | $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; |
94410036 DG |
507 | } |
508 | return $unix_rpt; | |
509 | } | |
510 | ||
511 | # Need to look up the EFS character set mode. This may become a dynamic | |
512 | # mode in the future. | |
513 | sub _efs { | |
514 | my $efs; | |
515 | if ($use_feature) { | |
516 | $efs = VMS::Feature::current("efs_charset"); | |
517 | } else { | |
518 | my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; | |
074f7b78 | 519 | $efs = $env_efs =~ /^[ET1]/i; |
94410036 DG |
520 | } |
521 | return $efs; | |
522 | } | |
523 | ||
bb4e9162 YST |
524 | =back |
525 | ||
526 | =head1 AUTHOR | |
527 | ||
f82d2ab4 CB |
528 | Michael G Schwern <schwern@pobox.com> |
529 | Ken Williams <kwilliams@cpan.org> | |
530 | Craig A. Berry <craigberry@mac.com> | |
bb4e9162 YST |
531 | |
532 | =head1 SEE ALSO | |
533 | ||
534 | perl(1), Module::Build(3), ExtUtils::MakeMaker(3) | |
535 | ||
536 | =cut | |
537 | ||
538 | 1; | |
539 | __END__ |