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.4204
[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);
71213e49 5$VERSION = '0.4204';
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
d9103e67
CB
282=item rscan_dir
283
94410036
DG
284Inherit the standard version but remove dots at end of name.
285If the extended character set is in effect, do not remove dots from filenames
286with Unix path delimiters.
d9103e67
CB
287
288=cut
289
290sub rscan_dir {
291 my ($self, $dir, $pattern) = @_;
292
293 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
294
94410036
DG
295 for my $file (@$result) {
296 if (!_efs() && ($file =~ m#/#)) {
297 $file =~ s/\.$//;
298 }
299 }
d9103e67
CB
300 return $result;
301}
302
f82d2ab4
CB
303=item dist_dir
304
074f7b78 305Inherit the standard version but replace embedded dots with underscores because
f82d2ab4
CB
306a dot is the directory delimiter on VMS.
307
308=cut
309
310sub dist_dir {
311 my $self = shift;
312
313 my $dist_dir = $self->SUPER::dist_dir;
94410036 314 $dist_dir =~ s/\./_/g unless _efs();
f82d2ab4
CB
315 return $dist_dir;
316}
317
318=item man3page_name
319
074f7b78 320Inherit the standard version but chop the extra manpage delimiter off the front if
f82d2ab4
CB
321there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
322
323=cut
324
325sub man3page_name {
326 my $self = shift;
327
328 my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0
JM
329 my $sep = $self->manpage_separator;
330 $mpname =~ s/^$sep//;
f82d2ab4
CB
331 return $mpname;
332}
333
01f3e2c1 334=item expand_test_dir
f82d2ab4 335
01f3e2c1
CB
336Inherit the standard version but relativize the paths as the native glob() doesn't
337do that for us.
f82d2ab4 338
01f3e2c1
CB
339=cut
340
341sub expand_test_dir {
342 my ($self, $dir) = @_;
343
344 my @reldirs = $self->SUPER::expand_test_dir( $dir );
345
346 for my $eachdir (@reldirs) {
347 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
348 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
349 $eachdir = File::Spec->catfile( $reldir, $f );
350 }
351 return @reldirs;
f82d2ab4 352}
d9103e67 353
3776488a
JM
354=item _detildefy
355
356The home-grown glob() does not currently handle tildes, so provide limited support
357here. Expect only UNIX format file specifications for now.
358
359=cut
360
361sub _detildefy {
362 my ($self, $arg) = @_;
363
364 # Apparently double ~ are not translated.
365 return $arg if ($arg =~ /^~~/);
366
367 # Apparently ~ followed by whitespace are not translated.
368 return $arg if ($arg =~ /^~ /);
369
370 if ($arg =~ /^~/) {
371 my $spec = $arg;
372
373 # Remove the tilde
374 $spec =~ s/^~//;
375
23837600 376 # Remove any slash following the tilde if present.
3776488a
JM
377 $spec =~ s#^/##;
378
379 # break up the paths for the merge
380 my $home = VMS::Filespec::unixify($ENV{HOME});
381
94410036
DG
382 # In the default VMS mode, the trailing slash is present.
383 # In Unix report mode it is not. The parsing logic assumes that
384 # it is present.
385 $home .= '/' unless $home =~ m#/$#;
386
3776488a
JM
387 # Trivial case of just ~ by it self
388 if ($spec eq '') {
86bddcbf 389 $home =~ s#/$##;
3776488a
JM
390 return $home;
391 }
392
393 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
394 if ($hdir eq '') {
395 # Someone has tampered with $ENV{HOME}
396 # So hfile is probably the directory since this should be
397 # a path.
398 $hdir = $hfile;
399 }
400
401 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
402
403 my @hdirs = File::Spec::Unix->splitdir($hdir);
404 my @dirs = File::Spec::Unix->splitdir($dir);
405
46de787b
CBW
406 unless ($arg =~ m#^~/#) {
407 # There is a home directory after the tilde, but it will already
408 # be present in in @hdirs so we need to remove it by from @dirs.
3776488a 409
46de787b 410 shift @dirs;
3776488a 411 }
46de787b 412 my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
074f7b78 413
3776488a 414 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
3776488a 415 }
94410036 416 return $arg;
3776488a
JM
417
418}
419
fca1d8b3
CB
420=item find_perl_interpreter
421
7a827510
RGS
422On VMS, $^X returns the fully qualified absolute path including version
423number. It's logically impossible to improve on it for getting the perl
424we're currently running, and attempting to manipulate it is usually
425lossy.
fca1d8b3
CB
426
427=cut
428
94410036
DG
429sub find_perl_interpreter {
430 return VMS::Filespec::vmsify($^X);
431}
fca1d8b3 432
738349a8
SH
433=item localize_file_path
434
435Convert the file path to the local syntax
436
437=cut
438
439sub localize_file_path {
440 my ($self, $path) = @_;
94410036 441 $path = VMS::Filespec::vmsify($path);
738349a8 442 $path =~ s/\.\z//;
94410036 443 return $path;
738349a8
SH
444}
445
446=item localize_dir_path
447
448Convert the directory path to the local syntax
449
450=cut
451
452sub localize_dir_path {
453 my ($self, $path) = @_;
454 return VMS::Filespec::vmspath($path);
455}
456
86bddcbf
NC
457=item ACTION_clean
458
459The home-grown glob() expands a bit too aggressively when given a bare name,
460so default in a zero-length extension.
461
462=cut
463
464sub ACTION_clean {
465 my ($self) = @_;
466 foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
467 $self->delete_filetree($item);
468 }
469}
470
94410036
DG
471
472# Need to look up the feature settings. The preferred way is to use the
473# VMS::Feature module, but that may not be available to dual life modules.
474
475my $use_feature;
476BEGIN {
477 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
478 $use_feature = 1;
479 }
480}
481
482# Need to look up the UNIX report mode. This may become a dynamic mode
483# in the future.
484sub _unix_rpt {
485 my $unix_rpt;
486 if ($use_feature) {
487 $unix_rpt = VMS::Feature::current("filename_unix_report");
488 } else {
489 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
074f7b78 490 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
94410036
DG
491 }
492 return $unix_rpt;
493}
494
495# Need to look up the EFS character set mode. This may become a dynamic
496# mode in the future.
497sub _efs {
498 my $efs;
499 if ($use_feature) {
500 $efs = VMS::Feature::current("efs_charset");
501 } else {
502 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
074f7b78 503 $efs = $env_efs =~ /^[ET1]/i;
94410036
DG
504 }
505 return $efs;
506}
507
bb4e9162
YST
508=back
509
510=head1 AUTHOR
511
f82d2ab4
CB
512Michael G Schwern <schwern@pobox.com>
513Ken Williams <kwilliams@cpan.org>
514Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
515
516=head1 SEE ALSO
517
518perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
519
520=cut
521
5221;
523__END__