This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
A builtin hard upper bound for sLOCALTIME_max to prevent AIX
[perl5.git] / lib / Module / Build / Platform / VMS.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Platform::VMS;
2
3use strict;
7a827510
RGS
4use vars qw($VERSION);
5$VERSION = '0.2808_01';
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
139 map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
140 ($got_arrayref ? @{$args[0]}
141 : @args
142 );
143
144 return $got_arrayref ? $args[0]
145 : join(' ', @args);
a314697d
RS
146}
147
77e96e88
RGS
148=item have_forkpipe
149
150There is no native fork(), so some constructs depending on it are not
151available.
152
153=cut
154
dc8021d3 155sub have_forkpipe { 0 }
a314697d 156
77e96e88
RGS
157=item _backticks
158
159Override to ensure that we quote the arguments but not the command.
160
161=cut
162
163sub _backticks {
164 # The command must not be quoted but the arguments to it must be.
165 my ($self, @cmd) = @_;
166 my $cmd = shift @cmd;
167 my $args = $self->_quote_args(@cmd);
168 return `$cmd $args`;
169}
170
171=item do_system
172
173Override to ensure that we quote the arguments but not the command.
174
175=cut
176
177sub do_system {
178 # The command must not be quoted but the arguments to it must be.
179 my ($self, @cmd) = @_;
180 $self->log_info("@cmd\n");
181 my $cmd = shift @cmd;
182 my $args = $self->_quote_args(@cmd);
183 return !system("$cmd $args");
184}
185
186=item _infer_xs_spec
187
188Inherit the standard version but tweak the library file name to be
189something Dynaloader can find.
190
191=cut
192
193sub _infer_xs_spec {
194 my $self = shift;
195 my $file = shift;
196
197 my $spec = $self->SUPER::_infer_xs_spec($file);
198
199 # Need to create with the same name as DynaLoader will load with.
200 if (defined &DynaLoader::mod2fname) {
f82d2ab4
CB
201 my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
202 $file =~ tr/:/_/;
203 $file = DynaLoader::mod2fname([$file]);
d9103e67 204 $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88
RGS
205 }
206
207 return $spec;
208}
209
d9103e67
CB
210=item rscan_dir
211
212Inherit the standard version but remove dots at end of name. This may not be
213necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
214
215=cut
216
217sub rscan_dir {
218 my ($self, $dir, $pattern) = @_;
219
220 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
221
222 for my $file (@$result) { $file =~ s/\.$//; }
223 return $result;
224}
225
f82d2ab4
CB
226=item dist_dir
227
228Inherit the standard version but replace embedded dots with underscores because
229a dot is the directory delimiter on VMS.
230
231=cut
232
233sub dist_dir {
234 my $self = shift;
235
236 my $dist_dir = $self->SUPER::dist_dir;
237 $dist_dir =~ s/\./_/g;
238 return $dist_dir;
239}
240
241=item man3page_name
242
243Inherit the standard version but chop the extra manpage delimiter off the front if
244there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
245
246=cut
247
248sub man3page_name {
249 my $self = shift;
250
251 my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0
JM
252 my $sep = $self->manpage_separator;
253 $mpname =~ s/^$sep//;
f82d2ab4
CB
254 return $mpname;
255}
256
01f3e2c1 257=item expand_test_dir
f82d2ab4 258
01f3e2c1
CB
259Inherit the standard version but relativize the paths as the native glob() doesn't
260do that for us.
f82d2ab4 261
01f3e2c1
CB
262=cut
263
264sub expand_test_dir {
265 my ($self, $dir) = @_;
266
267 my @reldirs = $self->SUPER::expand_test_dir( $dir );
268
269 for my $eachdir (@reldirs) {
270 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
271 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
272 $eachdir = File::Spec->catfile( $reldir, $f );
273 }
274 return @reldirs;
f82d2ab4 275}
d9103e67 276
3776488a
JM
277=item _detildefy
278
279The home-grown glob() does not currently handle tildes, so provide limited support
280here. Expect only UNIX format file specifications for now.
281
282=cut
283
284sub _detildefy {
285 my ($self, $arg) = @_;
286
287 # Apparently double ~ are not translated.
288 return $arg if ($arg =~ /^~~/);
289
290 # Apparently ~ followed by whitespace are not translated.
291 return $arg if ($arg =~ /^~ /);
292
293 if ($arg =~ /^~/) {
294 my $spec = $arg;
295
296 # Remove the tilde
297 $spec =~ s/^~//;
298
299 # Remove any slash folloing the tilde if present.
300 $spec =~ s#^/##;
301
302 # break up the paths for the merge
303 my $home = VMS::Filespec::unixify($ENV{HOME});
304
305 # Trivial case of just ~ by it self
306 if ($spec eq '') {
307 return $home;
308 }
309
310 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
311 if ($hdir eq '') {
312 # Someone has tampered with $ENV{HOME}
313 # So hfile is probably the directory since this should be
314 # a path.
315 $hdir = $hfile;
316 }
317
318 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
319
320 my @hdirs = File::Spec::Unix->splitdir($hdir);
321 my @dirs = File::Spec::Unix->splitdir($dir);
322
323 my $newdirs;
324
325 # Two cases of tilde handling
326 if ($arg =~ m#^~/#) {
327
328 # Simple case, just merge together
329 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
330
331 } else {
332
333 # Complex case, need to add an updir - No delimiters
334 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
335
336 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
337
338 }
339
340 # Now put the two cases back together
341 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
342
343 } else {
344 return $arg;
345 }
346
347}
348
fca1d8b3
CB
349=item find_perl_interpreter
350
7a827510
RGS
351On VMS, $^X returns the fully qualified absolute path including version
352number. It's logically impossible to improve on it for getting the perl
353we're currently running, and attempting to manipulate it is usually
354lossy.
fca1d8b3
CB
355
356=cut
357
358sub find_perl_interpreter { return $^X; }
359
bb4e9162
YST
360=back
361
362=head1 AUTHOR
363
f82d2ab4
CB
364Michael G Schwern <schwern@pobox.com>
365Ken Williams <kwilliams@cpan.org>
366Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
367
368=head1 SEE ALSO
369
370perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
371
372=cut
373
3741;
375__END__