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.4200
[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.4200';
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 _infer_xs_spec
283
284 Inherit the standard version but tweak the library file name to be
285 something Dynaloader can find.
286
287 =cut
288
289 sub _infer_xs_spec {
290   my $self = shift;
291   my $file = shift;
292
293   my $spec = $self->SUPER::_infer_xs_spec($file);
294
295   # Need to create with the same name as DynaLoader will load with.
296   if (defined &DynaLoader::mod2fname) {
297     my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
298     $file =~ tr/:/_/;
299     $file = DynaLoader::mod2fname([$file]);
300     $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
301   }
302
303   return $spec;
304 }
305
306 =item rscan_dir
307
308 Inherit the standard version but remove dots at end of name.
309 If the extended character set is in effect, do not remove dots from filenames
310 with Unix path delimiters.
311
312 =cut
313
314 sub rscan_dir {
315   my ($self, $dir, $pattern) = @_;
316
317   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
318
319   for my $file (@$result) {
320       if (!_efs() && ($file =~ m#/#)) {
321           $file =~ s/\.$//;
322       }
323   }
324   return $result;
325 }
326
327 =item dist_dir
328
329 Inherit the standard version but replace embedded dots with underscores because
330 a dot is the directory delimiter on VMS.
331
332 =cut
333
334 sub dist_dir {
335   my $self = shift;
336
337   my $dist_dir = $self->SUPER::dist_dir;
338   $dist_dir =~ s/\./_/g unless _efs();
339   return $dist_dir;
340 }
341
342 =item man3page_name
343
344 Inherit the standard version but chop the extra manpage delimiter off the front if
345 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
346
347 =cut
348
349 sub man3page_name {
350   my $self = shift;
351
352   my $mpname = $self->SUPER::man3page_name( shift );
353   my $sep = $self->manpage_separator;
354   $mpname =~ s/^$sep//;
355   return $mpname;
356 }
357
358 =item expand_test_dir
359
360 Inherit the standard version but relativize the paths as the native glob() doesn't
361 do that for us.
362
363 =cut
364
365 sub expand_test_dir {
366   my ($self, $dir) = @_;
367
368   my @reldirs = $self->SUPER::expand_test_dir( $dir );
369
370   for my $eachdir (@reldirs) {
371     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
372     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
373     $eachdir = File::Spec->catfile( $reldir, $f );
374   }
375   return @reldirs;
376 }
377
378 =item _detildefy
379
380 The home-grown glob() does not currently handle tildes, so provide limited support
381 here.  Expect only UNIX format file specifications for now.
382
383 =cut
384
385 sub _detildefy {
386     my ($self, $arg) = @_;
387
388     # Apparently double ~ are not translated.
389     return $arg if ($arg =~ /^~~/);
390
391     # Apparently ~ followed by whitespace are not translated.
392     return $arg if ($arg =~ /^~ /);
393
394     if ($arg =~ /^~/) {
395         my $spec = $arg;
396
397         # Remove the tilde
398         $spec =~ s/^~//;
399
400         # Remove any slash following the tilde if present.
401         $spec =~ s#^/##;
402
403         # break up the paths for the merge
404         my $home = VMS::Filespec::unixify($ENV{HOME});
405
406         # In the default VMS mode, the trailing slash is present.
407         # In Unix report mode it is not.  The parsing logic assumes that
408         # it is present.
409         $home .= '/' unless $home =~ m#/$#;
410
411         # Trivial case of just ~ by it self
412         if ($spec eq '') {
413             $home =~ s#/$##;
414             return $home;
415         }
416
417         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
418         if ($hdir eq '') {
419              # Someone has tampered with $ENV{HOME}
420              # So hfile is probably the directory since this should be
421              # a path.
422              $hdir = $hfile;
423         }
424
425         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
426
427         my @hdirs = File::Spec::Unix->splitdir($hdir);
428         my @dirs = File::Spec::Unix->splitdir($dir);
429
430         unless ($arg =~ m#^~/#) {
431             # There is a home directory after the tilde, but it will already
432             # be present in in @hdirs so we need to remove it by from @dirs.
433
434             shift @dirs;
435         }
436         my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
437
438         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
439     }
440     return $arg;
441
442 }
443
444 =item find_perl_interpreter
445
446 On VMS, $^X returns the fully qualified absolute path including version
447 number.  It's logically impossible to improve on it for getting the perl
448 we're currently running, and attempting to manipulate it is usually
449 lossy.
450
451 =cut
452
453 sub find_perl_interpreter {
454     return VMS::Filespec::vmsify($^X);
455 }
456
457 =item localize_file_path
458
459 Convert the file path to the local syntax
460
461 =cut
462
463 sub localize_file_path {
464   my ($self, $path) = @_;
465   $path = VMS::Filespec::vmsify($path);
466   $path =~ s/\.\z//;
467   return $path;
468 }
469
470 =item localize_dir_path
471
472 Convert the directory path to the local syntax
473
474 =cut
475
476 sub localize_dir_path {
477   my ($self, $path) = @_;
478   return VMS::Filespec::vmspath($path);
479 }
480
481 =item ACTION_clean
482
483 The home-grown glob() expands a bit too aggressively when given a bare name,
484 so default in a zero-length extension.
485
486 =cut
487
488 sub ACTION_clean {
489   my ($self) = @_;
490   foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
491     $self->delete_filetree($item);
492   }
493 }
494
495
496 # Need to look up the feature settings.  The preferred way is to use the
497 # VMS::Feature module, but that may not be available to dual life modules.
498
499 my $use_feature;
500 BEGIN {
501     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
502         $use_feature = 1;
503     }
504 }
505
506 # Need to look up the UNIX report mode.  This may become a dynamic mode
507 # in the future.
508 sub _unix_rpt {
509     my $unix_rpt;
510     if ($use_feature) {
511         $unix_rpt = VMS::Feature::current("filename_unix_report");
512     } else {
513         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
514         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
515     }
516     return $unix_rpt;
517 }
518
519 # Need to look up the EFS character set mode.  This may become a dynamic
520 # mode in the future.
521 sub _efs {
522     my $efs;
523     if ($use_feature) {
524         $efs = VMS::Feature::current("efs_charset");
525     } else {
526         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
527         $efs = $env_efs =~ /^[ET1]/i;
528     }
529     return $efs;
530 }
531
532 =back
533
534 =head1 AUTHOR
535
536 Michael G Schwern <schwern@pobox.com>
537 Ken Williams <kwilliams@cpan.org>
538 Craig A. Berry <craigberry@mac.com>
539
540 =head1 SEE ALSO
541
542 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
543
544 =cut
545
546 1;
547 __END__