This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to Module::Build 0.31_04 (with a tweak to MBTest.pm)
[perl5.git] / lib / Module / Build / Platform / VMS.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Platform::VMS;
2
3use strict;
7a827510 4use vars qw($VERSION);
66e531b6 5$VERSION = '0.31_04';
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
191=item _infer_xs_spec
192
193Inherit the standard version but tweak the library file name to be
194something Dynaloader can find.
195
196=cut
197
198sub _infer_xs_spec {
199 my $self = shift;
200 my $file = shift;
201
202 my $spec = $self->SUPER::_infer_xs_spec($file);
203
204 # Need to create with the same name as DynaLoader will load with.
205 if (defined &DynaLoader::mod2fname) {
f82d2ab4
CB
206 my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
207 $file =~ tr/:/_/;
208 $file = DynaLoader::mod2fname([$file]);
d9103e67 209 $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
77e96e88
RGS
210 }
211
212 return $spec;
213}
214
d9103e67
CB
215=item rscan_dir
216
217Inherit the standard version but remove dots at end of name. This may not be
218necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
219
220=cut
221
222sub rscan_dir {
223 my ($self, $dir, $pattern) = @_;
224
225 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
226
227 for my $file (@$result) { $file =~ s/\.$//; }
228 return $result;
229}
230
f82d2ab4
CB
231=item dist_dir
232
233Inherit the standard version but replace embedded dots with underscores because
234a dot is the directory delimiter on VMS.
235
236=cut
237
238sub dist_dir {
239 my $self = shift;
240
241 my $dist_dir = $self->SUPER::dist_dir;
242 $dist_dir =~ s/\./_/g;
243 return $dist_dir;
244}
245
246=item man3page_name
247
248Inherit the standard version but chop the extra manpage delimiter off the front if
249there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
250
251=cut
252
253sub man3page_name {
254 my $self = shift;
255
256 my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0
JM
257 my $sep = $self->manpage_separator;
258 $mpname =~ s/^$sep//;
f82d2ab4
CB
259 return $mpname;
260}
261
01f3e2c1 262=item expand_test_dir
f82d2ab4 263
01f3e2c1
CB
264Inherit the standard version but relativize the paths as the native glob() doesn't
265do that for us.
f82d2ab4 266
01f3e2c1
CB
267=cut
268
269sub expand_test_dir {
270 my ($self, $dir) = @_;
271
272 my @reldirs = $self->SUPER::expand_test_dir( $dir );
273
274 for my $eachdir (@reldirs) {
275 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
276 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
277 $eachdir = File::Spec->catfile( $reldir, $f );
278 }
279 return @reldirs;
f82d2ab4 280}
d9103e67 281
3776488a
JM
282=item _detildefy
283
284The home-grown glob() does not currently handle tildes, so provide limited support
285here. Expect only UNIX format file specifications for now.
286
287=cut
288
289sub _detildefy {
290 my ($self, $arg) = @_;
291
292 # Apparently double ~ are not translated.
293 return $arg if ($arg =~ /^~~/);
294
295 # Apparently ~ followed by whitespace are not translated.
296 return $arg if ($arg =~ /^~ /);
297
298 if ($arg =~ /^~/) {
299 my $spec = $arg;
300
301 # Remove the tilde
302 $spec =~ s/^~//;
303
304 # Remove any slash folloing the tilde if present.
305 $spec =~ s#^/##;
306
307 # break up the paths for the merge
308 my $home = VMS::Filespec::unixify($ENV{HOME});
309
310 # Trivial case of just ~ by it self
311 if ($spec eq '') {
312 return $home;
313 }
314
315 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
316 if ($hdir eq '') {
317 # Someone has tampered with $ENV{HOME}
318 # So hfile is probably the directory since this should be
319 # a path.
320 $hdir = $hfile;
321 }
322
323 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
324
325 my @hdirs = File::Spec::Unix->splitdir($hdir);
326 my @dirs = File::Spec::Unix->splitdir($dir);
327
328 my $newdirs;
329
330 # Two cases of tilde handling
331 if ($arg =~ m#^~/#) {
332
333 # Simple case, just merge together
334 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
335
336 } else {
337
338 # Complex case, need to add an updir - No delimiters
339 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
340
341 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
342
343 }
344
345 # Now put the two cases back together
346 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
347
348 } else {
349 return $arg;
350 }
351
352}
353
fca1d8b3
CB
354=item find_perl_interpreter
355
7a827510
RGS
356On VMS, $^X returns the fully qualified absolute path including version
357number. It's logically impossible to improve on it for getting the perl
358we're currently running, and attempting to manipulate it is usually
359lossy.
fca1d8b3
CB
360
361=cut
362
363sub find_perl_interpreter { return $^X; }
364
738349a8
SH
365=item localize_file_path
366
367Convert the file path to the local syntax
368
369=cut
370
371sub localize_file_path {
372 my ($self, $path) = @_;
373 $path =~ s/\.\z//;
374 return VMS::Filespec::vmsify($path);
375}
376
377=item localize_dir_path
378
379Convert the directory path to the local syntax
380
381=cut
382
383sub localize_dir_path {
384 my ($self, $path) = @_;
385 return VMS::Filespec::vmspath($path);
386}
387
bb4e9162
YST
388=back
389
390=head1 AUTHOR
391
f82d2ab4
CB
392Michael G Schwern <schwern@pobox.com>
393Ken Williams <kwilliams@cpan.org>
394Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
395
396=head1 SEE ALSO
397
398perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
399
400=cut
401
4021;
403__END__