lib/Module/Build/Platform/VMS.pm

   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__