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.3607';
   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         my $newdirs;
 431
 432         # Two cases of tilde handling
 433         if ($arg =~ m#^~/#) {
 434
 435             # Simple case, just merge together
 436             $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
 437
 438         } else {
 439
 440             # Complex case, need to add an updir - No delimiters
 441             my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
 442
 443             $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
 444
 445         }
 446
 447         # Now put the two cases back together
 448         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
 449
 450     }
 451     return $arg;
 452
 453 }
 454
 455 =item find_perl_interpreter
 456
 457 On VMS, $^X returns the fully qualified absolute path including version
 458 number.  It's logically impossible to improve on it for getting the perl
 459 we're currently running, and attempting to manipulate it is usually
 460 lossy.
 461
 462 =cut
 463
 464 sub find_perl_interpreter {
 465     return VMS::Filespec::vmsify($^X);
 466 }
 467
 468 =item localize_file_path
 469
 470 Convert the file path to the local syntax
 471
 472 =cut
 473
 474 sub localize_file_path {
 475   my ($self, $path) = @_;
 476   $path = VMS::Filespec::vmsify($path);
 477   $path =~ s/\.\z//;
 478   return $path;
 479 }
 480
 481 =item localize_dir_path
 482
 483 Convert the directory path to the local syntax
 484
 485 =cut
 486
 487 sub localize_dir_path {
 488   my ($self, $path) = @_;
 489   return VMS::Filespec::vmspath($path);
 490 }
 491
 492 =item ACTION_clean
 493
 494 The home-grown glob() expands a bit too aggressively when given a bare name,
 495 so default in a zero-length extension.
 496
 497 =cut
 498
 499 sub ACTION_clean {
 500   my ($self) = @_;
 501   foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
 502     $self->delete_filetree($item);
 503   }
 504 }
 505
 506
 507 # Need to look up the feature settings.  The preferred way is to use the
 508 # VMS::Feature module, but that may not be available to dual life modules.
 509
 510 my $use_feature;
 511 BEGIN {
 512     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
 513         $use_feature = 1;
 514     }
 515 }
 516
 517 # Need to look up the UNIX report mode.  This may become a dynamic mode
 518 # in the future.
 519 sub _unix_rpt {
 520     my $unix_rpt;
 521     if ($use_feature) {
 522         $unix_rpt = VMS::Feature::current("filename_unix_report");
 523     } else {
 524         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
 525         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
 526     }
 527     return $unix_rpt;
 528 }
 529
 530 # Need to look up the EFS character set mode.  This may become a dynamic
 531 # mode in the future.
 532 sub _efs {
 533     my $efs;
 534     if ($use_feature) {
 535         $efs = VMS::Feature::current("efs_charset");
 536     } else {
 537         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
 538         $efs = $env_efs =~ /^[ET1]/i;
 539     }
 540     return $efs;
 541 }
 542
 543 =back
 544
 545 =head1 AUTHOR
 546
 547 Michael G Schwern <schwern@pobox.com>
 548 Ken Williams <kwilliams@cpan.org>
 549 Craig A. Berry <craigberry@mac.com>
 550
 551 =head1 SEE ALSO
 552
 553 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
 554
 555 =cut
 556
 557 1;
 558 __END__