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