This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VMS override for Module::Build::Base::find_perl_interpreter,
[perl5.git] / lib / Module / Build / Platform / VMS.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Platform::VMS;
2
3use strict;
4use Module::Build::Base;
5
6use vars qw(@ISA);
7@ISA = qw(Module::Build::Base);
8
9
10
11=head1 NAME
12
13Module::Build::Platform::VMS - Builder class for VMS platforms
14
15=head1 DESCRIPTION
16
17This module inherits from C<Module::Build::Base> and alters a few
18minor details of its functionality. Please see L<Module::Build> for
19the general docs.
20
21=head2 Overridden Methods
22
23=over 4
24
77e96e88 25=item _set_defaults
bb4e9162
YST
26
27Change $self->{build_script} to 'Build.com' so @Build works.
28
29=cut
30
77e96e88
RGS
31sub _set_defaults {
32 my $self = shift;
33 $self->SUPER::_set_defaults(@_);
bb4e9162
YST
34
35 $self->{properties}{build_script} = 'Build.com';
bb4e9162
YST
36}
37
38
39=item cull_args
40
41'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
42people to write '@Build "foo"' we'll dispatch case-insensitively.
43
44=cut
45
46sub cull_args {
47 my $self = shift;
48 my($action, $args) = $self->SUPER::cull_args(@_);
49 my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
50
51 die "Ambiguous action '$action'. Could be one of @possible_actions"
52 if @possible_actions > 1;
53
54 return ($possible_actions[0], $args);
55}
56
57
58=item manpage_separator
59
60Use '__' instead of '::'.
61
62=cut
63
64sub manpage_separator {
65 return '__';
66}
67
68
69=item prefixify
70
71Prefixify taking into account VMS' filepath syntax.
72
73=cut
74
75# Translated from ExtUtils::MM_VMS::prefixify()
76sub _prefixify {
77 my($self, $path, $sprefix, $type) = @_;
78 my $rprefix = $self->prefix;
79
80 $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
81
82 # Translate $(PERLPREFIX) to a real path.
bb4e9162
YST
83 $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
84 $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
85
86 $self->log_verbose(" rprefix translated to $rprefix\n".
87 " sprefix translated to $sprefix\n");
88
89 if( length $path == 0 ) {
90 $self->log_verbose(" no path to prefixify.\n")
91 }
92 elsif( !File::Spec->file_name_is_absolute($path) ) {
93 $self->log_verbose(" path is relative, not prefixifying.\n");
94 }
95 elsif( $sprefix eq $rprefix ) {
96 $self->log_verbose(" no new prefix.\n");
97 }
98 else {
99 my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
77e96e88 100 my $vms_prefix = $self->config('vms_prefix');
bb4e9162
YST
101 if( $path_vol eq $vms_prefix.':' ) {
102 $self->log_verbose(" $vms_prefix: seen\n");
103
104 $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
105 $path = $self->_catprefix($rprefix, $path_dirs);
106 }
107 else {
108 $self->log_verbose(" cannot prefixify.\n");
109 return $self->prefix_relpaths($self->installdirs, $type);
110 }
111 }
112
113 $self->log_verbose(" now $path\n");
114
115 return $path;
116}
117
77e96e88
RGS
118=item _quote_args
119
120Command-line arguments (but not the command itself) must be quoted
121to ensure case preservation.
122
123=cut
bb4e9162 124
a314697d
RS
125sub _quote_args {
126 # Returns a string that can become [part of] a command line with
77e96e88
RGS
127 # proper quoting so that the subprocess sees this same list of args,
128 # or if we get a single arg that is an array reference, quote the
129 # elements of it and return the reference.
a314697d 130 my ($self, @args) = @_;
77e96e88
RGS
131 my $got_arrayref = (scalar(@args) == 1
132 && UNIVERSAL::isa($args[0], 'ARRAY'))
133 ? 1
134 : 0;
135
136 map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
137 ($got_arrayref ? @{$args[0]}
138 : @args
139 );
140
141 return $got_arrayref ? $args[0]
142 : join(' ', @args);
a314697d
RS
143}
144
77e96e88
RGS
145=item have_forkpipe
146
147There is no native fork(), so some constructs depending on it are not
148available.
149
150=cut
151
dc8021d3 152sub have_forkpipe { 0 }
a314697d 153
77e96e88
RGS
154=item _backticks
155
156Override to ensure that we quote the arguments but not the command.
157
158=cut
159
160sub _backticks {
161 # The command must not be quoted but the arguments to it must be.
162 my ($self, @cmd) = @_;
163 my $cmd = shift @cmd;
164 my $args = $self->_quote_args(@cmd);
165 return `$cmd $args`;
166}
167
168=item do_system
169
170Override to ensure that we quote the arguments but not the command.
171
172=cut
173
174sub do_system {
175 # The command must not be quoted but the arguments to it must be.
176 my ($self, @cmd) = @_;
177 $self->log_info("@cmd\n");
178 my $cmd = shift @cmd;
179 my $args = $self->_quote_args(@cmd);
180 return !system("$cmd $args");
181}
182
183=item _infer_xs_spec
184
185Inherit the standard version but tweak the library file name to be
186something Dynaloader can find.
187
188=cut
189
190sub _infer_xs_spec {
191 my $self = shift;
192 my $file = shift;
193
194 my $spec = $self->SUPER::_infer_xs_spec($file);
195
196 # Need to create with the same name as DynaLoader will load with.
197 if (defined &DynaLoader::mod2fname) {
f82d2ab4
CB
198 my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
199 $file =~ tr/:/_/;
200 $file = DynaLoader::mod2fname([$file]);
d9103e67 201 $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88
RGS
202 }
203
204 return $spec;
205}
206
d9103e67
CB
207=item rscan_dir
208
209Inherit the standard version but remove dots at end of name. This may not be
210necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
211
212=cut
213
214sub rscan_dir {
215 my ($self, $dir, $pattern) = @_;
216
217 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
218
219 for my $file (@$result) { $file =~ s/\.$//; }
220 return $result;
221}
222
f82d2ab4
CB
223=item dist_dir
224
225Inherit the standard version but replace embedded dots with underscores because
226a dot is the directory delimiter on VMS.
227
228=cut
229
230sub dist_dir {
231 my $self = shift;
232
233 my $dist_dir = $self->SUPER::dist_dir;
234 $dist_dir =~ s/\./_/g;
235 return $dist_dir;
236}
237
238=item man3page_name
239
240Inherit the standard version but chop the extra manpage delimiter off the front if
241there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
242
243=cut
244
245sub man3page_name {
246 my $self = shift;
247
248 my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0
JM
249 my $sep = $self->manpage_separator;
250 $mpname =~ s/^$sep//;
f82d2ab4
CB
251 return $mpname;
252}
253
01f3e2c1 254=item expand_test_dir
f82d2ab4 255
01f3e2c1
CB
256Inherit the standard version but relativize the paths as the native glob() doesn't
257do that for us.
f82d2ab4 258
01f3e2c1
CB
259=cut
260
261sub expand_test_dir {
262 my ($self, $dir) = @_;
263
264 my @reldirs = $self->SUPER::expand_test_dir( $dir );
265
266 for my $eachdir (@reldirs) {
267 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
268 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
269 $eachdir = File::Spec->catfile( $reldir, $f );
270 }
271 return @reldirs;
f82d2ab4 272}
d9103e67 273
3776488a
JM
274=item _detildefy
275
276The home-grown glob() does not currently handle tildes, so provide limited support
277here. Expect only UNIX format file specifications for now.
278
279=cut
280
281sub _detildefy {
282 my ($self, $arg) = @_;
283
284 # Apparently double ~ are not translated.
285 return $arg if ($arg =~ /^~~/);
286
287 # Apparently ~ followed by whitespace are not translated.
288 return $arg if ($arg =~ /^~ /);
289
290 if ($arg =~ /^~/) {
291 my $spec = $arg;
292
293 # Remove the tilde
294 $spec =~ s/^~//;
295
296 # Remove any slash folloing the tilde if present.
297 $spec =~ s#^/##;
298
299 # break up the paths for the merge
300 my $home = VMS::Filespec::unixify($ENV{HOME});
301
302 # Trivial case of just ~ by it self
303 if ($spec eq '') {
304 return $home;
305 }
306
307 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
308 if ($hdir eq '') {
309 # Someone has tampered with $ENV{HOME}
310 # So hfile is probably the directory since this should be
311 # a path.
312 $hdir = $hfile;
313 }
314
315 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
316
317 my @hdirs = File::Spec::Unix->splitdir($hdir);
318 my @dirs = File::Spec::Unix->splitdir($dir);
319
320 my $newdirs;
321
322 # Two cases of tilde handling
323 if ($arg =~ m#^~/#) {
324
325 # Simple case, just merge together
326 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
327
328 } else {
329
330 # Complex case, need to add an updir - No delimiters
331 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
332
333 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
334
335 }
336
337 # Now put the two cases back together
338 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
339
340 } else {
341 return $arg;
342 }
343
344}
345
fca1d8b3
CB
346=item find_perl_interpreter
347
348On VMS, $^X returns the fully qualified absolute path including version number.
349It's logically impossible to improve on it for getting the perl we're currently
350running, and attempting to manipulate it is usually lossy.
351
352=cut
353
354sub find_perl_interpreter { return $^X; }
355
bb4e9162
YST
356=back
357
358=head1 AUTHOR
359
f82d2ab4
CB
360Michael G Schwern <schwern@pobox.com>
361Ken Williams <kwilliams@cpan.org>
362Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
363
364=head1 SEE ALSO
365
366perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
367
368=cut
369
3701;
371__END__