[Summary view] [Print] [Text view]

   1  package Module::Build::Platform::VMS;
   2  
   3  use strict;
   4  use vars qw($VERSION);
   5  $VERSION = '0.2808_01';
   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    map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
 140       ($got_arrayref ? @{$args[0]} 
 141                      : @args
 142       );
 143  
 144    return $got_arrayref ? $args[0] 
 145                         : join(' ', @args);
 146  }
 147  
 148  =item have_forkpipe
 149  
 150  There is no native fork(), so some constructs depending on it are not
 151  available.
 152  
 153  =cut
 154  
 155  sub have_forkpipe { 0 }
 156  
 157  =item _backticks
 158  
 159  Override to ensure that we quote the arguments but not the command.
 160  
 161  =cut
 162  
 163  sub _backticks {
 164    # The command must not be quoted but the arguments to it must be.
 165    my ($self, @cmd) = @_;
 166    my $cmd = shift @cmd;
 167    my $args = $self->_quote_args(@cmd);
 168    return `$cmd $args`;
 169  }
 170  
 171  =item do_system
 172  
 173  Override to ensure that we quote the arguments but not the command.
 174  
 175  =cut
 176  
 177  sub do_system {
 178    # The command must not be quoted but the arguments to it must be.
 179    my ($self, @cmd) = @_;
 180    $self->log_info("@cmd\n");
 181    my $cmd = shift @cmd;
 182    my $args = $self->_quote_args(@cmd);
 183    return !system("$cmd $args");
 184  }
 185  
 186  =item _infer_xs_spec
 187  
 188  Inherit the standard version but tweak the library file name to be 
 189  something Dynaloader can find.
 190  
 191  =cut
 192  
 193  sub _infer_xs_spec {
 194    my $self = shift;
 195    my $file = shift;
 196  
 197    my $spec = $self->SUPER::_infer_xs_spec($file);
 198  
 199    # Need to create with the same name as DynaLoader will load with.
 200    if (defined &DynaLoader::mod2fname) {
 201      my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
 202      $file =~ tr/:/_/;
 203      $file = DynaLoader::mod2fname([$file]);
 204      $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
 205    }
 206  
 207    return $spec;
 208  }
 209  
 210  =item rscan_dir
 211  
 212  Inherit the standard version but remove dots at end of name.  This may not be 
 213  necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
 214  
 215  =cut
 216  
 217  sub rscan_dir {
 218    my ($self, $dir, $pattern) = @_;
 219  
 220    my $result = $self->SUPER::rscan_dir( $dir, $pattern );
 221  
 222    for my $file (@$result) { $file =~ s/\.$//; }
 223    return $result;
 224  }
 225  
 226  =item dist_dir
 227  
 228  Inherit the standard version but replace embedded dots with underscores because 
 229  a dot is the directory delimiter on VMS.
 230  
 231  =cut
 232  
 233  sub dist_dir {
 234    my $self = shift;
 235  
 236    my $dist_dir = $self->SUPER::dist_dir;
 237    $dist_dir =~ s/\./_/g;
 238    return $dist_dir;
 239  }
 240  
 241  =item man3page_name
 242  
 243  Inherit the standard version but chop the extra manpage delimiter off the front if 
 244  there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
 245  
 246  =cut
 247  
 248  sub man3page_name {
 249    my $self = shift;
 250  
 251    my $mpname = $self->SUPER::man3page_name( shift );
 252    my $sep = $self->manpage_separator;
 253    $mpname =~ s/^$sep//;
 254    return $mpname;
 255  }
 256  
 257  =item expand_test_dir
 258  
 259  Inherit the standard version but relativize the paths as the native glob() doesn't
 260  do that for us.
 261  
 262  =cut
 263  
 264  sub expand_test_dir {
 265    my ($self, $dir) = @_;
 266  
 267    my @reldirs = $self->SUPER::expand_test_dir( $dir );
 268  
 269    for my $eachdir (@reldirs) {
 270      my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
 271      my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
 272      $eachdir = File::Spec->catfile( $reldir, $f );
 273    }
 274    return @reldirs;
 275  }
 276  
 277  =item _detildefy
 278  
 279  The home-grown glob() does not currently handle tildes, so provide limited support
 280  here.  Expect only UNIX format file specifications for now.
 281  
 282  =cut
 283  
 284  sub _detildefy {
 285      my ($self, $arg) = @_;
 286  
 287      # Apparently double ~ are not translated.
 288      return $arg if ($arg =~ /^~~/);
 289  
 290      # Apparently ~ followed by whitespace are not translated.
 291      return $arg if ($arg =~ /^~ /);
 292  
 293      if ($arg =~ /^~/) {
 294          my $spec = $arg;
 295  
 296          # Remove the tilde
 297          $spec =~ s/^~//;
 298  
 299          # Remove any slash folloing the tilde if present.
 300          $spec =~ s#^/##;
 301  
 302          # break up the paths for the merge
 303          my $home = VMS::Filespec::unixify($ENV{HOME});
 304  
 305          # Trivial case of just ~ by it self
 306          if ($spec eq '') {
 307              return $home;
 308          }
 309  
 310          my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
 311          if ($hdir eq '') {
 312               # Someone has tampered with $ENV{HOME}
 313               # So hfile is probably the directory since this should be
 314               # a path.
 315               $hdir = $hfile;
 316          }
 317  
 318          my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
 319  
 320          my @hdirs = File::Spec::Unix->splitdir($hdir);
 321          my @dirs = File::Spec::Unix->splitdir($dir);
 322  
 323          my $newdirs;
 324  
 325          # Two cases of tilde handling
 326          if ($arg =~ m#^~/#) {
 327  
 328              # Simple case, just merge together
 329              $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
 330  
 331          } else {
 332  
 333              # Complex case, need to add an updir - No delimiters
 334              my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
 335  
 336              $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
 337  
 338          }
 339          
 340          # Now put the two cases back together
 341          $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
 342  
 343      } else {
 344          return $arg;
 345      }
 346  
 347  }
 348  
 349  =item find_perl_interpreter
 350  
 351  On VMS, $^X returns the fully qualified absolute path including version
 352  number.  It's logically impossible to improve on it for getting the perl
 353  we're currently running, and attempting to manipulate it is usually
 354  lossy.
 355  
 356  =cut
 357  
 358  sub find_perl_interpreter { return $^X; }
 359  
 360  =back
 361  
 362  =head1 AUTHOR
 363  
 364  Michael G Schwern <schwern@pobox.com>
 365  Ken Williams <kwilliams@cpan.org>
 366  Craig A. Berry <craigberry@mac.com>
 367  
 368  =head1 SEE ALSO
 369  
 370  perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
 371  
 372  =cut
 373  
 374  1;
 375  __END__