This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Typo fix
[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);
cdbde1c3 5$VERSION = '0.35';
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) = @_;
77e96e88
RGS
134 my $got_arrayref = (scalar(@args) == 1
135 && UNIVERSAL::isa($args[0], 'ARRAY'))
136 ? 1
137 : 0;
138
738349a8
SH
139 # Do not quote qualifiers that begin with '/'.
140 map { if (!/^\//) {
141 $_ =~ s/\"/""/g; # escape C<"> by doubling
142 $_ = q(").$_.q(");
143 }
144 }
145 ($got_arrayref ? @{$args[0]}
146 : @args
147 );
77e96e88
RGS
148
149 return $got_arrayref ? $args[0]
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
176=item do_system
177
178Override to ensure that we quote the arguments but not the command.
179
180=cut
181
182sub do_system {
183 # The command must not be quoted but the arguments to it must be.
184 my ($self, @cmd) = @_;
185 $self->log_info("@cmd\n");
186 my $cmd = shift @cmd;
187 my $args = $self->_quote_args(@cmd);
188 return !system("$cmd $args");
189}
190
86bddcbf
NC
191=item oneliner
192
193Override to ensure that we do not quote the command.
194
195=cut
196
197sub oneliner {
198 my $self = shift;
199 my $oneliner = $self->SUPER::oneliner(@_);
200
201 $oneliner =~ s/^\"\S+\"//;
202
203 return "MCR $^X $oneliner";
204}
205
77e96e88
RGS
206=item _infer_xs_spec
207
208Inherit the standard version but tweak the library file name to be
209something Dynaloader can find.
210
211=cut
212
213sub _infer_xs_spec {
214 my $self = shift;
215 my $file = shift;
216
217 my $spec = $self->SUPER::_infer_xs_spec($file);
218
219 # Need to create with the same name as DynaLoader will load with.
220 if (defined &DynaLoader::mod2fname) {
f82d2ab4
CB
221 my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
222 $file =~ tr/:/_/;
223 $file = DynaLoader::mod2fname([$file]);
d9103e67 224 $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88
RGS
225 }
226
227 return $spec;
228}
229
d9103e67
CB
230=item rscan_dir
231
94410036
DG
232Inherit the standard version but remove dots at end of name.
233If the extended character set is in effect, do not remove dots from filenames
234with Unix path delimiters.
d9103e67
CB
235
236=cut
237
238sub rscan_dir {
239 my ($self, $dir, $pattern) = @_;
240
241 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
242
94410036
DG
243 for my $file (@$result) {
244 if (!_efs() && ($file =~ m#/#)) {
245 $file =~ s/\.$//;
246 }
247 }
d9103e67
CB
248 return $result;
249}
250
f82d2ab4
CB
251=item dist_dir
252
253Inherit the standard version but replace embedded dots with underscores because
254a dot is the directory delimiter on VMS.
255
256=cut
257
258sub dist_dir {
259 my $self = shift;
260
261 my $dist_dir = $self->SUPER::dist_dir;
94410036 262 $dist_dir =~ s/\./_/g unless _efs();
f82d2ab4
CB
263 return $dist_dir;
264}
265
266=item man3page_name
267
268Inherit the standard version but chop the extra manpage delimiter off the front if
269there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
270
271=cut
272
273sub man3page_name {
274 my $self = shift;
275
276 my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0
JM
277 my $sep = $self->manpage_separator;
278 $mpname =~ s/^$sep//;
f82d2ab4
CB
279 return $mpname;
280}
281
01f3e2c1 282=item expand_test_dir
f82d2ab4 283
01f3e2c1
CB
284Inherit the standard version but relativize the paths as the native glob() doesn't
285do that for us.
f82d2ab4 286
01f3e2c1
CB
287=cut
288
289sub expand_test_dir {
290 my ($self, $dir) = @_;
291
292 my @reldirs = $self->SUPER::expand_test_dir( $dir );
293
294 for my $eachdir (@reldirs) {
295 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
296 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
297 $eachdir = File::Spec->catfile( $reldir, $f );
298 }
299 return @reldirs;
f82d2ab4 300}
d9103e67 301
3776488a
JM
302=item _detildefy
303
304The home-grown glob() does not currently handle tildes, so provide limited support
305here. Expect only UNIX format file specifications for now.
306
307=cut
308
309sub _detildefy {
310 my ($self, $arg) = @_;
311
312 # Apparently double ~ are not translated.
313 return $arg if ($arg =~ /^~~/);
314
315 # Apparently ~ followed by whitespace are not translated.
316 return $arg if ($arg =~ /^~ /);
317
318 if ($arg =~ /^~/) {
319 my $spec = $arg;
320
321 # Remove the tilde
322 $spec =~ s/^~//;
323
23837600 324 # Remove any slash following the tilde if present.
3776488a
JM
325 $spec =~ s#^/##;
326
327 # break up the paths for the merge
328 my $home = VMS::Filespec::unixify($ENV{HOME});
329
94410036
DG
330 # In the default VMS mode, the trailing slash is present.
331 # In Unix report mode it is not. The parsing logic assumes that
332 # it is present.
333 $home .= '/' unless $home =~ m#/$#;
334
3776488a
JM
335 # Trivial case of just ~ by it self
336 if ($spec eq '') {
86bddcbf 337 $home =~ s#/$##;
3776488a
JM
338 return $home;
339 }
340
341 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
342 if ($hdir eq '') {
343 # Someone has tampered with $ENV{HOME}
344 # So hfile is probably the directory since this should be
345 # a path.
346 $hdir = $hfile;
347 }
348
349 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
350
351 my @hdirs = File::Spec::Unix->splitdir($hdir);
352 my @dirs = File::Spec::Unix->splitdir($dir);
353
354 my $newdirs;
355
356 # Two cases of tilde handling
357 if ($arg =~ m#^~/#) {
358
359 # Simple case, just merge together
360 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
361
362 } else {
363
364 # Complex case, need to add an updir - No delimiters
365 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
366
367 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
368
369 }
370
371 # Now put the two cases back together
372 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
373
3776488a 374 }
94410036 375 return $arg;
3776488a
JM
376
377}
378
fca1d8b3
CB
379=item find_perl_interpreter
380
7a827510
RGS
381On VMS, $^X returns the fully qualified absolute path including version
382number. It's logically impossible to improve on it for getting the perl
383we're currently running, and attempting to manipulate it is usually
384lossy.
fca1d8b3
CB
385
386=cut
387
94410036
DG
388sub find_perl_interpreter {
389 return VMS::Filespec::vmsify($^X);
390}
fca1d8b3 391
738349a8
SH
392=item localize_file_path
393
394Convert the file path to the local syntax
395
396=cut
397
398sub localize_file_path {
399 my ($self, $path) = @_;
94410036 400 $path = VMS::Filespec::vmsify($path);
738349a8 401 $path =~ s/\.\z//;
94410036 402 return $path;
738349a8
SH
403}
404
405=item localize_dir_path
406
407Convert the directory path to the local syntax
408
409=cut
410
411sub localize_dir_path {
412 my ($self, $path) = @_;
413 return VMS::Filespec::vmspath($path);
414}
415
86bddcbf
NC
416=item ACTION_clean
417
418The home-grown glob() expands a bit too aggressively when given a bare name,
419so default in a zero-length extension.
420
421=cut
422
423sub ACTION_clean {
424 my ($self) = @_;
425 foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
426 $self->delete_filetree($item);
427 }
428}
429
94410036
DG
430
431# Need to look up the feature settings. The preferred way is to use the
432# VMS::Feature module, but that may not be available to dual life modules.
433
434my $use_feature;
435BEGIN {
436 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
437 $use_feature = 1;
438 }
439}
440
441# Need to look up the UNIX report mode. This may become a dynamic mode
442# in the future.
443sub _unix_rpt {
444 my $unix_rpt;
445 if ($use_feature) {
446 $unix_rpt = VMS::Feature::current("filename_unix_report");
447 } else {
448 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
449 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
450 }
451 return $unix_rpt;
452}
453
454# Need to look up the EFS character set mode. This may become a dynamic
455# mode in the future.
456sub _efs {
457 my $efs;
458 if ($use_feature) {
459 $efs = VMS::Feature::current("efs_charset");
460 } else {
461 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
462 $efs = $env_efs =~ /^[ET1]/i;
463 }
464 return $efs;
465}
466
bb4e9162
YST
467=back
468
469=head1 AUTHOR
470
f82d2ab4
CB
471Michael G Schwern <schwern@pobox.com>
472Ken Williams <kwilliams@cpan.org>
473Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
474
475=head1 SEE ALSO
476
477perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
478
479=cut
480
4811;
482__END__