lib/Module/Build/Platform/VMS.pm

   1 package Module::Build::Platform::VMS;
   2
   3 use strict;
   4 use Module::Build::Base;
   5
   6 use vars qw(@ISA);
   7 @ISA = qw(Module::Build::Base);
   8
   9
  10
  11 =head1 NAME
  12
  13 Module::Build::Platform::VMS - Builder class for VMS platforms
  14
  15 =head1 DESCRIPTION
  16
  17 This module inherits from C<Module::Build::Base> and alters a few
  18 minor details of its functionality.  Please see L<Module::Build> for
  19 the general docs.
  20
  21 =head2 Overridden Methods
  22
  23 =over 4
  24
  25 =item _set_defaults
  26
  27 Change $self->{build_script} to 'Build.com' so @Build works.
  28
  29 =cut
  30
  31 sub _set_defaults {
  32     my $self = shift;
  33     $self->SUPER::_set_defaults(@_);
  34
  35     $self->{properties}{build_script} = 'Build.com';
  36 }
  37
  38
  39 =item cull_args
  40
  41 '@Build foo' on VMS will not preserve the case of 'foo'.  Rather than forcing
  42 people to write '@Build "foo"' we'll dispatch case-insensitively.
  43
  44 =cut
  45
  46 sub cull_args {
  47     my $self = shift;
  48     my($action, $args) = $self->SUPER::cull_args(@_);
  49     my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
  50
  51     die "Ambiguous action '$action'.  Could be one of @possible_actions"
  52         if @possible_actions > 1;
  53
  54     return ($possible_actions[0], $args);
  55 }
  56
  57
  58 =item manpage_separator
  59
  60 Use '__' instead of '::'.
  61
  62 =cut
  63
  64 sub manpage_separator {
  65     return '__';
  66 }
  67
  68
  69 =item prefixify
  70
  71 Prefixify taking into account VMS' filepath syntax.
  72
  73 =cut
  74
  75 # Translated from ExtUtils::MM_VMS::prefixify()
  76 sub _prefixify {
  77     my($self, $path, $sprefix, $type) = @_;
  78     my $rprefix = $self->prefix;
  79
  80     $self->log_verbose("  prefixify $path from $sprefix to $rprefix\n");
  81
  82     # Translate $(PERLPREFIX) to a real path.
  83     $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
  84     $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
  85
  86     $self->log_verbose("  rprefix translated to $rprefix\n".
  87                        "  sprefix translated to $sprefix\n");
  88
  89     if( length $path == 0 ) {
  90         $self->log_verbose("  no path to prefixify.\n")
  91     }
  92     elsif( !File::Spec->file_name_is_absolute($path) ) {
  93         $self->log_verbose("    path is relative, not prefixifying.\n");
  94     }
  95     elsif( $sprefix eq $rprefix ) {
  96         $self->log_verbose("  no new prefix.\n");
  97     }
  98     else {
  99         my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
 100         my $vms_prefix = $self->config('vms_prefix');
 101         if( $path_vol eq $vms_prefix.':' ) {
 102             $self->log_verbose("  $vms_prefix: seen\n");
 103
 104             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
 105             $path = $self->_catprefix($rprefix, $path_dirs);
 106         }
 107         else {
 108             $self->log_verbose("    cannot prefixify.\n");
 109             return $self->prefix_relpaths($self->installdirs, $type);
 110         }
 111     }
 112
 113     $self->log_verbose("    now $path\n");
 114
 115     return $path;
 116 }
 117
 118 =item _quote_args
 119
 120 Command-line arguments (but not the command itself) must be quoted
 121 to ensure case preservation.
 122
 123 =cut
 124
 125 sub _quote_args {
 126   # Returns a string that can become [part of] a command line with
 127   # proper quoting so that the subprocess sees this same list of args,
 128   # or if we get a single arg that is an array reference, quote the
 129   # elements of it and return the reference.
 130   my ($self, @args) = @_;
 131   my $got_arrayref = (scalar(@args) == 1
 132                       && UNIVERSAL::isa($args[0], 'ARRAY'))
 133                    ? 1
 134                    : 0;
 135
 136   map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
 137      ($got_arrayref ? @{$args[0]}
 138                     : @args
 139      );
 140
 141   return $got_arrayref ? $args[0]
 142                        : join(' ', @args);
 143 }
 144
 145 =item have_forkpipe
 146
 147 There is no native fork(), so some constructs depending on it are not
 148 available.
 149
 150 =cut
 151
 152 sub have_forkpipe { 0 }
 153
 154 =item _backticks
 155
 156 Override to ensure that we quote the arguments but not the command.
 157
 158 =cut
 159
 160 sub _backticks {
 161   # The command must not be quoted but the arguments to it must be.
 162   my ($self, @cmd) = @_;
 163   my $cmd = shift @cmd;
 164   my $args = $self->_quote_args(@cmd);
 165   return `$cmd $args`;
 166 }
 167
 168 =item do_system
 169
 170 Override to ensure that we quote the arguments but not the command.
 171
 172 =cut
 173
 174 sub do_system {
 175   # The command must not be quoted but the arguments to it must be.
 176   my ($self, @cmd) = @_;
 177   $self->log_info("@cmd\n");
 178   my $cmd = shift @cmd;
 179   my $args = $self->_quote_args(@cmd);
 180   return !system("$cmd $args");
 181 }
 182
 183 =item _infer_xs_spec
 184
 185 Inherit the standard version but tweak the library file name to be
 186 something Dynaloader can find.
 187
 188 =cut
 189
 190 sub _infer_xs_spec {
 191   my $self = shift;
 192   my $file = shift;
 193
 194   my $spec = $self->SUPER::_infer_xs_spec($file);
 195
 196   # Need to create with the same name as DynaLoader will load with.
 197   if (defined &DynaLoader::mod2fname) {
 198     my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
 199     $file =~ tr/:/_/;
 200     $file = DynaLoader::mod2fname([$file]);
 201     $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
 202   }
 203
 204   return $spec;
 205 }
 206
 207 =item rscan_dir
 208
 209 Inherit the standard version but remove dots at end of name.  This may not be
 210 necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
 211
 212 =cut
 213
 214 sub rscan_dir {
 215   my ($self, $dir, $pattern) = @_;
 216
 217   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
 218
 219   for my $file (@$result) { $file =~ s/\.$//; }
 220   return $result;
 221 }
 222
 223 =item dist_dir
 224
 225 Inherit the standard version but replace embedded dots with underscores because
 226 a dot is the directory delimiter on VMS.
 227
 228 =cut
 229
 230 sub dist_dir {
 231   my $self = shift;
 232
 233   my $dist_dir = $self->SUPER::dist_dir;
 234   $dist_dir =~ s/\./_/g;
 235   return $dist_dir;
 236 }
 237
 238 =item man3page_name
 239
 240 Inherit the standard version but chop the extra manpage delimiter off the front if
 241 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
 242
 243 =cut
 244
 245 sub man3page_name {
 246   my $self = shift;
 247
 248   my $mpname = $self->SUPER::man3page_name( shift );
 249   my $sep = $self->manpage_separator;
 250   $mpname =~ s/^$sep//;
 251   return $mpname;
 252 }
 253
 254 =item expand_test_dir
 255
 256 Inherit the standard version but relativize the paths as the native glob() doesn't
 257 do that for us.
 258
 259 =cut
 260
 261 sub expand_test_dir {
 262   my ($self, $dir) = @_;
 263
 264   my @reldirs = $self->SUPER::expand_test_dir( $dir );
 265
 266   for my $eachdir (@reldirs) {
 267     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
 268     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
 269     $eachdir = File::Spec->catfile( $reldir, $f );
 270   }
 271   return @reldirs;
 272 }
 273
 274 =item _detildefy
 275
 276 The home-grown glob() does not currently handle tildes, so provide limited support
 277 here.  Expect only UNIX format file specifications for now.
 278
 279 =cut
 280
 281 sub _detildefy {
 282     my ($self, $arg) = @_;
 283
 284     # Apparently double ~ are not translated.
 285     return $arg if ($arg =~ /^~~/);
 286
 287     # Apparently ~ followed by whitespace are not translated.
 288     return $arg if ($arg =~ /^~ /);
 289
 290     if ($arg =~ /^~/) {
 291         my $spec = $arg;
 292
 293         # Remove the tilde
 294         $spec =~ s/^~//;
 295
 296         # Remove any slash folloing the tilde if present.
 297         $spec =~ s#^/##;
 298
 299         # break up the paths for the merge
 300         my $home = VMS::Filespec::unixify($ENV{HOME});
 301
 302         # Trivial case of just ~ by it self
 303         if ($spec eq '') {
 304             return $home;
 305         }
 306
 307         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
 308         if ($hdir eq '') {
 309              # Someone has tampered with $ENV{HOME}
 310              # So hfile is probably the directory since this should be
 311              # a path.
 312              $hdir = $hfile;
 313         }
 314
 315         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
 316
 317         my @hdirs = File::Spec::Unix->splitdir($hdir);
 318         my @dirs = File::Spec::Unix->splitdir($dir);
 319
 320         my $newdirs;
 321
 322         # Two cases of tilde handling
 323         if ($arg =~ m#^~/#) {
 324
 325             # Simple case, just merge together
 326             $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
 327
 328         } else {
 329
 330             # Complex case, need to add an updir - No delimiters
 331             my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
 332
 333             $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
 334
 335         }
 336
 337         # Now put the two cases back together
 338         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
 339
 340     } else {
 341         return $arg;
 342     }
 343
 344 }
 345
 346 =item find_perl_interpreter
 347
 348 On VMS, $^X returns the fully qualified absolute path including version number.
 349 It's logically impossible to improve on it for getting the perl we're currently
 350 running, and attempting to manipulate it is usually lossy.
 351
 352 =cut
 353
 354 sub find_perl_interpreter { return $^X; }
 355
 356 =back
 357
 358 =head1 AUTHOR
 359
 360 Michael G Schwern <schwern@pobox.com>
 361 Ken Williams <kwilliams@cpan.org>
 362 Craig A. Berry <craigberry@mac.com>
 363
 364 =head1 SEE ALSO
 365
 366 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
 367
 368 =cut
 369
 370 1;
 371 __END__