local-lib5/lib/perl5/Module/Build/Platform/VMS.pm

   1 package Module::Build::Platform::VMS;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5 $VERSION = '0.35';
   6 $VERSION = eval $VERSION;
   7 use Module::Build::Base;
   8
   9 use vars qw(@ISA);
  10 @ISA = qw(Module::Build::Base);
  11
  12
  13
  14 =head1 NAME
  15
  16 Module::Build::Platform::VMS - Builder class for VMS platforms
  17
  18 =head1 DESCRIPTION
  19
  20 This module inherits from C<Module::Build::Base> and alters a few
  21 minor details of its functionality.  Please see L<Module::Build> for
  22 the general docs.
  23
  24 =head2 Overridden Methods
  25
  26 =over 4
  27
  28 =item _set_defaults
  29
  30 Change $self->{build_script} to 'Build.com' so @Build works.
  31
  32 =cut
  33
  34 sub _set_defaults {
  35     my $self = shift;
  36     $self->SUPER::_set_defaults(@_);
  37
  38     $self->{properties}{build_script} = 'Build.com';
  39 }
  40
  41
  42 =item cull_args
  43
  44 '@Build foo' on VMS will not preserve the case of 'foo'.  Rather than forcing
  45 people to write '@Build "foo"' we'll dispatch case-insensitively.
  46
  47 =cut
  48
  49 sub 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
  63 Use '__' instead of '::'.
  64
  65 =cut
  66
  67 sub manpage_separator {
  68     return '__';
  69 }
  70
  71
  72 =item prefixify
  73
  74 Prefixify taking into account VMS' filepath syntax.
  75
  76 =cut
  77
  78 # Translated from ExtUtils::MM_VMS::prefixify()
  79 sub _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.
  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 );
 103         my $vms_prefix = $self->config('vms_prefix');
 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
 121 =item _quote_args
 122
 123 Command-line arguments (but not the command itself) must be quoted
 124 to ensure case preservation.
 125
 126 =cut
 127
 128 sub _quote_args {
 129   # Returns a string that can become [part of] a command line with
 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.
 133   my ($self, @args) = @_;
 134   my $got_arrayref = (scalar(@args) == 1
 135                       && UNIVERSAL::isa($args[0], 'ARRAY'))
 136                    ? 1
 137                    : 0;
 138
 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     );
 148
 149   return $got_arrayref ? $args[0]
 150                        : join(' ', @args);
 151 }
 152
 153 =item have_forkpipe
 154
 155 There is no native fork(), so some constructs depending on it are not
 156 available.
 157
 158 =cut
 159
 160 sub have_forkpipe { 0 }
 161
 162 =item _backticks
 163
 164 Override to ensure that we quote the arguments but not the command.
 165
 166 =cut
 167
 168 sub _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
 178 Override to ensure that we quote the arguments but not the command.
 179
 180 =cut
 181
 182 sub 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 oneliner
 192
 193 Override to ensure that we do not quote the command.
 194
 195 =cut
 196
 197 sub oneliner {
 198     my $self = shift;
 199     my $oneliner = $self->SUPER::oneliner(@_);
 200
 201     $oneliner =~ s/^\"\S+\"//;
 202
 203     return "MCR $^X $oneliner";
 204 }
 205
 206 =item _infer_xs_spec
 207
 208 Inherit the standard version but tweak the library file name to be
 209 something Dynaloader can find.
 210
 211 =cut
 212
 213 sub _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) {
 221     my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
 222     $file =~ tr/:/_/;
 223     $file = DynaLoader::mod2fname([$file]);
 224     $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
 225   }
 226
 227   return $spec;
 228 }
 229
 230 =item rscan_dir
 231
 232 Inherit the standard version but remove dots at end of name.
 233 If the extended character set is in effect, do not remove dots from filenames
 234 with Unix path delimiters.
 235
 236 =cut
 237
 238 sub rscan_dir {
 239   my ($self, $dir, $pattern) = @_;
 240
 241   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
 242
 243   for my $file (@$result) {
 244       if (!_efs() && ($file =~ m#/#)) {
 245           $file =~ s/\.$//;
 246       }
 247   }
 248   return $result;
 249 }
 250
 251 =item dist_dir
 252
 253 Inherit the standard version but replace embedded dots with underscores because
 254 a dot is the directory delimiter on VMS.
 255
 256 =cut
 257
 258 sub dist_dir {
 259   my $self = shift;
 260
 261   my $dist_dir = $self->SUPER::dist_dir;
 262   $dist_dir =~ s/\./_/g unless _efs();
 263   return $dist_dir;
 264 }
 265
 266 =item man3page_name
 267
 268 Inherit the standard version but chop the extra manpage delimiter off the front if
 269 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
 270
 271 =cut
 272
 273 sub man3page_name {
 274   my $self = shift;
 275
 276   my $mpname = $self->SUPER::man3page_name( shift );
 277   my $sep = $self->manpage_separator;
 278   $mpname =~ s/^$sep//;
 279   return $mpname;
 280 }
 281
 282 =item expand_test_dir
 283
 284 Inherit the standard version but relativize the paths as the native glob() doesn't
 285 do that for us.
 286
 287 =cut
 288
 289 sub expand_test_dir {
 290   my ($self, $dir) = @_;
 291
 292   my @reldirs = $self->SUPER::expand_test_dir( $dir );
 293
 294   for my $eachdir (@reldirs) {
 295     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
 296     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
 297     $eachdir = File::Spec->catfile( $reldir, $f );
 298   }
 299   return @reldirs;
 300 }
 301
 302 =item _detildefy
 303
 304 The home-grown glob() does not currently handle tildes, so provide limited support
 305 here.  Expect only UNIX format file specifications for now.
 306
 307 =cut
 308
 309 sub _detildefy {
 310     my ($self, $arg) = @_;
 311
 312     # Apparently double ~ are not translated.
 313     return $arg if ($arg =~ /^~~/);
 314
 315     # Apparently ~ followed by whitespace are not translated.
 316     return $arg if ($arg =~ /^~ /);
 317
 318     if ($arg =~ /^~/) {
 319         my $spec = $arg;
 320
 321         # Remove the tilde
 322         $spec =~ s/^~//;
 323
 324         # Remove any slash following the tilde if present.
 325         $spec =~ s#^/##;
 326
 327         # break up the paths for the merge
 328         my $home = VMS::Filespec::unixify($ENV{HOME});
 329
 330         # In the default VMS mode, the trailing slash is present.
 331         # In Unix report mode it is not.  The parsing logic assumes that
 332         # it is present.
 333         $home .= '/' unless $home =~ m#/$#;
 334
 335         # Trivial case of just ~ by it self
 336         if ($spec eq '') {
 337             $home =~ s#/$##;
 338             return $home;
 339         }
 340
 341         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
 342         if ($hdir eq '') {
 343              # Someone has tampered with $ENV{HOME}
 344              # So hfile is probably the directory since this should be
 345              # a path.
 346              $hdir = $hfile;
 347         }
 348
 349         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
 350
 351         my @hdirs = File::Spec::Unix->splitdir($hdir);
 352         my @dirs = File::Spec::Unix->splitdir($dir);
 353
 354         my $newdirs;
 355
 356         # Two cases of tilde handling
 357         if ($arg =~ m#^~/#) {
 358
 359             # Simple case, just merge together
 360             $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
 361
 362         } else {
 363
 364             # Complex case, need to add an updir - No delimiters
 365             my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
 366
 367             $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
 368
 369         }
 370
 371         # Now put the two cases back together
 372         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
 373
 374     }
 375     return $arg;
 376
 377 }
 378
 379 =item find_perl_interpreter
 380
 381 On VMS, $^X returns the fully qualified absolute path including version
 382 number.  It's logically impossible to improve on it for getting the perl
 383 we're currently running, and attempting to manipulate it is usually
 384 lossy.
 385
 386 =cut
 387
 388 sub find_perl_interpreter {
 389     return VMS::Filespec::vmsify($^X);
 390 }
 391
 392 =item localize_file_path
 393
 394 Convert the file path to the local syntax
 395
 396 =cut
 397
 398 sub localize_file_path {
 399   my ($self, $path) = @_;
 400   $path = VMS::Filespec::vmsify($path);
 401   $path =~ s/\.\z//;
 402   return $path;
 403 }
 404
 405 =item localize_dir_path
 406
 407 Convert the directory path to the local syntax
 408
 409 =cut
 410
 411 sub localize_dir_path {
 412   my ($self, $path) = @_;
 413   return VMS::Filespec::vmspath($path);
 414 }
 415
 416 =item ACTION_clean
 417
 418 The home-grown glob() expands a bit too aggressively when given a bare name,
 419 so default in a zero-length extension.
 420
 421 =cut
 422
 423 sub ACTION_clean {
 424   my ($self) = @_;
 425   foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
 426     $self->delete_filetree($item);
 427   }
 428 }
 429
 430
 431 # Need to look up the feature settings.  The preferred way is to use the
 432 # VMS::Feature module, but that may not be available to dual life modules.
 433
 434 my $use_feature;
 435 BEGIN {
 436     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
 437         $use_feature = 1;
 438     }
 439 }
 440
 441 # Need to look up the UNIX report mode.  This may become a dynamic mode
 442 # in the future.
 443 sub _unix_rpt {
 444     my $unix_rpt;
 445     if ($use_feature) {
 446         $unix_rpt = VMS::Feature::current("filename_unix_report");
 447     } else {
 448         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
 449         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
 450     }
 451     return $unix_rpt;
 452 }
 453
 454 # Need to look up the EFS character set mode.  This may become a dynamic
 455 # mode in the future.
 456 sub _efs {
 457     my $efs;
 458     if ($use_feature) {
 459         $efs = VMS::Feature::current("efs_charset");
 460     } else {
 461         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
 462         $efs = $env_efs =~ /^[ET1]/i;
 463     }
 464     return $efs;
 465 }
 466
 467 =back
 468
 469 =head1 AUTHOR
 470
 471 Michael G Schwern <schwern@pobox.com>
 472 Ken Williams <kwilliams@cpan.org>
 473 Craig A. Berry <craigberry@mac.com>
 474
 475 =head1 SEE ALSO
 476
 477 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
 478
 479 =cut
 480
 481 1;
 482 __END__