This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add-package.pl lib exclude fixed
[perl5.git] / lib / Module / Build / Platform / VMS.pm
CommitLineData
bb4e9162
YST
1package Module::Build::Platform::VMS;
2
3use strict;
7a827510 4use vars qw($VERSION);
2645075a 5$VERSION = '0.32_01';
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
232Inherit the standard version but remove dots at end of name. This may not be
233necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
234
235=cut
236
237sub rscan_dir {
238 my ($self, $dir, $pattern) = @_;
239
240 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
241
242 for my $file (@$result) { $file =~ s/\.$//; }
243 return $result;
244}
245
f82d2ab4
CB
246=item dist_dir
247
248Inherit the standard version but replace embedded dots with underscores because
249a dot is the directory delimiter on VMS.
250
251=cut
252
253sub dist_dir {
254 my $self = shift;
255
256 my $dist_dir = $self->SUPER::dist_dir;
257 $dist_dir =~ s/\./_/g;
258 return $dist_dir;
259}
260
261=item man3page_name
262
263Inherit the standard version but chop the extra manpage delimiter off the front if
264there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
265
266=cut
267
268sub man3page_name {
269 my $self = shift;
270
271 my $mpname = $self->SUPER::man3page_name( shift );
d1bd4ef0
JM
272 my $sep = $self->manpage_separator;
273 $mpname =~ s/^$sep//;
f82d2ab4
CB
274 return $mpname;
275}
276
01f3e2c1 277=item expand_test_dir
f82d2ab4 278
01f3e2c1
CB
279Inherit the standard version but relativize the paths as the native glob() doesn't
280do that for us.
f82d2ab4 281
01f3e2c1
CB
282=cut
283
284sub expand_test_dir {
285 my ($self, $dir) = @_;
286
287 my @reldirs = $self->SUPER::expand_test_dir( $dir );
288
289 for my $eachdir (@reldirs) {
290 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
291 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
292 $eachdir = File::Spec->catfile( $reldir, $f );
293 }
294 return @reldirs;
f82d2ab4 295}
d9103e67 296
3776488a
JM
297=item _detildefy
298
299The home-grown glob() does not currently handle tildes, so provide limited support
300here. Expect only UNIX format file specifications for now.
301
302=cut
303
304sub _detildefy {
305 my ($self, $arg) = @_;
306
307 # Apparently double ~ are not translated.
308 return $arg if ($arg =~ /^~~/);
309
310 # Apparently ~ followed by whitespace are not translated.
311 return $arg if ($arg =~ /^~ /);
312
313 if ($arg =~ /^~/) {
314 my $spec = $arg;
315
316 # Remove the tilde
317 $spec =~ s/^~//;
318
319 # Remove any slash folloing the tilde if present.
320 $spec =~ s#^/##;
321
322 # break up the paths for the merge
323 my $home = VMS::Filespec::unixify($ENV{HOME});
324
325 # Trivial case of just ~ by it self
326 if ($spec eq '') {
86bddcbf 327 $home =~ s#/$##;
3776488a
JM
328 return $home;
329 }
330
331 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
332 if ($hdir eq '') {
333 # Someone has tampered with $ENV{HOME}
334 # So hfile is probably the directory since this should be
335 # a path.
336 $hdir = $hfile;
337 }
338
339 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
340
341 my @hdirs = File::Spec::Unix->splitdir($hdir);
342 my @dirs = File::Spec::Unix->splitdir($dir);
343
344 my $newdirs;
345
346 # Two cases of tilde handling
347 if ($arg =~ m#^~/#) {
348
349 # Simple case, just merge together
350 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
351
352 } else {
353
354 # Complex case, need to add an updir - No delimiters
355 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
356
357 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
358
359 }
360
361 # Now put the two cases back together
362 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
363
364 } else {
365 return $arg;
366 }
367
368}
369
fca1d8b3
CB
370=item find_perl_interpreter
371
7a827510
RGS
372On VMS, $^X returns the fully qualified absolute path including version
373number. It's logically impossible to improve on it for getting the perl
374we're currently running, and attempting to manipulate it is usually
375lossy.
fca1d8b3
CB
376
377=cut
378
379sub find_perl_interpreter { return $^X; }
380
738349a8
SH
381=item localize_file_path
382
383Convert the file path to the local syntax
384
385=cut
386
387sub localize_file_path {
388 my ($self, $path) = @_;
389 $path =~ s/\.\z//;
390 return VMS::Filespec::vmsify($path);
391}
392
393=item localize_dir_path
394
395Convert the directory path to the local syntax
396
397=cut
398
399sub localize_dir_path {
400 my ($self, $path) = @_;
401 return VMS::Filespec::vmspath($path);
402}
403
86bddcbf
NC
404=item ACTION_clean
405
406The home-grown glob() expands a bit too aggressively when given a bare name,
407so default in a zero-length extension.
408
409=cut
410
411sub ACTION_clean {
412 my ($self) = @_;
413 foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
414 $self->delete_filetree($item);
415 }
416}
417
bb4e9162
YST
418=back
419
420=head1 AUTHOR
421
f82d2ab4
CB
422Michael G Schwern <schwern@pobox.com>
423Ken Williams <kwilliams@cpan.org>
424Craig A. Berry <craigberry@mac.com>
bb4e9162
YST
425
426=head1 SEE ALSO
427
428perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
429
430=cut
431
4321;
433__END__