lib/ExtUtils/MM_VMS.pm

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