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 =back
 347
 348 =head1 AUTHOR
 349
 350 Michael G Schwern <schwern@pobox.com>
 351 Ken Williams <kwilliams@cpan.org>
 352 Craig A. Berry <craigberry@mac.com>
 353
 354 =head1 SEE ALSO
 355
 356 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
 357
 358 =cut
 359
 360 1;
 361 __END__