This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix 3 remaining Test::Harness tests to work in core.
[perl5.git] / cpan / Module-Build / lib / Module / Build / Platform / VMS.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Platform::VMS;
2
3use strict;
7a827510 4use vars qw($VERSION);
6d3892ec 5$VERSION = '0.3603';
7a827510 6$VERSION = eval $VERSION;
bb4e9162 7use Module::Build::Base;
074f7b78 8use Config;
bb4e9162
YST
9
10use vars qw(@ISA);
11@ISA = qw(Module::Build::Base);
12
13
14
15=head1 NAME
16
17Module::Build::Platform::VMS - Builder class for VMS platforms
18
19=head1 DESCRIPTION
20
21This module inherits from C<Module::Build::Base> and alters a few
22minor details of its functionality. Please see L<Module::Build> for
23the general docs.
24
25=head2 Overridden Methods
26
27=over 4
28
77e96e88 29=item _set_defaults
bb4e9162
YST
30
31Change $self->{build_script} to 'Build.com' so @Build works.
32
33=cut
34
77e96e88
RGS
35sub _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
46people to write '@Build "foo"' we'll dispatch case-insensitively.
47
48=cut
49
50sub 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
64Use '__' instead of '::'.
65
66=cut
67
68sub manpage_separator {
69 return '__';
70}
71
72
73=item prefixify
74
75Prefixify taking into account VMS' filepath syntax.
76
77=cut
78
79# Translated from ExtUtils::MM_VMS::prefixify()
80sub _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
6d3892ec 93 if( length $path == 0 ) {
bb4e9162
YST
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
124Command-line arguments (but not the command itself) must be quoted
125to ensure case preservation.
126
127=cut
bb4e9162 128
a314697d
RS
129sub _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
156There is no native fork(), so some constructs depending on it are not
157available.
158
159=cut
160
dc8021d3 161sub have_forkpipe { 0 }
a314697d 162
77e96e88
RGS
163=item _backticks
164
165Override to ensure that we quote the arguments but not the command.
166
167=cut
168
169sub _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
179Local an executable program
180
181=cut
182
183sub 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
201Follows VMS naming conventions for executable files.
202If the name passed in doesn't exactly match an executable file,
203appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
204to check for DCL procedure. If this fails, checks directories in DCL$PATH
205and finally F<Sys$System:> for an executable file having the name specified,
206with or without the F<.Exe>-equivalent suffix.
207
208=cut
209
210sub _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
235Override to ensure that we quote the arguments but not the command.
236
237=cut
238
239sub 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
250Override to ensure that we do not quote the command.
251
252=cut
253
254sub 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 265Inherit the standard version but tweak the library file name to be
77e96e88
RGS
266something Dynaloader can find.
267
268=cut
269
270sub _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
289Inherit the standard version but remove dots at end of name.
290If the extended character set is in effect, do not remove dots from filenames
291with Unix path delimiters.
d9103e67
CB
292
293=cut
294
295sub 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 310Inherit the standard version but replace embedded dots with underscores because
f82d2ab4
CB
311a dot is the directory delimiter on VMS.
312
313=cut
314
315sub 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 325Inherit the standard version but chop the extra manpage delimiter off the front if
f82d2ab4
CB
326there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
327
328=cut
329
330sub 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
341Inherit the standard version but relativize the paths as the native glob() doesn't
342do that for us.
f82d2ab4 343
01f3e2c1
CB
344=cut
345
346sub 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
361The home-grown glob() does not currently handle tildes, so provide limited support
362here. Expect only UNIX format file specifications for now.
363
364=cut
365
366sub _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
438On VMS, $^X returns the fully qualified absolute path including version
439number. It's logically impossible to improve on it for getting the perl
440we're currently running, and attempting to manipulate it is usually
441lossy.
fca1d8b3
CB
442
443=cut
444
94410036
DG
445sub find_perl_interpreter {
446 return VMS::Filespec::vmsify($^X);
447}
fca1d8b3 448
738349a8
SH
449=item localize_file_path
450
451Convert the file path to the local syntax
452
453=cut
454
455sub 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
464Convert the directory path to the local syntax
465
466=cut
467
468sub localize_dir_path {
469 my ($self, $path) = @_;
470 return VMS::Filespec::vmspath($path);
471}
472
86bddcbf
NC
473=item ACTION_clean
474
475The home-grown glob() expands a bit too aggressively when given a bare name,
476so default in a zero-length extension.
477
478=cut
479
480sub 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
491my $use_feature;
492BEGIN {
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.
500sub _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.
513sub _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
528Michael G Schwern <schwern@pobox.com>
529Ken Williams <kwilliams@cpan.org>
530Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
531
532=head1 SEE ALSO
533
534perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
535
536=cut
537
5381;
539__END__