1package Module::Build::Platform::VMS; 2 3use strict; 4use warnings; 5our $VERSION = '0.4231'; 6$VERSION = eval $VERSION; 7use Module::Build::Base; 8use Config; 9 10our @ISA = qw(Module::Build::Base); 11 12 13 14=head1 NAME 15 16Module::Build::Platform::VMS - Builder class for VMS platforms 17 18=head1 DESCRIPTION 19 20This module inherits from C<Module::Build::Base> and alters a few 21minor details of its functionality. Please see L<Module::Build> for 22the general docs. 23 24=head2 Overridden Methods 25 26=over 4 27 28=item _set_defaults 29 30Change $self->{build_script} to 'Build.com' so @Build works. 31 32=cut 33 34sub _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 45people to write '@Build "foo"' we'll dispatch case-insensitively. 46 47=cut 48 49sub 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 63Use '__' instead of '::'. 64 65=cut 66 67sub manpage_separator { 68 return '__'; 69} 70 71 72=item prefixify 73 74Prefixify taking into account VMS' filepath syntax. 75 76=cut 77 78# Translated from ExtUtils::MM_VMS::prefixify() 79 80sub _catprefix { 81 my($self, $rprefix, $default) = @_; 82 83 my($rvol, $rdirs) = File::Spec->splitpath($rprefix); 84 if( $rvol ) { 85 return File::Spec->catpath($rvol, 86 File::Spec->catdir($rdirs, $default), 87 '' 88 ) 89 } 90 else { 91 return File::Spec->catdir($rdirs, $default); 92 } 93} 94 95 96sub _prefixify { 97 my($self, $path, $sprefix, $type) = @_; 98 my $rprefix = $self->prefix; 99 100 return '' unless defined $path; 101 102 $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n"); 103 104 # Translate $(PERLPREFIX) to a real path. 105 $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix; 106 $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix; 107 108 $self->log_verbose(" rprefix translated to $rprefix\n". 109 " sprefix translated to $sprefix\n"); 110 111 if( length($path) == 0 ) { 112 $self->log_verbose(" no path to prefixify.\n") 113 } 114 elsif( !File::Spec->file_name_is_absolute($path) ) { 115 $self->log_verbose(" path is relative, not prefixifying.\n"); 116 } 117 elsif( $sprefix eq $rprefix ) { 118 $self->log_verbose(" no new prefix.\n"); 119 } 120 else { 121 my($path_vol, $path_dirs) = File::Spec->splitpath( $path ); 122 my $vms_prefix = $self->config('vms_prefix'); 123 if( $path_vol eq $vms_prefix.':' ) { 124 $self->log_verbose(" $vms_prefix: seen\n"); 125 126 $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; 127 $path = $self->_catprefix($rprefix, $path_dirs); 128 } 129 else { 130 $self->log_verbose(" cannot prefixify.\n"); 131 return $self->prefix_relpaths($self->installdirs, $type); 132 } 133 } 134 135 $self->log_verbose(" now $path\n"); 136 137 return $path; 138} 139 140=item _quote_args 141 142Command-line arguments (but not the command itself) must be quoted 143to ensure case preservation. 144 145=cut 146 147sub _quote_args { 148 # Returns a string that can become [part of] a command line with 149 # proper quoting so that the subprocess sees this same list of args, 150 # or if we get a single arg that is an array reference, quote the 151 # elements of it and return the reference. 152 my ($self, @args) = @_; 153 my $got_arrayref = (scalar(@args) == 1 154 && ref $args[0] eq 'ARRAY') 155 ? 1 156 : 0; 157 158 # Do not quote qualifiers that begin with '/'. 159 map { if (!/^\//) { 160 $_ =~ s/\"/""/g; # escape C<"> by doubling 161 $_ = q(").$_.q("); 162 } 163 } 164 ($got_arrayref ? @{$args[0]} 165 : @args 166 ); 167 168 return $got_arrayref ? $args[0] 169 : join(' ', @args); 170} 171 172=item have_forkpipe 173 174There is no native fork(), so some constructs depending on it are not 175available. 176 177=cut 178 179sub have_forkpipe { 0 } 180 181=item _backticks 182 183Override to ensure that we quote the arguments but not the command. 184 185=cut 186 187sub _backticks { 188 # The command must not be quoted but the arguments to it must be. 189 my ($self, @cmd) = @_; 190 my $cmd = shift @cmd; 191 my $args = $self->_quote_args(@cmd); 192 return `$cmd $args`; 193} 194 195=item find_command 196 197Local an executable program 198 199=cut 200 201sub find_command { 202 my ($self, $command) = @_; 203 204 # a lot of VMS executables have a symbol defined 205 # check those first 206 if ( $^O eq 'VMS' ) { 207 require VMS::DCLsym; 208 my $syms = VMS::DCLsym->new; 209 return $command if scalar $syms->getsym( uc $command ); 210 } 211 212 $self->SUPER::find_command($command); 213} 214 215# _maybe_command copied from ExtUtils::MM_VMS::maybe_command 216 217=item _maybe_command (override) 218 219Follows VMS naming conventions for executable files. 220If the name passed in doesn't exactly match an executable file, 221appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> 222to check for DCL procedure. If this fails, checks directories in DCL$PATH 223and finally F<Sys$System:> for an executable file having the name specified, 224with or without the F<.Exe>-equivalent suffix. 225 226=cut 227 228sub _maybe_command { 229 my($self,$file) = @_; 230 return $file if -x $file && ! -d _; 231 my(@dirs) = (''); 232 my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); 233 234 if ($file !~ m![/:>\]]!) { 235 for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { 236 my $dir = $ENV{"DCL\$PATH;$i"}; 237 $dir .= ':' unless $dir =~ m%[\]:]$%; 238 push(@dirs,$dir); 239 } 240 push(@dirs,'Sys$System:'); 241 foreach my $dir (@dirs) { 242 my $sysfile = "$dir$file"; 243 foreach my $ext (@exts) { 244 return $file if -x "$sysfile$ext" && ! -d _; 245 } 246 } 247 } 248 return; 249} 250 251=item do_system 252 253Override to ensure that we quote the arguments but not the command. 254 255=cut 256 257sub do_system { 258 # The command must not be quoted but the arguments to it must be. 259 my ($self, @cmd) = @_; 260 $self->log_verbose("@cmd\n"); 261 my $cmd = shift @cmd; 262 my $args = $self->_quote_args(@cmd); 263 return !system("$cmd $args"); 264} 265 266=item oneliner 267 268Override to ensure that we do not quote the command. 269 270=cut 271 272sub oneliner { 273 my $self = shift; 274 my $oneliner = $self->SUPER::oneliner(@_); 275 276 $oneliner =~ s/^\"\S+\"//; 277 278 return "MCR $^X $oneliner"; 279} 280 281=item rscan_dir 282 283Inherit the standard version but remove dots at end of name. 284If the extended character set is in effect, do not remove dots from filenames 285with Unix path delimiters. 286 287=cut 288 289sub rscan_dir { 290 my ($self, $dir, $pattern) = @_; 291 292 my $result = $self->SUPER::rscan_dir( $dir, $pattern ); 293 294 for my $file (@$result) { 295 if (!_efs() && ($file =~ m#/#)) { 296 $file =~ s/\.$//; 297 } 298 } 299 return $result; 300} 301 302=item dist_dir 303 304Inherit the standard version but replace embedded dots with underscores because 305a dot is the directory delimiter on VMS. 306 307=cut 308 309sub dist_dir { 310 my $self = shift; 311 312 my $dist_dir = $self->SUPER::dist_dir; 313 $dist_dir =~ s/\./_/g unless _efs(); 314 return $dist_dir; 315} 316 317=item man3page_name 318 319Inherit the standard version but chop the extra manpage delimiter off the front if 320there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'. 321 322=cut 323 324sub man3page_name { 325 my $self = shift; 326 327 my $mpname = $self->SUPER::man3page_name( shift ); 328 my $sep = $self->manpage_separator; 329 $mpname =~ s/^$sep//; 330 return $mpname; 331} 332 333=item expand_test_dir 334 335Inherit the standard version but relativize the paths as the native glob() doesn't 336do that for us. 337 338=cut 339 340sub expand_test_dir { 341 my ($self, $dir) = @_; 342 343 my @reldirs = $self->SUPER::expand_test_dir( $dir ); 344 345 for my $eachdir (@reldirs) { 346 my ($v,$d,$f) = File::Spec->splitpath( $eachdir ); 347 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) ); 348 $eachdir = File::Spec->catfile( $reldir, $f ); 349 } 350 return @reldirs; 351} 352 353=item _detildefy 354 355The home-grown glob() does not currently handle tildes, so provide limited support 356here. Expect only UNIX format file specifications for now. 357 358=cut 359 360sub _detildefy { 361 my ($self, $arg) = @_; 362 363 # Apparently double ~ are not translated. 364 return $arg if ($arg =~ /^~~/); 365 366 # Apparently ~ followed by whitespace are not translated. 367 return $arg if ($arg =~ /^~ /); 368 369 if ($arg =~ /^~/) { 370 my $spec = $arg; 371 372 # Remove the tilde 373 $spec =~ s/^~//; 374 375 # Remove any slash following the tilde if present. 376 $spec =~ s#^/##; 377 378 # break up the paths for the merge 379 my $home = VMS::Filespec::unixify($ENV{HOME}); 380 381 # In the default VMS mode, the trailing slash is present. 382 # In Unix report mode it is not. The parsing logic assumes that 383 # it is present. 384 $home .= '/' unless $home =~ m#/$#; 385 386 # Trivial case of just ~ by it self 387 if ($spec eq '') { 388 $home =~ s#/$##; 389 return $home; 390 } 391 392 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home); 393 if ($hdir eq '') { 394 # Someone has tampered with $ENV{HOME} 395 # So hfile is probably the directory since this should be 396 # a path. 397 $hdir = $hfile; 398 } 399 400 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec); 401 402 my @hdirs = File::Spec::Unix->splitdir($hdir); 403 my @dirs = File::Spec::Unix->splitdir($dir); 404 405 unless ($arg =~ m#^~/#) { 406 # There is a home directory after the tilde, but it will already 407 # be present in in @hdirs so we need to remove it by from @dirs. 408 409 shift @dirs; 410 } 411 my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs); 412 413 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file); 414 } 415 return $arg; 416 417} 418 419=item find_perl_interpreter 420 421On VMS, $^X returns the fully qualified absolute path including version 422number. It's logically impossible to improve on it for getting the perl 423we're currently running, and attempting to manipulate it is usually 424lossy. 425 426=cut 427 428sub find_perl_interpreter { 429 return VMS::Filespec::vmsify($^X); 430} 431 432=item localize_file_path 433 434Convert the file path to the local syntax 435 436=cut 437 438sub localize_file_path { 439 my ($self, $path) = @_; 440 $path = VMS::Filespec::vmsify($path); 441 $path =~ s/\.\z//; 442 return $path; 443} 444 445=item localize_dir_path 446 447Convert the directory path to the local syntax 448 449=cut 450 451sub localize_dir_path { 452 my ($self, $path) = @_; 453 return VMS::Filespec::vmspath($path); 454} 455 456=item ACTION_clean 457 458The home-grown glob() expands a bit too aggressively when given a bare name, 459so default in a zero-length extension. 460 461=cut 462 463sub ACTION_clean { 464 my ($self) = @_; 465 foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) { 466 $self->delete_filetree($item); 467 } 468} 469 470 471# Need to look up the feature settings. The preferred way is to use the 472# VMS::Feature module, but that may not be available to dual life modules. 473 474my $use_feature; 475BEGIN { 476 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { 477 $use_feature = 1; 478 } 479} 480 481# Need to look up the UNIX report mode. This may become a dynamic mode 482# in the future. 483sub _unix_rpt { 484 my $unix_rpt; 485 if ($use_feature) { 486 $unix_rpt = VMS::Feature::current("filename_unix_report"); 487 } else { 488 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; 489 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 490 } 491 return $unix_rpt; 492} 493 494# Need to look up the EFS character set mode. This may become a dynamic 495# mode in the future. 496sub _efs { 497 my $efs; 498 if ($use_feature) { 499 $efs = VMS::Feature::current("efs_charset"); 500 } else { 501 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; 502 $efs = $env_efs =~ /^[ET1]/i; 503 } 504 return $efs; 505} 506 507=back 508 509=head1 AUTHOR 510 511Michael G Schwern <schwern@pobox.com> 512Ken Williams <kwilliams@cpan.org> 513Craig A. Berry <craigberry@mac.com> 514 515=head1 SEE ALSO 516 517perl(1), Module::Build(3), ExtUtils::MakeMaker(3) 518 519=cut 520 5211; 522__END__ 523