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