This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Module-Build to CPAN version 0.4204
[perl5.git] / cpan / Module-Build / lib / Module / Build / Platform / VMS.pm
1 package Module::Build::Platform::VMS;
2
3 use strict;
4 use vars qw($VERSION);
5 $VERSION = '0.4204';
6 $VERSION = eval $VERSION;
7 use Module::Build::Base;
8 use Config;
9
10 use vars qw(@ISA);
11 @ISA = qw(Module::Build::Base);
12
13
14
15 =head1 NAME
16
17 Module::Build::Platform::VMS - Builder class for VMS platforms
18
19 =head1 DESCRIPTION
20
21 This module inherits from C<Module::Build::Base> and alters a few
22 minor details of its functionality.  Please see L<Module::Build> for
23 the general docs.
24
25 =head2 Overridden Methods
26
27 =over 4
28
29 =item _set_defaults
30
31 Change $self->{build_script} to 'Build.com' so @Build works.
32
33 =cut
34
35 sub _set_defaults {
36     my $self = shift;
37     $self->SUPER::_set_defaults(@_);
38
39     $self->{properties}{build_script} = 'Build.com';
40 }
41
42
43 =item cull_args
44
45 '@Build foo' on VMS will not preserve the case of 'foo'.  Rather than forcing
46 people to write '@Build "foo"' we'll dispatch case-insensitively.
47
48 =cut
49
50 sub cull_args {
51     my $self = shift;
52     my($action, $args) = $self->SUPER::cull_args(@_);
53     my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
54
55     die "Ambiguous action '$action'.  Could be one of @possible_actions"
56         if @possible_actions > 1;
57
58     return ($possible_actions[0], $args);
59 }
60
61
62 =item manpage_separator
63
64 Use '__' instead of '::'.
65
66 =cut
67
68 sub manpage_separator {
69     return '__';
70 }
71
72
73 =item prefixify
74
75 Prefixify taking into account VMS' filepath syntax.
76
77 =cut
78
79 # Translated from ExtUtils::MM_VMS::prefixify()
80
81 sub _catprefix {
82     my($self, $rprefix, $default) = @_;
83
84     my($rvol, $rdirs) = File::Spec->splitpath($rprefix);
85     if( $rvol ) {
86         return File::Spec->catpath($rvol,
87                                    File::Spec->catdir($rdirs, $default),
88                                    ''
89                                   )
90     }
91     else {
92         return File::Spec->catdir($rdirs, $default);
93     }
94 }
95
96
97 sub _prefixify {
98     my($self, $path, $sprefix, $type) = @_;
99     my $rprefix = $self->prefix;
100
101     return '' unless defined $path;
102
103     $self->log_verbose("  prefixify $path from $sprefix to $rprefix\n");
104
105     # Translate $(PERLPREFIX) to a real path.
106     $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
107     $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
108
109     $self->log_verbose("  rprefix translated to $rprefix\n".
110                        "  sprefix translated to $sprefix\n");
111
112     if( length($path) == 0 ) {
113         $self->log_verbose("  no path to prefixify.\n")
114     }
115     elsif( !File::Spec->file_name_is_absolute($path) ) {
116         $self->log_verbose("    path is relative, not prefixifying.\n");
117     }
118     elsif( $sprefix eq $rprefix ) {
119         $self->log_verbose("  no new prefix.\n");
120     }
121     else {
122         my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
123         my $vms_prefix = $self->config('vms_prefix');
124         if( $path_vol eq $vms_prefix.':' ) {
125             $self->log_verbose("  $vms_prefix: seen\n");
126
127             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
128             $path = $self->_catprefix($rprefix, $path_dirs);
129         }
130         else {
131             $self->log_verbose("    cannot prefixify.\n");
132             return $self->prefix_relpaths($self->installdirs, $type);
133         }
134     }
135
136     $self->log_verbose("    now $path\n");
137
138     return $path;
139 }
140
141 =item _quote_args
142
143 Command-line arguments (but not the command itself) must be quoted
144 to ensure case preservation.
145
146 =cut
147
148 sub _quote_args {
149   # Returns a string that can become [part of] a command line with
150   # proper quoting so that the subprocess sees this same list of args,
151   # or if we get a single arg that is an array reference, quote the
152   # elements of it and return the reference.
153   my ($self, @args) = @_;
154   my $got_arrayref = (scalar(@args) == 1
155                       && UNIVERSAL::isa($args[0], 'ARRAY'))
156                    ? 1
157                    : 0;
158
159   # Do not quote qualifiers that begin with '/'.
160   map { if (!/^\//) {
161           $_ =~ s/\"/""/g;     # escape C<"> by doubling
162           $_ = q(").$_.q(");
163         }
164   }
165     ($got_arrayref ? @{$args[0]}
166                    : @args
167     );
168
169   return $got_arrayref ? $args[0]
170                        : join(' ', @args);
171 }
172
173 =item have_forkpipe
174
175 There is no native fork(), so some constructs depending on it are not
176 available.
177
178 =cut
179
180 sub have_forkpipe { 0 }
181
182 =item _backticks
183
184 Override to ensure that we quote the arguments but not the command.
185
186 =cut
187
188 sub _backticks {
189   # The command must not be quoted but the arguments to it must be.
190   my ($self, @cmd) = @_;
191   my $cmd = shift @cmd;
192   my $args = $self->_quote_args(@cmd);
193   return `$cmd $args`;
194 }
195
196 =item find_command
197
198 Local an executable program
199
200 =cut
201
202 sub find_command {
203     my ($self, $command) = @_;
204
205     # a lot of VMS executables have a symbol defined
206     # check those first
207     if ( $^O eq 'VMS' ) {
208         require VMS::DCLsym;
209         my $syms = VMS::DCLsym->new;
210         return $command if scalar $syms->getsym( uc $command );
211     }
212
213     $self->SUPER::find_command($command);
214 }
215
216 # _maybe_command copied from ExtUtils::MM_VMS::maybe_command
217
218 =item _maybe_command (override)
219
220 Follows VMS naming conventions for executable files.
221 If the name passed in doesn't exactly match an executable file,
222 appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
223 to check for DCL procedure.  If this fails, checks directories in DCL$PATH
224 and finally F<Sys$System:> for an executable file having the name specified,
225 with or without the F<.Exe>-equivalent suffix.
226
227 =cut
228
229 sub _maybe_command {
230     my($self,$file) = @_;
231     return $file if -x $file && ! -d _;
232     my(@dirs) = ('');
233     my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
234
235     if ($file !~ m![/:>\]]!) {
236         for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
237             my $dir = $ENV{"DCL\$PATH;$i"};
238             $dir .= ':' unless $dir =~ m%[\]:]$%;
239             push(@dirs,$dir);
240         }
241         push(@dirs,'Sys$System:');
242         foreach my $dir (@dirs) {
243             my $sysfile = "$dir$file";
244             foreach my $ext (@exts) {
245                 return $file if -x "$sysfile$ext" && ! -d _;
246             }
247         }
248     }
249     return;
250 }
251
252 =item do_system
253
254 Override to ensure that we quote the arguments but not the command.
255
256 =cut
257
258 sub do_system {
259   # The command must not be quoted but the arguments to it must be.
260   my ($self, @cmd) = @_;
261   $self->log_verbose("@cmd\n");
262   my $cmd = shift @cmd;
263   my $args = $self->_quote_args(@cmd);
264   return !system("$cmd $args");
265 }
266
267 =item oneliner
268
269 Override to ensure that we do not quote the command.
270
271 =cut
272
273 sub oneliner {
274     my $self = shift;
275     my $oneliner = $self->SUPER::oneliner(@_);
276
277     $oneliner =~ s/^\"\S+\"//;
278
279     return "MCR $^X $oneliner";
280 }
281
282 =item rscan_dir
283
284 Inherit the standard version but remove dots at end of name.
285 If the extended character set is in effect, do not remove dots from filenames
286 with Unix path delimiters.
287
288 =cut
289
290 sub rscan_dir {
291   my ($self, $dir, $pattern) = @_;
292
293   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
294
295   for my $file (@$result) {
296       if (!_efs() && ($file =~ m#/#)) {
297           $file =~ s/\.$//;
298       }
299   }
300   return $result;
301 }
302
303 =item dist_dir
304
305 Inherit the standard version but replace embedded dots with underscores because
306 a dot is the directory delimiter on VMS.
307
308 =cut
309
310 sub dist_dir {
311   my $self = shift;
312
313   my $dist_dir = $self->SUPER::dist_dir;
314   $dist_dir =~ s/\./_/g unless _efs();
315   return $dist_dir;
316 }
317
318 =item man3page_name
319
320 Inherit the standard version but chop the extra manpage delimiter off the front if
321 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
322
323 =cut
324
325 sub man3page_name {
326   my $self = shift;
327
328   my $mpname = $self->SUPER::man3page_name( shift );
329   my $sep = $self->manpage_separator;
330   $mpname =~ s/^$sep//;
331   return $mpname;
332 }
333
334 =item expand_test_dir
335
336 Inherit the standard version but relativize the paths as the native glob() doesn't
337 do that for us.
338
339 =cut
340
341 sub expand_test_dir {
342   my ($self, $dir) = @_;
343
344   my @reldirs = $self->SUPER::expand_test_dir( $dir );
345
346   for my $eachdir (@reldirs) {
347     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
348     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
349     $eachdir = File::Spec->catfile( $reldir, $f );
350   }
351   return @reldirs;
352 }
353
354 =item _detildefy
355
356 The home-grown glob() does not currently handle tildes, so provide limited support
357 here.  Expect only UNIX format file specifications for now.
358
359 =cut
360
361 sub _detildefy {
362     my ($self, $arg) = @_;
363
364     # Apparently double ~ are not translated.
365     return $arg if ($arg =~ /^~~/);
366
367     # Apparently ~ followed by whitespace are not translated.
368     return $arg if ($arg =~ /^~ /);
369
370     if ($arg =~ /^~/) {
371         my $spec = $arg;
372
373         # Remove the tilde
374         $spec =~ s/^~//;
375
376         # Remove any slash following the tilde if present.
377         $spec =~ s#^/##;
378
379         # break up the paths for the merge
380         my $home = VMS::Filespec::unixify($ENV{HOME});
381
382         # In the default VMS mode, the trailing slash is present.
383         # In Unix report mode it is not.  The parsing logic assumes that
384         # it is present.
385         $home .= '/' unless $home =~ m#/$#;
386
387         # Trivial case of just ~ by it self
388         if ($spec eq '') {
389             $home =~ s#/$##;
390             return $home;
391         }
392
393         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
394         if ($hdir eq '') {
395              # Someone has tampered with $ENV{HOME}
396              # So hfile is probably the directory since this should be
397              # a path.
398              $hdir = $hfile;
399         }
400
401         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
402
403         my @hdirs = File::Spec::Unix->splitdir($hdir);
404         my @dirs = File::Spec::Unix->splitdir($dir);
405
406         unless ($arg =~ m#^~/#) {
407             # There is a home directory after the tilde, but it will already
408             # be present in in @hdirs so we need to remove it by from @dirs.
409
410             shift @dirs;
411         }
412         my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
413
414         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
415     }
416     return $arg;
417
418 }
419
420 =item find_perl_interpreter
421
422 On VMS, $^X returns the fully qualified absolute path including version
423 number.  It's logically impossible to improve on it for getting the perl
424 we're currently running, and attempting to manipulate it is usually
425 lossy.
426
427 =cut
428
429 sub find_perl_interpreter {
430     return VMS::Filespec::vmsify($^X);
431 }
432
433 =item localize_file_path
434
435 Convert the file path to the local syntax
436
437 =cut
438
439 sub localize_file_path {
440   my ($self, $path) = @_;
441   $path = VMS::Filespec::vmsify($path);
442   $path =~ s/\.\z//;
443   return $path;
444 }
445
446 =item localize_dir_path
447
448 Convert the directory path to the local syntax
449
450 =cut
451
452 sub localize_dir_path {
453   my ($self, $path) = @_;
454   return VMS::Filespec::vmspath($path);
455 }
456
457 =item ACTION_clean
458
459 The home-grown glob() expands a bit too aggressively when given a bare name,
460 so default in a zero-length extension.
461
462 =cut
463
464 sub ACTION_clean {
465   my ($self) = @_;
466   foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
467     $self->delete_filetree($item);
468   }
469 }
470
471
472 # Need to look up the feature settings.  The preferred way is to use the
473 # VMS::Feature module, but that may not be available to dual life modules.
474
475 my $use_feature;
476 BEGIN {
477     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
478         $use_feature = 1;
479     }
480 }
481
482 # Need to look up the UNIX report mode.  This may become a dynamic mode
483 # in the future.
484 sub _unix_rpt {
485     my $unix_rpt;
486     if ($use_feature) {
487         $unix_rpt = VMS::Feature::current("filename_unix_report");
488     } else {
489         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
490         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
491     }
492     return $unix_rpt;
493 }
494
495 # Need to look up the EFS character set mode.  This may become a dynamic
496 # mode in the future.
497 sub _efs {
498     my $efs;
499     if ($use_feature) {
500         $efs = VMS::Feature::current("efs_charset");
501     } else {
502         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
503         $efs = $env_efs =~ /^[ET1]/i;
504     }
505     return $efs;
506 }
507
508 =back
509
510 =head1 AUTHOR
511
512 Michael G Schwern <schwern@pobox.com>
513 Ken Williams <kwilliams@cpan.org>
514 Craig A. Berry <craigberry@mac.com>
515
516 =head1 SEE ALSO
517
518 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
519
520 =cut
521
522 1;
523 __END__