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