lib/Module/Build/Platform/VMS.pm

   1 package Module::Build::Platform::VMS;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5 $VERSION = '0.30';
   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 _infer_xs_spec
 192
 193 Inherit the standard version but tweak the library file name to be
 194 something Dynaloader can find.
 195
 196 =cut
 197
 198 sub _infer_xs_spec {
 199   my $self = shift;
 200   my $file = shift;
 201
 202   my $spec = $self->SUPER::_infer_xs_spec($file);
 203
 204   # Need to create with the same name as DynaLoader will load with.
 205   if (defined &DynaLoader::mod2fname) {
 206     my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
 207     $file =~ tr/:/_/;
 208     $file = DynaLoader::mod2fname([$file]);
 209     $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
 210   }
 211
 212   return $spec;
 213 }
 214
 215 =item rscan_dir
 216
 217 Inherit the standard version but remove dots at end of name.  This may not be
 218 necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
 219
 220 =cut
 221
 222 sub rscan_dir {
 223   my ($self, $dir, $pattern) = @_;
 224
 225   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
 226
 227   for my $file (@$result) { $file =~ s/\.$//; }
 228   return $result;
 229 }
 230
 231 =item dist_dir
 232
 233 Inherit the standard version but replace embedded dots with underscores because
 234 a dot is the directory delimiter on VMS.
 235
 236 =cut
 237
 238 sub dist_dir {
 239   my $self = shift;
 240
 241   my $dist_dir = $self->SUPER::dist_dir;
 242   $dist_dir =~ s/\./_/g;
 243   return $dist_dir;
 244 }
 245
 246 =item man3page_name
 247
 248 Inherit the standard version but chop the extra manpage delimiter off the front if
 249 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
 250
 251 =cut
 252
 253 sub man3page_name {
 254   my $self = shift;
 255
 256   my $mpname = $self->SUPER::man3page_name( shift );
 257   my $sep = $self->manpage_separator;
 258   $mpname =~ s/^$sep//;
 259   return $mpname;
 260 }
 261
 262 =item expand_test_dir
 263
 264 Inherit the standard version but relativize the paths as the native glob() doesn't
 265 do that for us.
 266
 267 =cut
 268
 269 sub expand_test_dir {
 270   my ($self, $dir) = @_;
 271
 272   my @reldirs = $self->SUPER::expand_test_dir( $dir );
 273
 274   for my $eachdir (@reldirs) {
 275     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
 276     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
 277     $eachdir = File::Spec->catfile( $reldir, $f );
 278   }
 279   return @reldirs;
 280 }
 281
 282 =item _detildefy
 283
 284 The home-grown glob() does not currently handle tildes, so provide limited support
 285 here.  Expect only UNIX format file specifications for now.
 286
 287 =cut
 288
 289 sub _detildefy {
 290     my ($self, $arg) = @_;
 291
 292     # Apparently double ~ are not translated.
 293     return $arg if ($arg =~ /^~~/);
 294
 295     # Apparently ~ followed by whitespace are not translated.
 296     return $arg if ($arg =~ /^~ /);
 297
 298     if ($arg =~ /^~/) {
 299         my $spec = $arg;
 300
 301         # Remove the tilde
 302         $spec =~ s/^~//;
 303
 304         # Remove any slash folloing the tilde if present.
 305         $spec =~ s#^/##;
 306
 307         # break up the paths for the merge
 308         my $home = VMS::Filespec::unixify($ENV{HOME});
 309
 310         # Trivial case of just ~ by it self
 311         if ($spec eq '') {
 312             return $home;
 313         }
 314
 315         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
 316         if ($hdir eq '') {
 317              # Someone has tampered with $ENV{HOME}
 318              # So hfile is probably the directory since this should be
 319              # a path.
 320              $hdir = $hfile;
 321         }
 322
 323         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
 324
 325         my @hdirs = File::Spec::Unix->splitdir($hdir);
 326         my @dirs = File::Spec::Unix->splitdir($dir);
 327
 328         my $newdirs;
 329
 330         # Two cases of tilde handling
 331         if ($arg =~ m#^~/#) {
 332
 333             # Simple case, just merge together
 334             $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
 335
 336         } else {
 337
 338             # Complex case, need to add an updir - No delimiters
 339             my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
 340
 341             $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
 342
 343         }
 344
 345         # Now put the two cases back together
 346         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
 347
 348     } else {
 349         return $arg;
 350     }
 351
 352 }
 353
 354 =item find_perl_interpreter
 355
 356 On VMS, $^X returns the fully qualified absolute path including version
 357 number.  It's logically impossible to improve on it for getting the perl
 358 we're currently running, and attempting to manipulate it is usually
 359 lossy.
 360
 361 =cut
 362
 363 sub find_perl_interpreter { return $^X; }
 364
 365 =item localize_file_path
 366
 367 Convert the file path to the local syntax
 368
 369 =cut
 370
 371 sub localize_file_path {
 372   my ($self, $path) = @_;
 373   $path =~ s/\.\z//;
 374   return VMS::Filespec::vmsify($path);
 375 }
 376
 377 =item localize_dir_path
 378
 379 Convert the directory path to the local syntax
 380
 381 =cut
 382
 383 sub localize_dir_path {
 384   my ($self, $path) = @_;
 385   return VMS::Filespec::vmspath($path);
 386 }
 387
 388 =back
 389
 390 =head1 AUTHOR
 391
 392 Michael G Schwern <schwern@pobox.com>
 393 Ken Williams <kwilliams@cpan.org>
 394 Craig A. Berry <craigberry@mac.com>
 395
 396 =head1 SEE ALSO
 397
 398 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
 399
 400 =cut
 401
 402 1;
 403 __END__