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