local-lib5/lib/perl5/ExtUtils/MM_VMS.pm

   1 package ExtUtils::MM_VMS;
   2
   3 use strict;
   4
   5 use ExtUtils::MakeMaker::Config;
   6 require Exporter;
   7
   8 BEGIN {
   9     # so we can compile the thing on non-VMS platforms.
  10     if( $^O eq 'VMS' ) {
  11         require VMS::Filespec;
  12         VMS::Filespec->import;
  13     }
  14 }
  15
  16 use File::Basename;
  17
  18 our $VERSION = '6.54';
  19
  20 require ExtUtils::MM_Any;
  21 require ExtUtils::MM_Unix;
  22 our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
  23
  24 use ExtUtils::MakeMaker qw($Verbose neatvalue);
  25 our $Revision = $ExtUtils::MakeMaker::Revision;
  26
  27
  28 =head1 NAME
  29
  30 ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker
  31
  32 =head1 SYNOPSIS
  33
  34   Do not use this directly.
  35   Instead, use ExtUtils::MM and it will figure out which MM_*
  36   class to use for you.
  37
  38 =head1 DESCRIPTION
  39
  40 See ExtUtils::MM_Unix for a documentation of the methods provided
  41 there. This package overrides the implementation of these methods, not
  42 the semantics.
  43
  44 =head2 Methods always loaded
  45
  46 =over 4
  47
  48 =item wraplist
  49
  50 Converts a list into a string wrapped at approximately 80 columns.
  51
  52 =cut
  53
  54 sub wraplist {
  55     my($self) = shift;
  56     my($line,$hlen) = ('',0);
  57
  58     foreach my $word (@_) {
  59       # Perl bug -- seems to occasionally insert extra elements when
  60       # traversing array (scalar(@array) doesn't show them, but
  61       # foreach(@array) does) (5.00307)
  62       next unless $word =~ /\w/;
  63       $line .= ' ' if length($line);
  64       if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
  65       $line .= $word;
  66       $hlen += length($word) + 2;
  67     }
  68     $line;
  69 }
  70
  71
  72 # This isn't really an override.  It's just here because ExtUtils::MM_VMS
  73 # appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
  74 # in MM_VMS, then AUTOLOAD is called, and bad things happen.  So, we just
  75 # mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
  76 # XXX This hackery will die soon. --Schwern
  77 sub ext {
  78     require ExtUtils::Liblist::Kid;
  79     goto &ExtUtils::Liblist::Kid::ext;
  80 }
  81
  82 =back
  83
  84 =head2 Methods
  85
  86 Those methods which override default MM_Unix methods are marked
  87 "(override)", while methods unique to MM_VMS are marked "(specific)".
  88 For overridden methods, documentation is limited to an explanation
  89 of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
  90 documentation for more details.
  91
  92 =over 4
  93
  94 =item guess_name (override)
  95
  96 Try to determine name of extension being built.  We begin with the name
  97 of the current directory.  Since VMS filenames are case-insensitive,
  98 however, we look for a F<.pm> file whose name matches that of the current
  99 directory (presumably the 'main' F<.pm> file for this extension), and try
 100 to find a C<package> statement from which to obtain the Mixed::Case
 101 package name.
 102
 103 =cut
 104
 105 sub guess_name {
 106     my($self) = @_;
 107     my($defname,$defpm,@pm,%xs);
 108     local *PM;
 109
 110     $defname = basename(fileify($ENV{'DEFAULT'}));
 111     $defname =~ s![\d\-_]*\.dir.*$!!;  # Clip off .dir;1 suffix, and package version
 112     $defpm = $defname;
 113     # Fallback in case for some reason a user has copied the files for an
 114     # extension into a working directory whose name doesn't reflect the
 115     # extension's name.  We'll use the name of a unique .pm file, or the
 116     # first .pm file with a matching .xs file.
 117     if (not -e "${defpm}.pm") {
 118       @pm = glob('*.pm');
 119       s/.pm$// for @pm;
 120       if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
 121       elsif (@pm) {
 122         %xs = map { s/.xs$//; ($_,1) } glob('*.xs');  ## no critic
 123         if (keys %xs) {
 124             foreach my $pm (@pm) {
 125                 $defpm = $pm, last if exists $xs{$pm};
 126             }
 127         }
 128       }
 129     }
 130     if (open(my $pm, '<', "${defpm}.pm")){
 131         while (<$pm>) {
 132             if (/^\s*package\s+([^;]+)/i) {
 133                 $defname = $1;
 134                 last;
 135             }
 136         }
 137         print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
 138                      "defaulting package name to $defname\n"
 139             if eof($pm);
 140         close $pm;
 141     }
 142     else {
 143         print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
 144                      "defaulting package name to $defname\n";
 145     }
 146     $defname =~ s#[\d.\-_]+$##;
 147     $defname;
 148 }
 149
 150 =item find_perl (override)
 151
 152 Use VMS file specification syntax and CLI commands to find and
 153 invoke Perl images.
 154
 155 =cut
 156
 157 sub find_perl {
 158     my($self, $ver, $names, $dirs, $trace) = @_;
 159     my($vmsfile,@sdirs,@snames,@cand);
 160     my($rslt);
 161     my($inabs) = 0;
 162     local *TCF;
 163
 164     if( $self->{PERL_CORE} ) {
 165         # Check in relative directories first, so we pick up the current
 166         # version of Perl if we're running MakeMaker as part of the main build.
 167         @sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
 168                         my($absb) = $self->file_name_is_absolute($b);
 169                         if ($absa && $absb) { return $a cmp $b }
 170                         else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
 171                       } @$dirs;
 172         # Check miniperl before perl, and check names likely to contain
 173         # version numbers before "generic" names, so we pick up an
 174         # executable that's less likely to be from an old installation.
 175         @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!;  # basename
 176                          my($bb) = $b =~ m!([^:>\]/]+)$!;
 177                          my($ahasdir) = (length($a) - length($ba) > 0);
 178                          my($bhasdir) = (length($b) - length($bb) > 0);
 179                          if    ($ahasdir and not $bhasdir) { return 1; }
 180                          elsif ($bhasdir and not $ahasdir) { return -1; }
 181                          else { $bb =~ /\d/ <=> $ba =~ /\d/
 182                                   or substr($ba,0,1) cmp substr($bb,0,1)
 183                                   or length($bb) <=> length($ba) } } @$names;
 184     }
 185     else {
 186         @sdirs  = @$dirs;
 187         @snames = @$names;
 188     }
 189
 190     # Image names containing Perl version use '_' instead of '.' under VMS
 191     s/\.(\d+)$/_$1/ for @snames;
 192     if ($trace >= 2){
 193         print "Looking for perl $ver by these names:\n";
 194         print "\t@snames,\n";
 195         print "in these dirs:\n";
 196         print "\t@sdirs\n";
 197     }
 198     foreach my $dir (@sdirs){
 199         next unless defined $dir; # $self->{PERL_SRC} may be undefined
 200         $inabs++ if $self->file_name_is_absolute($dir);
 201         if ($inabs == 1) {
 202             # We've covered relative dirs; everything else is an absolute
 203             # dir (probably an installed location).  First, we'll try
 204             # potential command names, to see whether we can avoid a long
 205             # MCR expression.
 206             foreach my $name (@snames) {
 207                 push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
 208             }
 209             $inabs++; # Should happen above in next $dir, but just in case...
 210         }
 211         foreach my $name (@snames){
 212             push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name)
 213                                               : $self->fixpath($name,0);
 214         }
 215     }
 216     foreach my $name (@cand) {
 217         print "Checking $name\n" if $trace >= 2;
 218         # If it looks like a potential command, try it without the MCR
 219         if ($name =~ /^[\w\-\$]+$/) {
 220             open(my $tcf, ">", "temp_mmvms.com")
 221                 or die('unable to open temp file');
 222             print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
 223             print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
 224             close $tcf;
 225             $rslt = `\@temp_mmvms.com` ;
 226             unlink('temp_mmvms.com');
 227             if ($rslt =~ /VER_OK/) {
 228                 print "Using PERL=$name\n" if $trace;
 229                 return $name;
 230             }
 231         }
 232         next unless $vmsfile = $self->maybe_command($name);
 233         $vmsfile =~ s/;[\d\-]*$//;  # Clip off version number; we can use a newer version as well
 234         print "Executing $vmsfile\n" if ($trace >= 2);
 235         open(my $tcf, '>', "temp_mmvms.com")
 236                 or die('unable to open temp file');
 237         print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
 238         print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
 239         close $tcf;
 240         $rslt = `\@temp_mmvms.com`;
 241         unlink('temp_mmvms.com');
 242         if ($rslt =~ /VER_OK/) {
 243             print "Using PERL=MCR $vmsfile\n" if $trace;
 244             return "MCR $vmsfile";
 245         }
 246     }
 247     print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
 248     0; # false and not empty
 249 }
 250
 251 =item maybe_command (override)
 252
 253 Follows VMS naming conventions for executable files.
 254 If the name passed in doesn't exactly match an executable file,
 255 appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
 256 to check for DCL procedure.  If this fails, checks directories in DCL$PATH
 257 and finally F<Sys$System:> for an executable file having the name specified,
 258 with or without the F<.Exe>-equivalent suffix.
 259
 260 =cut
 261
 262 sub maybe_command {
 263     my($self,$file) = @_;
 264     return $file if -x $file && ! -d _;
 265     my(@dirs) = ('');
 266     my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
 267
 268     if ($file !~ m![/:>\]]!) {
 269         for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
 270             my $dir = $ENV{"DCL\$PATH;$i"};
 271             $dir .= ':' unless $dir =~ m%[\]:]$%;
 272             push(@dirs,$dir);
 273         }
 274         push(@dirs,'Sys$System:');
 275         foreach my $dir (@dirs) {
 276             my $sysfile = "$dir$file";
 277             foreach my $ext (@exts) {
 278                 return $file if -x "$sysfile$ext" && ! -d _;
 279             }
 280         }
 281     }
 282     return 0;
 283 }
 284
 285
 286 =item pasthru (override)
 287
 288 VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
 289 options.  This is used in every invocation of make in the VMS Makefile so
 290 PASTHRU should not be necessary.  Using PASTHRU tends to blow commands past
 291 the 256 character limit.
 292
 293 =cut
 294
 295 sub pasthru {
 296     return "PASTHRU=\n";
 297 }
 298
 299
 300 =item pm_to_blib (override)
 301
 302 VMS wants a dot in every file so we can't have one called 'pm_to_blib',
 303 it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
 304 you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.
 305
 306 So in VMS its pm_to_blib.ts.
 307
 308 =cut
 309
 310 sub pm_to_blib {
 311     my $self = shift;
 312
 313     my $make = $self->SUPER::pm_to_blib;
 314
 315     $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
 316     $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};
 317
 318     $make = <<'MAKE' . $make;
 319 # Dummy target to match Unix target name; we use pm_to_blib.ts as
 320 # timestamp file to avoid repeated invocations under VMS
 321 pm_to_blib : pm_to_blib.ts
 322         $(NOECHO) $(NOOP)
 323
 324 MAKE
 325
 326     return $make;
 327 }
 328
 329
 330 =item perl_script (override)
 331
 332 If name passed in doesn't specify a readable file, appends F<.com> or
 333 F<.pl> and tries again, since it's customary to have file types on all files
 334 under VMS.
 335
 336 =cut
 337
 338 sub perl_script {
 339     my($self,$file) = @_;
 340     return $file if -r $file && ! -d _;
 341     return "$file.com" if -r "$file.com";
 342     return "$file.pl" if -r "$file.pl";
 343     return '';
 344 }
 345
 346
 347 =item replace_manpage_separator
 348
 349 Use as separator a character which is legal in a VMS-syntax file name.
 350
 351 =cut
 352
 353 sub replace_manpage_separator {
 354     my($self,$man) = @_;
 355     $man = unixify($man);
 356     $man =~ s#/+#__#g;
 357     $man;
 358 }
 359
 360 =item init_DEST
 361
 362 (override) Because of the difficulty concatenating VMS filepaths we
 363 must pre-expand the DEST* variables.
 364
 365 =cut
 366
 367 sub init_DEST {
 368     my $self = shift;
 369
 370     $self->SUPER::init_DEST;
 371
 372     # Expand DEST variables.
 373     foreach my $var ($self->installvars) {
 374         my $destvar = 'DESTINSTALL'.$var;
 375         $self->{$destvar} = $self->eliminate_macros($self->{$destvar});
 376     }
 377 }
 378
 379
 380 =item init_DIRFILESEP
 381
 382 No seperator between a directory path and a filename on VMS.
 383
 384 =cut
 385
 386 sub init_DIRFILESEP {
 387     my($self) = shift;
 388
 389     $self->{DIRFILESEP} = '';
 390     return 1;
 391 }
 392
 393
 394 =item init_main (override)
 395
 396
 397 =cut
 398
 399 sub init_main {
 400     my($self) = shift;
 401
 402     $self->SUPER::init_main;
 403
 404     $self->{DEFINE} ||= '';
 405     if ($self->{DEFINE} ne '') {
 406         my(@terms) = split(/\s+/,$self->{DEFINE});
 407         my(@defs,@udefs);
 408         foreach my $def (@terms) {
 409             next unless $def;
 410             my $targ = \@defs;
 411             if ($def =~ s/^-([DU])//) {    # If it was a Unix-style definition
 412                 $targ = \@udefs if $1 eq 'U';
 413                 $def =~ s/='(.*)'$/=$1/;  # then remove shell-protection ''
 414                 $def =~ s/^'(.*)'$/$1/;   # from entire term or argument
 415             }
 416             if ($def =~ /=/) {
 417                 $def =~ s/"/""/g;  # Protect existing " from DCL
 418                 $def = qq["$def"]; # and quote to prevent parsing of =
 419             }
 420             push @$targ, $def;
 421         }
 422
 423         $self->{DEFINE} = '';
 424         if (@defs)  {
 425             $self->{DEFINE}  = '/Define=(' . join(',',@defs)  . ')';
 426         }
 427         if (@udefs) {
 428             $self->{DEFINE} .= '/Undef=('  . join(',',@udefs) . ')';
 429         }
 430     }
 431 }
 432
 433 =item init_others (override)
 434
 435 Provide VMS-specific forms of various utility commands, then hand
 436 off to the default MM_Unix method.
 437
 438 DEV_NULL should probably be overriden with something.
 439
 440 Also changes EQUALIZE_TIMESTAMP to set revision date of target file to
 441 one second later than source file, since MMK interprets precisely
 442 equal revision dates for a source and target file as a sign that the
 443 target needs to be updated.
 444
 445 =cut
 446
 447 sub init_others {
 448     my($self) = @_;
 449
 450     $self->{NOOP}               = 'Continue';
 451     $self->{NOECHO}             ||= '@ ';
 452
 453     $self->{MAKEFILE}           ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
 454     $self->{FIRST_MAKEFILE}     ||= $self->{MAKEFILE};
 455     $self->{MAKE_APERL_FILE}    ||= 'Makeaperl.MMS';
 456     $self->{MAKEFILE_OLD}       ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
 457 #
 458 #   If an extension is not specified, then MMS/MMK assumes an
 459 #   an extension of .MMS.  If there really is no extension,
 460 #   then a trailing "." needs to be appended to specify a
 461 #   a null extension.
 462 #
 463     $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
 464     $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
 465     $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
 466     $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;
 467
 468     $self->{MACROSTART}         ||= '/Macro=(';
 469     $self->{MACROEND}           ||= ')';
 470     $self->{USEMAKEFILE}        ||= '/Descrip=';
 471
 472     $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';
 473
 474     $self->{MOD_INSTALL} ||=
 475       $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
 476 install([ from_to => {split(' ', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
 477 CODE
 478
 479     $self->SUPER::init_others;
 480
 481     $self->{SHELL}    ||= 'Posix';
 482
 483     $self->{UMASK_NULL} = '! ';
 484
 485     # Redirection on VMS goes before the command, not after as on Unix.
 486     # $(DEV_NULL) is used once and its not worth going nuts over making
 487     # it work.  However, Unix's DEV_NULL is quite wrong for VMS.
 488     $self->{DEV_NULL}   = '';
 489
 490     if ($self->{OBJECT} =~ /\s/) {
 491         $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g;
 492         $self->{OBJECT} = $self->wraplist(
 493             map $self->fixpath($_,0), split /,?\s+/, $self->{OBJECT}
 494         );
 495     }
 496
 497     $self->{LDFROM} = $self->wraplist(
 498         map $self->fixpath($_,0), split /,?\s+/, $self->{LDFROM}
 499     );
 500 }
 501
 502
 503 =item init_platform (override)
 504
 505 Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.
 506
 507 MM_VMS_REVISION is for backwards compatibility before MM_VMS had a
 508 $VERSION.
 509
 510 =cut
 511
 512 sub init_platform {
 513     my($self) = shift;
 514
 515     $self->{MM_VMS_REVISION} = $Revision;
 516     $self->{MM_VMS_VERSION}  = $VERSION;
 517     $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS')
 518       if $self->{PERL_SRC};
 519 }
 520
 521
 522 =item platform_constants
 523
 524 =cut
 525
 526 sub platform_constants {
 527     my($self) = shift;
 528     my $make_frag = '';
 529
 530     foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION))
 531     {
 532         next unless defined $self->{$macro};
 533         $make_frag .= "$macro = $self->{$macro}\n";
 534     }
 535
 536     return $make_frag;
 537 }
 538
 539
 540 =item init_VERSION (override)
 541
 542 Override the *DEFINE_VERSION macros with VMS semantics.  Translate the
 543 MAKEMAKER filepath to VMS style.
 544
 545 =cut
 546
 547 sub init_VERSION {
 548     my $self = shift;
 549
 550     $self->SUPER::init_VERSION;
 551
 552     $self->{DEFINE_VERSION}    = '"$(VERSION_MACRO)=""$(VERSION)"""';
 553     $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""';
 554     $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'});
 555 }
 556
 557
 558 =item constants (override)
 559
 560 Fixes up numerous file and directory macros to insure VMS syntax
 561 regardless of input syntax.  Also makes lists of files
 562 comma-separated.
 563
 564 =cut
 565
 566 sub constants {
 567     my($self) = @_;
 568
 569     # Be kind about case for pollution
 570     for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }
 571
 572     # Cleanup paths for directories in MMS macros.
 573     foreach my $macro ( qw [
 574             INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
 575             PERL_LIB PERL_ARCHLIB
 576             PERL_INC PERL_SRC ],
 577                         (map { 'INSTALL'.$_ } $self->installvars)
 578                       )
 579     {
 580         next unless defined $self->{$macro};
 581         next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
 582         $self->{$macro} = $self->fixpath($self->{$macro},1);
 583     }
 584
 585     # Cleanup paths for files in MMS macros.
 586     foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
 587                            MAKE_APERL_FILE MYEXTLIB] )
 588     {
 589         next unless defined $self->{$macro};
 590         $self->{$macro} = $self->fixpath($self->{$macro},0);
 591     }
 592
 593     # Fixup files for MMS macros
 594     # XXX is this list complete?
 595     for my $macro (qw/
 596                    FULLEXT VERSION_FROM OBJECT LDFROM
 597               / ) {
 598         next unless defined $self->{$macro};
 599         $self->{$macro} = $self->fixpath($self->{$macro},0);
 600     }
 601
 602
 603     for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
 604         # Where is the space coming from? --jhi
 605         next unless $self ne " " && defined $self->{$macro};
 606         my %tmp = ();
 607         for my $key (keys %{$self->{$macro}}) {
 608             $tmp{$self->fixpath($key,0)} =
 609                                      $self->fixpath($self->{$macro}{$key},0);
 610         }
 611         $self->{$macro} = \%tmp;
 612     }
 613
 614     for my $macro (qw/ C O_FILES H /) {
 615         next unless defined $self->{$macro};
 616         my @tmp = ();
 617         for my $val (@{$self->{$macro}}) {
 618             push(@tmp,$self->fixpath($val,0));
 619         }
 620         $self->{$macro} = \@tmp;
 621     }
 622
 623     # mms/k does not define a $(MAKE) macro.
 624     $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)';
 625
 626     return $self->SUPER::constants;
 627 }
 628
 629
 630 =item special_targets
 631
 632 Clear the default .SUFFIXES and put in our own list.
 633
 634 =cut
 635
 636 sub special_targets {
 637     my $self = shift;
 638
 639     my $make_frag .= <<'MAKE_FRAG';
 640 .SUFFIXES :
 641 .SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs
 642
 643 MAKE_FRAG
 644
 645     return $make_frag;
 646 }
 647
 648 =item cflags (override)
 649
 650 Bypass shell script and produce qualifiers for CC directly (but warn
 651 user if a shell script for this extension exists).  Fold multiple
 652 /Defines into one, since some C compilers pay attention to only one
 653 instance of this qualifier on the command line.
 654
 655 =cut
 656
 657 sub cflags {
 658     my($self,$libperl) = @_;
 659     my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
 660     my($definestr,$undefstr,$flagoptstr) = ('','','');
 661     my($incstr) = '/Include=($(PERL_INC)';
 662     my($name,$sys,@m);
 663
 664     ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
 665     print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
 666          " required to modify CC command for $self->{'BASEEXT'}\n"
 667     if ($Config{$name});
 668
 669     if ($quals =~ / -[DIUOg]/) {
 670         while ($quals =~ / -([Og])(\d*)\b/) {
 671             my($type,$lvl) = ($1,$2);
 672             $quals =~ s/ -$type$lvl\b\s*//;
 673             if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
 674             else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
 675         }
 676         while ($quals =~ / -([DIU])(\S+)/) {
 677             my($type,$def) = ($1,$2);
 678             $quals =~ s/ -$type$def\s*//;
 679             $def =~ s/"/""/g;
 680             if    ($type eq 'D') { $definestr .= qq["$def",]; }
 681             elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
 682             else                 { $undefstr  .= qq["$def",]; }
 683         }
 684     }
 685     if (length $quals and $quals !~ m!/!) {
 686         warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
 687         $quals = '';
 688     }
 689     $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
 690     if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
 691     if (length $undefstr)  { chop($undefstr);  $quals .= "/Undef=($undefstr)";   }
 692     # Deal with $self->{DEFINE} here since some C compilers pay attention
 693     # to only one /Define clause on command line, so we have to
 694     # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
 695     # ($self->{DEFINE} has already been VMSified in constants() above)
 696     if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
 697     for my $type (qw(Def Undef)) {
 698         my(@terms);
 699         while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
 700                 my $term = $1;
 701                 $term =~ s:^\((.+)\)$:$1:;
 702                 push @terms, $term;
 703             }
 704         if ($type eq 'Def') {
 705             push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
 706         }
 707         if (@terms) {
 708             $quals =~ s:/${type}i?n?e?=[^/]+::ig;
 709             $quals .= "/${type}ine=(" . join(',',@terms) . ')';
 710         }
 711     }
 712
 713     $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
 714
 715     # Likewise with $self->{INC} and /Include
 716     if ($self->{'INC'}) {
 717         my(@includes) = split(/\s+/,$self->{INC});
 718         foreach (@includes) {
 719             s/^-I//;
 720             $incstr .= ','.$self->fixpath($_,1);
 721         }
 722     }
 723     $quals .= "$incstr)";
 724 #    $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
 725     $self->{CCFLAGS} = $quals;
 726
 727     $self->{PERLTYPE} ||= '';
 728
 729     $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
 730     if ($self->{OPTIMIZE} !~ m!/!) {
 731         if    ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
 732         elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
 733             $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
 734         }
 735         else {
 736             warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
 737             $self->{OPTIMIZE} = '/Optimize';
 738         }
 739     }
 740
 741     return $self->{CFLAGS} = qq{
 742 CCFLAGS = $self->{CCFLAGS}
 743 OPTIMIZE = $self->{OPTIMIZE}
 744 PERLTYPE = $self->{PERLTYPE}
 745 };
 746 }
 747
 748 =item const_cccmd (override)
 749
 750 Adds directives to point C preprocessor to the right place when
 751 handling #include E<lt>sys/foo.hE<gt> directives.  Also constructs CC
 752 command line a bit differently than MM_Unix method.
 753
 754 =cut
 755
 756 sub const_cccmd {
 757     my($self,$libperl) = @_;
 758     my(@m);
 759
 760     return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
 761     return '' unless $self->needs_linking();
 762     if ($Config{'vms_cc_type'} eq 'gcc') {
 763         push @m,'
 764 .FIRST
 765         ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
 766     }
 767     elsif ($Config{'vms_cc_type'} eq 'vaxc') {
 768         push @m,'
 769 .FIRST
 770         ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
 771         ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
 772     }
 773     else {
 774         push @m,'
 775 .FIRST
 776         ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
 777                 ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
 778         ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
 779     }
 780
 781     push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");
 782
 783     $self->{CONST_CCCMD} = join('',@m);
 784 }
 785
 786
 787 =item tools_other (override)
 788
 789 Throw in some dubious extra macros for Makefile args.
 790
 791 Also keep around the old $(SAY) macro in case somebody's using it.
 792
 793 =cut
 794
 795 sub tools_other {
 796     my($self) = @_;
 797
 798     # XXX Are these necessary?  Does anyone override them?  They're longer
 799     # than just typing the literal string.
 800     my $extra_tools = <<'EXTRA_TOOLS';
 801
 802 # Just in case anyone is using the old macro.
 803 USEMACROS = $(MACROSTART)
 804 SAY = $(ECHO)
 805
 806 EXTRA_TOOLS
 807
 808     return $self->SUPER::tools_other . $extra_tools;
 809 }
 810
 811 =item init_dist (override)
 812
 813 VMSish defaults for some values.
 814
 815   macro         description                     default
 816
 817   ZIPFLAGS      flags to pass to ZIP            -Vu
 818
 819   COMPRESS      compression command to          gzip
 820                 use for tarfiles
 821   SUFFIX        suffix to put on                -gz
 822                 compressed files
 823
 824   SHAR          shar command to use             vms_share
 825
 826   DIST_DEFAULT  default target to use to        tardist
 827                 create a distribution
 828
 829   DISTVNAME     Use VERSION_SYM instead of      $(DISTNAME)-$(VERSION_SYM)
 830                 VERSION for the name
 831
 832 =cut
 833
 834 sub init_dist {
 835     my($self) = @_;
 836     $self->{ZIPFLAGS}     ||= '-Vu';
 837     $self->{COMPRESS}     ||= 'gzip';
 838     $self->{SUFFIX}       ||= '-gz';
 839     $self->{SHAR}         ||= 'vms_share';
 840     $self->{DIST_DEFAULT} ||= 'zipdist';
 841
 842     $self->SUPER::init_dist;
 843
 844     $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"
 845       unless $self->{ARGS}{DISTVNAME};
 846
 847     return;
 848 }
 849
 850 =item c_o (override)
 851
 852 Use VMS syntax on command line.  In particular, $(DEFINE) and
 853 $(PERL_INC) have been pulled into $(CCCMD).  Also use MM[SK] macros.
 854
 855 =cut
 856
 857 sub c_o {
 858     my($self) = @_;
 859     return '' unless $self->needs_linking();
 860     '
 861 .c$(OBJ_EXT) :
 862         $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
 863
 864 .cpp$(OBJ_EXT) :
 865         $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp
 866
 867 .cxx$(OBJ_EXT) :
 868         $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx
 869
 870 ';
 871 }
 872
 873 =item xs_c (override)
 874
 875 Use MM[SK] macros.
 876
 877 =cut
 878
 879 sub xs_c {
 880     my($self) = @_;
 881     return '' unless $self->needs_linking();
 882     '
 883 .xs.c :
 884         $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
 885 ';
 886 }
 887
 888 =item xs_o (override)
 889
 890 Use MM[SK] macros, and VMS command line for C compiler.
 891
 892 =cut
 893
 894 sub xs_o {      # many makes are too dumb to use xs_c then c_o
 895     my($self) = @_;
 896     return '' unless $self->needs_linking();
 897     '
 898 .xs$(OBJ_EXT) :
 899         $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
 900         $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
 901 ';
 902 }
 903
 904
 905 =item dlsyms (override)
 906
 907 Create VMS linker options files specifying universal symbols for this
 908 extension's shareable image, and listing other shareable images or
 909 libraries to which it should be linked.
 910
 911 =cut
 912
 913 sub dlsyms {
 914     my($self,%attribs) = @_;
 915
 916     return '' unless $self->needs_linking();
 917
 918     my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
 919     my($vars)  = $attribs{DL_VARS}  || $self->{DL_VARS}  || [];
 920     my($funclist)  = $attribs{FUNCLIST}  || $self->{FUNCLIST}  || [];
 921     my(@m);
 922
 923     unless ($self->{SKIPHASH}{'dynamic'}) {
 924         push(@m,'
 925 dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
 926         $(NOECHO) $(NOOP)
 927 ');
 928     }
 929
 930     push(@m,'
 931 static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
 932         $(NOECHO) $(NOOP)
 933 ') unless $self->{SKIPHASH}{'static'};
 934
 935     push @m,'
 936 $(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
 937         $(CP) $(MMS$SOURCE) $(MMS$TARGET)
 938
 939 $(BASEEXT).opt : Makefile.PL
 940         $(PERLRUN) -e "use ExtUtils::Mksymlists;" -
 941         ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
 942         neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),
 943         q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n];
 944
 945     push @m, '  $(PERL) -e "print ""$(INST_STATIC)/Include=';
 946     if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
 947         $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
 948         push @m, ($Config{d_vms_case_sensitive_symbols}
 949                    ? uc($self->{BASEEXT}) :'$(BASEEXT)');
 950     }
 951     else {  # We don't have a "main" object file, so pull 'em all in
 952         # Upcase module names if linker is being case-sensitive
 953         my($upcase) = $Config{d_vms_case_sensitive_symbols};
 954         my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
 955         for (@omods) {
 956             s/\.[^.]*$//;         # Trim off file type
 957             s[\$\(\w+_EXT\)][];   # even as a macro
 958             s/.*[:>\/\]]//;       # Trim off dir spec
 959             $_ = uc if $upcase;
 960         };
 961
 962         my(@lines);
 963         my $tmp = shift @omods;
 964         foreach my $elt (@omods) {
 965             $tmp .= ",$elt";
 966             if (length($tmp) > 80) { push @lines, $tmp;  $tmp = ''; }
 967         }
 968         push @lines, $tmp;
 969         push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
 970     }
 971     push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";
 972
 973     if (length $self->{LDLOADLIBS}) {
 974         my($line) = '';
 975         foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
 976             $lib =~ s%\$%\\\$%g;  # Escape '$' in VMS filespecs
 977             if (length($line) + length($lib) > 160) {
 978                 push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
 979                 $line = $lib . '\n';
 980             }
 981             else { $line .= $lib . '\n'; }
 982         }
 983         push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
 984     }
 985
 986     join('',@m);
 987
 988 }
 989
 990 =item dynamic_lib (override)
 991
 992 Use VMS Link command.
 993
 994 =cut
 995
 996 sub dynamic_lib {
 997     my($self, %attribs) = @_;
 998     return '' unless $self->needs_linking(); #might be because of a subdir
 999
1000     return '' unless $self->has_link_code();
1001
1002     my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
1003     my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
1004     my $shr = $Config{'dbgprefix'} . 'PerlShr';
1005     my(@m);
1006     push @m,"
1007
1008 OTHERLDFLAGS = $otherldflags
1009 INST_DYNAMIC_DEP = $inst_dynamic_dep
1010
1011 ";
1012     push @m, '
1013 $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
1014         If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
1015         Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
1016 ';
1017
1018     join('',@m);
1019 }
1020
1021
1022 =item static_lib (override)
1023
1024 Use VMS commands to manipulate object library.
1025
1026 =cut
1027
1028 sub static_lib {
1029     my($self) = @_;
1030     return '' unless $self->needs_linking();
1031
1032     return '
1033 $(INST_STATIC) :
1034         $(NOECHO) $(NOOP)
1035 ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
1036
1037     my(@m);
1038     push @m,'
1039 # Rely on suffix rule for update action
1040 $(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists
1041
1042 $(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
1043 ';
1044     # If this extension has its own library (eg SDBM_File)
1045     # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
1046     push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
1047
1048     push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");
1049
1050     # if there was a library to copy, then we can't use MMS$SOURCE_LIST,
1051     # 'cause it's a library and you can't stick them in other libraries.
1052     # In that case, we use $OBJECT instead and hope for the best
1053     if ($self->{MYEXTLIB}) {
1054       push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
1055     } else {
1056       push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
1057     }
1058
1059     push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
1060     foreach my $lib (split ' ', $self->{EXTRALIBS}) {
1061       push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
1062     }
1063     join('',@m);
1064 }
1065
1066
1067 =item extra_clean_files
1068
1069 Clean up some OS specific files.  Plus the temp file used to shorten
1070 a lot of commands.
1071
1072 =cut
1073
1074 sub extra_clean_files {
1075     return qw(
1076               *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
1077               .MM_Tmp
1078              );
1079 }
1080
1081
1082 =item zipfile_target
1083
1084 =item tarfile_target
1085
1086 =item shdist_target
1087
1088 Syntax for invoking shar, tar and zip differs from that for Unix.
1089
1090 =cut
1091
1092 sub zipfile_target {
1093     my($self) = shift;
1094
1095     return <<'MAKE_FRAG';
1096 $(DISTVNAME).zip : distdir
1097         $(PREOP)
1098         $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
1099         $(RM_RF) $(DISTVNAME)
1100         $(POSTOP)
1101 MAKE_FRAG
1102 }
1103
1104 sub tarfile_target {
1105     my($self) = shift;
1106
1107     return <<'MAKE_FRAG';
1108 $(DISTVNAME).tar$(SUFFIX) : distdir
1109         $(PREOP)
1110         $(TO_UNIX)
1111         $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
1112         $(RM_RF) $(DISTVNAME)
1113         $(COMPRESS) $(DISTVNAME).tar
1114         $(POSTOP)
1115 MAKE_FRAG
1116 }
1117
1118 sub shdist_target {
1119     my($self) = shift;
1120
1121     return <<'MAKE_FRAG';
1122 shdist : distdir
1123         $(PREOP)
1124         $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
1125         $(RM_RF) $(DISTVNAME)
1126         $(POSTOP)
1127 MAKE_FRAG
1128 }
1129
1130
1131 # --- Test and Installation Sections ---
1132
1133 =item install (override)
1134
1135 Work around DCL's 255 character limit several times,and use
1136 VMS-style command line quoting in a few cases.
1137
1138 =cut
1139
1140 sub install {
1141     my($self, %attribs) = @_;
1142     my(@m);
1143
1144     push @m, q[
1145 install :: all pure_install doc_install
1146         $(NOECHO) $(NOOP)
1147
1148 install_perl :: all pure_perl_install doc_perl_install
1149         $(NOECHO) $(NOOP)
1150
1151 install_site :: all pure_site_install doc_site_install
1152         $(NOECHO) $(NOOP)
1153
1154 pure_install :: pure_$(INSTALLDIRS)_install
1155         $(NOECHO) $(NOOP)
1156
1157 doc_install :: doc_$(INSTALLDIRS)_install
1158         $(NOECHO) $(NOOP)
1159
1160 pure__install : pure_site_install
1161         $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
1162
1163 doc__install : doc_site_install
1164         $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
1165
1166 # This hack brought to you by DCL's 255-character command line limit
1167 pure_perl_install ::
1168         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1169         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1170         $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
1171         $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp
1172         $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp
1173         $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
1174         $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
1175         $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp
1176         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1177         $(NOECHO) $(RM_F) .MM_tmp
1178         $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
1179
1180 # Likewise
1181 pure_site_install ::
1182         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1183         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1184         $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
1185         $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp
1186         $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp
1187         $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
1188         $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp
1189         $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp
1190         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1191         $(NOECHO) $(RM_F) .MM_tmp
1192         $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
1193
1194 pure_vendor_install ::
1195         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1196         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1197         $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
1198         $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp
1199         $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp
1200         $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
1201         $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp
1202         $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp
1203         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1204         $(NOECHO) $(RM_F) .MM_tmp
1205
1206 # Ditto
1207 doc_perl_install ::
1208         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
1209         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1210         $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
1211         $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1212         $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
1213         $(NOECHO) $(RM_F) .MM_tmp
1214
1215 # And again
1216 doc_site_install ::
1217         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
1218         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1219         $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
1220         $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1221         $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
1222         $(NOECHO) $(RM_F) .MM_tmp
1223
1224 doc_vendor_install ::
1225         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
1226         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1227         $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
1228         $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1229         $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
1230         $(NOECHO) $(RM_F) .MM_tmp
1231
1232 ];
1233
1234     push @m, q[
1235 uninstall :: uninstall_from_$(INSTALLDIRS)dirs
1236         $(NOECHO) $(NOOP)
1237
1238 uninstall_from_perldirs ::
1239         $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
1240         $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
1241         $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
1242         $(NOECHO) $(ECHO) "the appropriate files.  Sorry for the inconvenience."
1243
1244 uninstall_from_sitedirs ::
1245         $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
1246         $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
1247         $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
1248         $(NOECHO) $(ECHO) "the appropriate files.  Sorry for the inconvenience."
1249 ];
1250
1251     join('',@m);
1252 }
1253
1254 =item perldepend (override)
1255
1256 Use VMS-style syntax for files; it's cheaper to just do it directly here
1257 than to have the MM_Unix method call C<catfile> repeatedly.  Also, if
1258 we have to rebuild Config.pm, use MM[SK] to do it.
1259
1260 =cut
1261
1262 sub perldepend {
1263     my($self) = @_;
1264     my(@m);
1265
1266     push @m, '
1267 $(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h
1268 $(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h
1269 $(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h
1270 $(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h
1271 $(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h
1272 $(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h
1273 $(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h
1274 $(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
1275 $(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h
1276 $(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h
1277 $(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h
1278 $(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h
1279 $(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
1280 $(OBJECT) : $(PERL_INC)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h
1281
1282 ' if $self->{OBJECT};
1283
1284     if ($self->{PERL_SRC}) {
1285         my(@macros);
1286         my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
1287         push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
1288         push(@macros,'DECC=1')    if $Config{'vms_cc_type'} eq 'decc';
1289         push(@macros,'GNUC=1')    if $Config{'vms_cc_type'} eq 'gcc';
1290         push(@macros,'SOCKET=1')  if $Config{'d_has_sockets'};
1291         push(@macros,qq["CC=$Config{'cc'}"])  if $Config{'cc'} =~ m!/!;
1292         $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
1293         push(@m,q[
1294 # Check for unpropagated config.sh changes. Should never happen.
1295 # We do NOT just update config.h because that is not sufficient.
1296 # An out of date config.h is not fatal but complains loudly!
1297 $(PERL_INC)config.h : $(PERL_SRC)config.sh
1298         $(NOOP)
1299
1300 $(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
1301         $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
1302         olddef = F$Environment("Default")
1303         Set Default $(PERL_SRC)
1304         $(MMS)],$mmsquals,);
1305         if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
1306             my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
1307             $target =~ s/\Q$prefix/[/;
1308             push(@m," $target");
1309         }
1310         else { push(@m,' $(MMS$TARGET)'); }
1311         push(@m,q[
1312         Set Default 'olddef'
1313 ]);
1314     }
1315
1316     push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
1317       if %{$self->{XS}};
1318
1319     join('',@m);
1320 }
1321
1322
1323 =item makeaperl (override)
1324
1325 Undertake to build a new set of Perl images using VMS commands.  Since
1326 VMS does dynamic loading, it's not necessary to statically link each
1327 extension into the Perl image, so this isn't the normal build path.
1328 Consequently, it hasn't really been tested, and may well be incomplete.
1329
1330 =cut
1331
1332 our %olbs;  # needs to be localized
1333
1334 sub makeaperl {
1335     my($self, %attribs) = @_;
1336     my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
1337       @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
1338     my(@m);
1339     push @m, "
1340 # --- MakeMaker makeaperl section ---
1341 MAP_TARGET    = $target
1342 ";
1343     return join '', @m if $self->{PARENT};
1344
1345     my($dir) = join ":", @{$self->{DIR}};
1346
1347     unless ($self->{MAKEAPERL}) {
1348         push @m, q{
1349 $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
1350         $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
1351         $(NOECHO) $(PERLRUNINST) \
1352                 Makefile.PL DIR=}, $dir, q{ \
1353                 FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
1354                 MAKEAPERL=1 NORECURS=1 };
1355
1356         push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
1357
1358 $(MAP_TARGET) :: $(MAKE_APERL_FILE)
1359         $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
1360 };
1361         push @m, "\n";
1362
1363         return join '', @m;
1364     }
1365
1366
1367     my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen);
1368     local($_);
1369
1370     # The front matter of the linkcommand...
1371     $linkcmd = join ' ', $Config{'ld'},
1372             grep($_, @Config{qw(large split ldflags ccdlflags)});
1373     $linkcmd =~ s/\s+/ /g;
1374
1375     # Which *.olb files could we make use of...
1376     local(%olbs);       # XXX can this be lexical?
1377     $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
1378     require File::Find;
1379     File::Find::find(sub {
1380         return unless m/\Q$self->{LIB_EXT}\E$/;
1381         return if m/^libperl/;
1382
1383         if( exists $self->{INCLUDE_EXT} ){
1384                 my $found = 0;
1385
1386                 (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
1387                 $xx =~ s,/?$_,,;
1388                 $xx =~ s,/,::,g;
1389
1390                 # Throw away anything not explicitly marked for inclusion.
1391                 # DynaLoader is implied.
1392                 foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
1393                         if( $xx eq $incl ){
1394                                 $found++;
1395                                 last;
1396                         }
1397                 }
1398                 return unless $found;
1399         }
1400         elsif( exists $self->{EXCLUDE_EXT} ){
1401                 (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
1402                 $xx =~ s,/?$_,,;
1403                 $xx =~ s,/,::,g;
1404
1405                 # Throw away anything explicitly marked for exclusion
1406                 foreach my $excl (@{$self->{EXCLUDE_EXT}}){
1407                         return if( $xx eq $excl );
1408                 }
1409         }
1410
1411         $olbs{$ENV{DEFAULT}} = $_;
1412     }, grep( -d $_, @{$searchdirs || []}));
1413
1414     # We trust that what has been handed in as argument will be buildable
1415     $static = [] unless $static;
1416     @olbs{@{$static}} = (1) x @{$static};
1417
1418     $extra = [] unless $extra && ref $extra eq 'ARRAY';
1419     # Sort the object libraries in inverse order of
1420     # filespec length to try to insure that dependent extensions
1421     # will appear before their parents, so the linker will
1422     # search the parent library to resolve references.
1423     # (e.g. Intuit::DWIM will precede Intuit, so unresolved
1424     # references from [.intuit.dwim]dwim.obj can be found
1425     # in [.intuit]intuit.olb).
1426     for (sort { length($a) <=> length($b) } keys %olbs) {
1427         next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
1428         my($dir) = $self->fixpath($_,1);
1429         my($extralibs) = $dir . "extralibs.ld";
1430         my($extopt) = $dir . $olbs{$_};
1431         $extopt =~ s/$self->{LIB_EXT}$/.opt/;
1432         push @optlibs, "$dir$olbs{$_}";
1433         # Get external libraries this extension will need
1434         if (-f $extralibs ) {
1435             my %seenthis;
1436             open my $list, "<", $extralibs or warn $!,next;
1437             while (<$list>) {
1438                 chomp;
1439                 # Include a library in the link only once, unless it's mentioned
1440                 # multiple times within a single extension's options file, in which
1441                 # case we assume the builder needed to search it again later in the
1442                 # link.
1443                 my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
1444                 $libseen{$_}++;  $seenthis{$_}++;
1445                 next if $skip;
1446                 push @$extra,$_;
1447             }
1448         }
1449         # Get full name of extension for ExtUtils::Miniperl
1450         if (-f $extopt) {
1451             open my $opt, '<', $extopt or die $!;
1452             while (<$opt>) {
1453                 next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
1454                 my $pkg = $1;
1455                 $pkg =~ s#__*#::#g;
1456                 push @staticpkgs,$pkg;
1457             }
1458         }
1459     }
1460     # Place all of the external libraries after all of the Perl extension
1461     # libraries in the final link, in order to maximize the opportunity
1462     # for XS code from multiple extensions to resolve symbols against the
1463     # same external library while only including that library once.
1464     push @optlibs, @$extra;
1465
1466     $target = "Perl$Config{'exe_ext'}" unless $target;
1467     my $shrtarget;
1468     ($shrtarget,$targdir) = fileparse($target);
1469     $shrtarget =~ s/^([^.]*)/$1Shr/;
1470     $shrtarget = $targdir . $shrtarget;
1471     $target = "Perlshr.$Config{'dlext'}" unless $target;
1472     $tmpdir = "[]" unless $tmpdir;
1473     $tmpdir = $self->fixpath($tmpdir,1);
1474     if (@optlibs) { $extralist = join(' ',@optlibs); }
1475     else          { $extralist = ''; }
1476     # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
1477     # that's what we're building here).
1478     push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
1479     if ($libperl) {
1480         unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
1481             print STDOUT "Warning: $libperl not found\n";
1482             undef $libperl;
1483         }
1484     }
1485     unless ($libperl) {
1486         if (defined $self->{PERL_SRC}) {
1487             $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
1488         } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
1489         } else {
1490             print STDOUT "Warning: $libperl not found
1491     If you're going to build a static perl binary, make sure perl is installed
1492     otherwise ignore this warning\n";
1493         }
1494     }
1495     $libperldir = $self->fixpath((fileparse($libperl))[1],1);
1496
1497     push @m, '
1498 # Fill in the target you want to produce if it\'s not perl
1499 MAP_TARGET    = ',$self->fixpath($target,0),'
1500 MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
1501 MAP_LINKCMD   = $linkcmd
1502 MAP_PERLINC   = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
1503 MAP_EXTRA     = $extralist
1504 MAP_LIBPERL = ",$self->fixpath($libperl,0),'
1505 ';
1506
1507
1508     push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
1509     foreach (@optlibs) {
1510         push @m,'       $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
1511     }
1512     push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
1513     push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
1514
1515     push @m,'
1516 $(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
1517         $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
1518 $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
1519         $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
1520         $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
1521         $(NOECHO) $(ECHO) "    $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
1522         $(NOECHO) $(ECHO) "To remove the intermediate files, say
1523         $(NOECHO) $(ECHO) "    $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
1524 ';
1525     push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
1526     push @m, "# More from the 255-char line length limit\n";
1527     foreach (@staticpkgs) {
1528         push @m,'       $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
1529     }
1530
1531     push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
1532         $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
1533         $(NOECHO) $(RM_F) %sWritemain.tmp
1534 MAKE_FRAG
1535
1536     push @m, q[
1537 # Still more from the 255-char line length limit
1538 doc_inst_perl :
1539         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1540         $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
1541         $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
1542         $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
1543         $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
1544         $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
1545         $(NOECHO) $(RM_F) .MM_tmp
1546 ];
1547
1548     push @m, "
1549 inst_perl : pure_inst_perl doc_inst_perl
1550         \$(NOECHO) \$(NOOP)
1551
1552 pure_inst_perl : \$(MAP_TARGET)
1553         $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
1554         $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
1555
1556 clean :: map_clean
1557         \$(NOECHO) \$(NOOP)
1558
1559 map_clean :
1560         \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
1561         \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
1562 ";
1563
1564     join '', @m;
1565 }
1566
1567
1568 # --- Output postprocessing section ---
1569
1570 =item maketext_filter (override)
1571
1572 Insure that colons marking targets are preceded by space, in order
1573 to distinguish the target delimiter from a colon appearing as
1574 part of a filespec.
1575
1576 =cut
1577
1578 sub maketext_filter {
1579     my($self, $text) = @_;
1580
1581     $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
1582     return $text;
1583 }
1584
1585 =item prefixify (override)
1586
1587 prefixifying on VMS is simple.  Each should simply be:
1588
1589     perl_root:[some.dir]
1590
1591 which can just be converted to:
1592
1593     volume:[your.prefix.some.dir]
1594
1595 otherwise you get the default layout.
1596
1597 In effect, your search prefix is ignored and $Config{vms_prefix} is
1598 used instead.
1599
1600 =cut
1601
1602 sub prefixify {
1603     my($self, $var, $sprefix, $rprefix, $default) = @_;
1604
1605     # Translate $(PERLPREFIX) to a real path.
1606     $rprefix = $self->eliminate_macros($rprefix);
1607     $rprefix = vmspath($rprefix) if $rprefix;
1608     $sprefix = vmspath($sprefix) if $sprefix;
1609
1610     $default = vmsify($default)
1611       unless $default =~ /\[.*\]/;
1612
1613     (my $var_no_install = $var) =~ s/^install//;
1614     my $path = $self->{uc $var} ||
1615                $ExtUtils::MM_Unix::Config_Override{lc $var} ||
1616                $Config{lc $var} || $Config{lc $var_no_install};
1617
1618     if( !$path ) {
1619         print STDERR "  no Config found for $var.\n" if $Verbose >= 2;
1620         $path = $self->_prefixify_default($rprefix, $default);
1621     }
1622     elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
1623         # do nothing if there's no prefix or if its relative
1624     }
1625     elsif( $sprefix eq $rprefix ) {
1626         print STDERR "  no new prefix.\n" if $Verbose >= 2;
1627     }
1628     else {
1629
1630         print STDERR "  prefixify $var => $path\n"     if $Verbose >= 2;
1631         print STDERR "    from $sprefix to $rprefix\n" if $Verbose >= 2;
1632
1633         my($path_vol, $path_dirs) = $self->splitpath( $path );
1634         if( $path_vol eq $Config{vms_prefix}.':' ) {
1635             print STDERR "  $Config{vms_prefix}: seen\n" if $Verbose >= 2;
1636
1637             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
1638             $path = $self->_catprefix($rprefix, $path_dirs);
1639         }
1640         else {
1641             $path = $self->_prefixify_default($rprefix, $default);
1642         }
1643     }
1644
1645     print "    now $path\n" if $Verbose >= 2;
1646     return $self->{uc $var} = $path;
1647 }
1648
1649
1650 sub _prefixify_default {
1651     my($self, $rprefix, $default) = @_;
1652
1653     print STDERR "  cannot prefix, using default.\n" if $Verbose >= 2;
1654
1655     if( !$default ) {
1656         print STDERR "No default!\n" if $Verbose >= 1;
1657         return;
1658     }
1659     if( !$rprefix ) {
1660         print STDERR "No replacement prefix!\n" if $Verbose >= 1;
1661         return '';
1662     }
1663
1664     return $self->_catprefix($rprefix, $default);
1665 }
1666
1667 sub _catprefix {
1668     my($self, $rprefix, $default) = @_;
1669
1670     my($rvol, $rdirs) = $self->splitpath($rprefix);
1671     if( $rvol ) {
1672         return $self->catpath($rvol,
1673                                    $self->catdir($rdirs, $default),
1674                                    ''
1675                                   )
1676     }
1677     else {
1678         return $self->catdir($rdirs, $default);
1679     }
1680 }
1681
1682
1683 =item cd
1684
1685 =cut
1686
1687 sub cd {
1688     my($self, $dir, @cmds) = @_;
1689
1690     $dir = vmspath($dir);
1691
1692     my $cmd = join "\n\t", map "$_", @cmds;
1693
1694     # No leading tab makes it look right when embedded
1695     my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
1696 startdir = F$Environment("Default")
1697         Set Default %s
1698         %s
1699         Set Default 'startdir'
1700 MAKE_FRAG
1701
1702     # No trailing newline makes this easier to embed
1703     chomp $make_frag;
1704
1705     return $make_frag;
1706 }
1707
1708
1709 =item oneliner
1710
1711 =cut
1712
1713 sub oneliner {
1714     my($self, $cmd, $switches) = @_;
1715     $switches = [] unless defined $switches;
1716
1717     # Strip leading and trailing newlines
1718     $cmd =~ s{^\n+}{};
1719     $cmd =~ s{\n+$}{};
1720
1721     $cmd = $self->quote_literal($cmd);
1722     $cmd = $self->escape_newlines($cmd);
1723
1724     # Switches must be quoted else they will be lowercased.
1725     $switches = join ' ', map { qq{"$_"} } @$switches;
1726
1727     return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
1728 }
1729
1730
1731 =item B<echo>
1732
1733 perl trips up on "<foo>" thinking it's an input redirect.  So we use the
1734 native Write command instead.  Besides, its faster.
1735
1736 =cut
1737
1738 sub echo {
1739     my($self, $text, $file, $appending) = @_;
1740     $appending ||= 0;
1741
1742     my $opencmd = $appending ? 'Open/Append' : 'Open/Write';
1743
1744     my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
1745     push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) }
1746                 split /\n/, $text;
1747     push @cmds, '$(NOECHO) Close MMECHOFILE';
1748     return @cmds;
1749 }
1750
1751
1752 =item quote_literal
1753
1754 =cut
1755
1756 sub quote_literal {
1757     my($self, $text) = @_;
1758
1759     # I believe this is all we should need.
1760     $text =~ s{"}{""}g;
1761
1762     return qq{"$text"};
1763 }
1764
1765 =item escape_newlines
1766
1767 =cut
1768
1769 sub escape_newlines {
1770     my($self, $text) = @_;
1771
1772     $text =~ s{\n}{-\n}g;
1773
1774     return $text;
1775 }
1776
1777 =item max_exec_len
1778
1779 256 characters.
1780
1781 =cut
1782
1783 sub max_exec_len {
1784     my $self = shift;
1785
1786     return $self->{_MAX_EXEC_LEN} ||= 256;
1787 }
1788
1789 =item init_linker
1790
1791 =cut
1792
1793 sub init_linker {
1794     my $self = shift;
1795     $self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
1796
1797     my $shr = $Config{dbgprefix} . 'PERLSHR';
1798     if ($self->{PERL_SRC}) {
1799         $self->{PERL_ARCHIVE} ||=
1800           $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
1801     }
1802     else {
1803         $self->{PERL_ARCHIVE} ||=
1804           $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
1805     }
1806
1807     $self->{PERL_ARCHIVE_AFTER} ||= '';
1808 }
1809
1810
1811 =item catdir (override)
1812
1813 =item catfile (override)
1814
1815 Eliminate the macros in the output to the MMS/MMK file.
1816
1817 (File::Spec::VMS used to do this for us, but it's being removed)
1818
1819 =cut
1820
1821 sub catdir {
1822     my $self = shift;
1823
1824     # Process the macros on VMS MMS/MMK
1825     my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_  } @_;
1826
1827     my $dir = $self->SUPER::catdir(@args);
1828
1829     # Fix up the directory and force it to VMS format.
1830     $dir = $self->fixpath($dir, 1);
1831
1832     return $dir;
1833 }
1834
1835 sub catfile {
1836     my $self = shift;
1837
1838     # Process the macros on VMS MMS/MMK
1839     my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_  } @_;
1840
1841     my $file = $self->SUPER::catfile(@args);
1842
1843     $file = vmsify($file);
1844
1845     return $file
1846 }
1847
1848
1849 =item eliminate_macros
1850
1851 Expands MM[KS]/Make macros in a text string, using the contents of
1852 identically named elements of C<%$self>, and returns the result
1853 as a file specification in Unix syntax.
1854
1855 NOTE:  This is the canonical version of the method.  The version in
1856 File::Spec::VMS is deprecated.
1857
1858 =cut
1859
1860 sub eliminate_macros {
1861     my($self,$path) = @_;
1862     return '' unless $path;
1863     $self = {} unless ref $self;
1864
1865     if ($path =~ /\s/) {
1866       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1867     }
1868
1869     my($npath) = unixify($path);
1870     # sometimes unixify will return a string with an off-by-one trailing null
1871     $npath =~ s{\0$}{};
1872
1873     my($complex) = 0;
1874     my($head,$macro,$tail);
1875
1876     # perform m##g in scalar context so it acts as an iterator
1877     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
1878         if (defined $self->{$2}) {
1879             ($head,$macro,$tail) = ($1,$2,$3);
1880             if (ref $self->{$macro}) {
1881                 if (ref $self->{$macro} eq 'ARRAY') {
1882                     $macro = join ' ', @{$self->{$macro}};
1883                 }
1884                 else {
1885                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1886                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1887                     $macro = "\cB$macro\cB";
1888                     $complex = 1;
1889                 }
1890             }
1891             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1892             $npath = "$head$macro$tail";
1893         }
1894     }
1895     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1896     $npath;
1897 }
1898
1899 =item fixpath
1900
1901    my $path = $mm->fixpath($path);
1902    my $path = $mm->fixpath($path, $is_dir);
1903
1904 Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
1905 in any directory specification, in order to avoid juxtaposing two
1906 VMS-syntax directories when MM[SK] is run.  Also expands expressions which
1907 are all macro, so that we can tell how long the expansion is, and avoid
1908 overrunning DCL's command buffer when MM[KS] is running.
1909
1910 fixpath() checks to see whether the result matches the name of a
1911 directory in the current default directory and returns a directory or
1912 file specification accordingly.  C<$is_dir> can be set to true to
1913 force fixpath() to consider the path to be a directory or false to force
1914 it to be a file.
1915
1916 NOTE:  This is the canonical version of the method.  The version in
1917 File::Spec::VMS is deprecated.
1918
1919 =cut
1920
1921 sub fixpath {
1922     my($self,$path,$force_path) = @_;
1923     return '' unless $path;
1924     $self = bless {}, $self unless ref $self;
1925     my($fixedpath,$prefix,$name);
1926
1927     if ($path =~ /[ \t]/) {
1928       return join ' ',
1929              map { $self->fixpath($_,$force_path) }
1930              split /[ \t]+/, $path;
1931     }
1932
1933     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
1934         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
1935             $fixedpath = vmspath($self->eliminate_macros($path));
1936         }
1937         else {
1938             $fixedpath = vmsify($self->eliminate_macros($path));
1939         }
1940     }
1941     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
1942         my($vmspre) = $self->eliminate_macros("\$($prefix)");
1943         # is it a dir or just a name?
1944         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
1945         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
1946         $fixedpath = vmspath($fixedpath) if $force_path;
1947     }
1948     else {
1949         $fixedpath = $path;
1950         $fixedpath = vmspath($fixedpath) if $force_path;
1951     }
1952     # No hints, so we try to guess
1953     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
1954         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
1955     }
1956
1957     # Trim off root dirname if it's had other dirs inserted in front of it.
1958     $fixedpath =~ s/\.000000([\]>])/$1/;
1959     # Special case for VMS absolute directory specs: these will have had device
1960     # prepended during trip through Unix syntax in eliminate_macros(), since
1961     # Unix syntax has no way to express "absolute from the top of this device's
1962     # directory tree".
1963     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
1964
1965     return $fixedpath;
1966 }
1967
1968
1969 =item os_flavor
1970
1971 VMS is VMS.
1972
1973 =cut
1974
1975 sub os_flavor {
1976     return('VMS');
1977 }
1978
1979 =back
1980
1981
1982 =head1 AUTHOR
1983
1984 Original author Charles Bailey F<bailey@newman.upenn.edu>
1985
1986 Maintained by Michael G Schwern F<schwern@pobox.com>
1987
1988 See L<ExtUtils::MakeMaker> for patching and contact information.
1989
1990
1991 =cut
1992
1993 1;
1994