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 = substr(q$Revision: 1.91 $, 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
 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 realclean ::
1200 ";
1201
1202     my $line = '';
1203     foreach $to (@to) {
1204         if (length($line) + length($to) > 80) {
1205             push @m, "\t\$(RM_F) $line\n";
1206             $line = $to;
1207         }
1208         else { $line .= " $to"; }
1209     }
1210     push @m, "\t\$(RM_F) $line\n\n" if $line;
1211
1212     while (($from,$to) = each %fromto) {
1213         last unless defined $from;
1214         my $todir;
1215         if ($to =~ m#[/>:\]]#) { $todir = dirname($to); }
1216         else                   { ($todir = $to) =~ s/[^\)]+$//; }
1217         $todir = $self->fixpath($todir,1);
1218         push @m, "
1219 $to : $from \$(FIRST_MAKEFILE) ${todir}\$(DIRFILESEP).exists
1220         \$(CP) $from $to
1221
1222 ", $self->dir_target($todir);
1223     }
1224     join "", @m;
1225 }
1226
1227 =item subdir_x (override)
1228
1229 Use VMS commands to change default directory.
1230
1231 =cut
1232
1233 sub subdir_x {
1234     my($self, $subdir) = @_;
1235     my(@m,$key);
1236     $subdir = $self->fixpath($subdir,1);
1237     push @m, '
1238
1239 subdirs ::
1240         olddef = F$Environment("Default")
1241         Set Default ',$subdir,'
1242         - $(MMS)$(MMSQUALIFIERS) all $(USEMACROS)$(PASTHRU)$(MACROEND)
1243         Set Default \'olddef\'
1244 ';
1245     join('',@m);
1246 }
1247
1248 =item clean (override)
1249
1250 Split potentially long list of files across multiple commands (in
1251 order to stay under the magic command line limit).  Also use MM[SK]
1252 commands for handling subdirectories.
1253
1254 =cut
1255
1256 sub clean {
1257     my($self, %attribs) = @_;
1258     my(@m,$dir);
1259     push @m, '
1260 # Delete temporary files but do not touch installed files. We don\'t delete
1261 # the Descrip.MMS here so that a later make realclean still has it to use.
1262 clean :: clean_subdirs
1263 ';
1264     push @m, '  $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso .MM_Tmp
1265 ';
1266
1267     my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
1268     # Unlink realclean, $attribs{FILES} is a string here; it may contain
1269     # a list or a macro that expands to a list.
1270     if ($attribs{FILES}) {
1271         my @filelist = ref $attribs{FILES} eq 'ARRAY'
1272             ? @{$attribs{FILES}}
1273             : split /\s+/, $attribs{FILES};
1274
1275         foreach my $word (@filelist) {
1276             if ($word =~ m#^\$\((.*)\)$# and
1277                 ref $self->{$1} eq 'ARRAY')
1278             {
1279                 push(@otherfiles, @{$self->{$1}});
1280             }
1281             else { push(@otherfiles, $word); }
1282         }
1283     }
1284     push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld
1285                           perlmain.c pm_to_blib pm_to_blib.ts ]);
1286     push(@otherfiles, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
1287
1288     # Occasionally files are repeated several times from different sources
1289     { my(%of) = map { ($_ => 1) } @otherfiles; @otherfiles = keys %of; }
1290
1291     my $line = '';
1292     foreach my $file (@otherfiles) {
1293         $file = $self->fixpath($file);
1294         if (length($line) + length($file) > 80) {
1295             push @m, "\t\$(RM_RF) $line\n";
1296             $line = "$file";
1297         }
1298         else { $line .= " $file"; }
1299     }
1300     push @m, "\t\$(RM_RF) $line\n" if $line;
1301     push(@m, "  $attribs{POSTOP}\n") if $attribs{POSTOP};
1302     join('', @m);
1303 }
1304
1305
1306 =item clean_subdirs_target
1307
1308   my $make_frag = $MM->clean_subdirs_target;
1309
1310 VMS semantics for changing directories and rerunning make very different.
1311
1312 =cut
1313
1314 sub clean_subdirs_target {
1315     my($self) = shift;
1316
1317     # No subdirectories, no cleaning.
1318     return <<'NOOP_FRAG' unless @{$self->{DIR}};
1319 clean_subdirs :
1320         $(NOECHO) $(NOOP)
1321 NOOP_FRAG
1322
1323
1324     my $clean = "clean_subdirs :\n";
1325
1326     foreach my $dir (@{$self->{DIR}}) { # clean subdirectories first
1327         $dir = $self->fixpath($dir,1);
1328
1329         $clean .= sprintf <<'MAKE_FRAG', $dir, $dir;
1330         If F$Search("%s$(FIRST_MAKEFILE)").nes."" Then $(PERLRUN) -e "chdir '%s'; print `$(MMS)$(MMSQUALIFIERS) clean`;"
1331 MAKE_FRAG
1332     }
1333
1334     return $clean;
1335 }
1336
1337
1338 =item realclean (override)
1339
1340 Guess what we're working around?  Also, use MM[SK] for subdirectories.
1341
1342 =cut
1343
1344 sub realclean {
1345     my($self, %attribs) = @_;
1346     my(@m);
1347     push(@m,'
1348 # Delete temporary files (via clean) and also delete installed files
1349 realclean :: clean
1350 ');
1351     foreach(@{$self->{DIR}}){
1352         my($vmsdir) = $self->fixpath($_,1);
1353         push(@m, '      If F$Search("'."$vmsdir".'$(FIRST_MAKEFILE)").nes."" Then \\',"\n\t",
1354               '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS)$(MMSQUALIFIERS) realclean`;"',"\n");
1355     }
1356     push @m, "  \$(RM_RF) \$(INST_AUTODIR) \$(INST_ARCHAUTODIR)\n";
1357     push @m, "  \$(RM_RF) \$(DISTVNAME)\n";
1358     # We can't expand several of the MMS macros here, since they don't have
1359     # corresponding %$self keys (i.e. they're defined in Descrip.MMS as a
1360     # combination of macros).  In order to stay below DCL's 255 char limit,
1361     # we put only 2 on a line.
1362     my($file,$fcnt);
1363     my(@files) = qw{ $(FIRST_MAKEFILE) $(MAKEFILE_OLD) };
1364     if ($self->has_link_code) {
1365         push(@files,qw{ $(INST_DYNAMIC) $(INST_STATIC) $(INST_BOOT) $(OBJECT) });
1366     }
1367
1368     # Occasionally files are repeated several times from different sources
1369     { my(%f) = map { ($_,1) } @files; @files = keys %f; }
1370
1371     my $line = '';
1372     foreach $file (@files) {
1373         $file = $self->fixpath($file);
1374         if (length($line) + length($file) > 80 || ++$fcnt >= 2) {
1375             push @m, "\t\$(RM_F) $line\n";
1376             $line = "$file";
1377             $fcnt = 0;
1378         }
1379         else { $line .= " $file"; }
1380     }
1381     push @m, "\t\$(RM_F) $line\n" if $line;
1382     if ($attribs{FILES}) {
1383         my($word,$key,@filist,@allfiles);
1384         if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; }
1385         else { @filist = split /\s+/, $attribs{FILES}; }
1386         foreach $word (@filist) {
1387             if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') {
1388                 push(@allfiles, @{$self->{$key}});
1389             }
1390             else { push(@allfiles, $word); }
1391         }
1392         $line = '';
1393         # Occasionally files are repeated several times from different sources
1394         { my(%af) = map { ($_,1) } @allfiles; @allfiles = keys %af; }
1395         foreach $file (@allfiles) {
1396             $file = $self->fixpath($file);
1397             if (length($line) + length($file) > 80) {
1398                 push @m, "\t\$(RM_RF) $line\n";
1399                 $line = "$file";
1400             }
1401             else { $line .= " $file"; }
1402         }
1403         push @m, "\t\$(RM_RF) $line\n" if $line;
1404     }
1405     push(@m, "  $attribs{POSTOP}\n")                     if $attribs{POSTOP};
1406     join('', @m);
1407 }
1408
1409 =item zipfile_target (o)
1410
1411 =item tarfile_target (o)
1412
1413 =item shdist_target (o)
1414
1415 Syntax for invoking shar, tar and zip differs from that for Unix.
1416
1417 =cut
1418
1419 sub zipfile_target {
1420     my($self) = shift;
1421
1422     return <<'MAKE_FRAG';
1423 $(DISTVNAME).zip : distdir
1424         $(PREOP)
1425         $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
1426         $(RM_RF) $(DISTVNAME)
1427         $(POSTOP)
1428 MAKE_FRAG
1429 }
1430
1431 sub tarfile_target {
1432     my($self) = shift;
1433
1434     return <<'MAKE_FRAG';
1435 $(DISTVNAME).tar$(SUFFIX) : distdir
1436         $(PREOP)
1437         $(TO_UNIX)
1438         $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
1439         $(RM_RF) $(DISTVNAME)
1440         $(COMPRESS) $(DISTVNAME).tar
1441         $(POSTOP)
1442 MAKE_FRAG
1443 }
1444
1445 sub shdist_target {
1446     my($self) = shift;
1447
1448     return <<'MAKE_FRAG';
1449 shdist : distdir
1450         $(PREOP)
1451         $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
1452         $(RM_RF) $(DISTVNAME)
1453         $(POSTOP)
1454 MAKE_FRAG
1455 }
1456
1457 =item dist_test (override)
1458
1459 Use VMS commands to change default directory, and use VMS-style
1460 quoting on command line.
1461
1462 =cut
1463
1464 sub dist_test {
1465     my($self) = @_;
1466 q{
1467 disttest : distdir
1468         startdir = F$Environment("Default")
1469         Set Default [.$(DISTVNAME)]
1470         $(ABSPERLRUN) Makefile.PL
1471         $(MMS)$(MMSQUALIFIERS)
1472         $(MMS)$(MMSQUALIFIERS) test
1473         Set Default 'startdir'
1474 };
1475 }
1476
1477 # --- Test and Installation Sections ---
1478
1479 =item install (override)
1480
1481 Work around DCL's 255 character limit several times,and use
1482 VMS-style command line quoting in a few cases.
1483
1484 =cut
1485
1486 sub install {
1487     my($self, %attribs) = @_;
1488     my(@m,@exe_files);
1489
1490     if ($self->{EXE_FILES}) {
1491         my($line,$file) = ('','');
1492         foreach $file (@{$self->{EXE_FILES}}) {
1493             $line .= "$file ";
1494             if (length($line) > 128) {
1495                 push(@exe_files,qq[\t\$(NOECHO) \$(ECHO) "$line" >>.MM_tmp\n]);
1496                 $line = '';
1497             }
1498         }
1499         push(@exe_files,qq[\t\$(NOECHO) \$(ECHO) "$line" >>.MM_tmp\n]) if $line;
1500     }
1501
1502     push @m, q[
1503 install :: all pure_install doc_install
1504         $(NOECHO) $(NOOP)
1505
1506 install_perl :: all pure_perl_install doc_perl_install
1507         $(NOECHO) $(NOOP)
1508
1509 install_site :: all pure_site_install doc_site_install
1510         $(NOECHO) $(NOOP)
1511
1512 pure_install :: pure_$(INSTALLDIRS)_install
1513         $(NOECHO) $(NOOP)
1514
1515 doc_install :: doc_$(INSTALLDIRS)_install
1516         $(NOECHO) $(NOOP)
1517
1518 pure__install : pure_site_install
1519         $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
1520
1521 doc__install : doc_site_install
1522         $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
1523
1524 # This hack brought to you by DCL's 255-character command line limit
1525 pure_perl_install ::
1526         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1527         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1528         $(NOECHO) $(ECHO) "$(INST_LIB) $(INSTALLPRIVLIB) " >>.MM_tmp
1529         $(NOECHO) $(ECHO) "$(INST_ARCHLIB) $(INSTALLARCHLIB) " >>.MM_tmp
1530         $(NOECHO) $(ECHO) "$(INST_BIN) $(INSTALLBIN) " >>.MM_tmp
1531         $(NOECHO) $(ECHO) "$(INST_SCRIPT) $(INSTALLSCRIPT) " >>.MM_tmp
1532         $(NOECHO) $(ECHO) "$(INST_MAN1DIR) $(INSTALLMAN1DIR) " >>.MM_tmp
1533         $(NOECHO) $(ECHO) "$(INST_MAN3DIR) $(INSTALLMAN3DIR) " >>.MM_tmp
1534         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1535         $(NOECHO) $(RM_F) .MM_tmp
1536         $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
1537
1538 # Likewise
1539 pure_site_install ::
1540         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1541         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1542         $(NOECHO) $(ECHO) "$(INST_LIB) $(INSTALLSITELIB) " >>.MM_tmp
1543         $(NOECHO) $(ECHO) "$(INST_ARCHLIB) $(INSTALLSITEARCH) " >>.MM_tmp
1544         $(NOECHO) $(ECHO) "$(INST_BIN) $(INSTALLSITEBIN) " >>.MM_tmp
1545         $(NOECHO) $(ECHO) "$(INST_SCRIPT) $(INSTALLSCRIPT) " >>.MM_tmp
1546         $(NOECHO) $(ECHO) "$(INST_MAN1DIR) $(INSTALLSITEMAN1DIR) " >>.MM_tmp
1547         $(NOECHO) $(ECHO) "$(INST_MAN3DIR) $(INSTALLSITEMAN3DIR) " >>.MM_tmp
1548         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1549         $(NOECHO) $(RM_F) .MM_tmp
1550         $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
1551
1552 pure_vendor_install ::
1553         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1554         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(INSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1555         $(NOECHO) $(ECHO) "$(INST_LIB) $(INSTALLVENDORLIB) " >>.MM_tmp
1556         $(NOECHO) $(ECHO) "$(INST_ARCHLIB) $(INSTALLVENDORARCH) " >>.MM_tmp
1557         $(NOECHO) $(ECHO) "$(INST_BIN) $(INSTALLVENDORBIN) " >>.MM_tmp
1558         $(NOECHO) $(ECHO) "$(INST_SCRIPT) $(INSTALLSCRIPT) " >>.MM_tmp
1559         $(NOECHO) $(ECHO) "$(INST_MAN1DIR) $(INSTALLVENDORMAN1DIR) " >>.MM_tmp
1560         $(NOECHO) $(ECHO) "$(INST_MAN3DIR) $(INSTALLVENDORMAN3DIR) " >>.MM_tmp
1561         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1562         $(NOECHO) $(RM_F) .MM_tmp
1563
1564 # Ditto
1565 doc_perl_install ::
1566         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{INSTALLARCHLIB}, 'perllocal.pod').q["
1567         $(NOECHO) $(MKPATH) $(INSTALLARCHLIB)
1568         $(NOECHO) $(ECHO) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
1569         $(NOECHO) $(ECHO) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1570 ],@exe_files,
1571 q[      $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{INSTALLARCHLIB},'perllocal.pod').q[
1572         $(NOECHO) $(RM_F) .MM_tmp
1573
1574 # And again
1575 doc_site_install ::
1576         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{INSTALLSITEARCH}, 'perllocal.pod').q["
1577         $(NOECHO) $(MKPATH) $(INSTALLSITEARCH)
1578         $(NOECHO) $(ECHO) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
1579         $(NOECHO) $(ECHO) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1580 ],@exe_files,
1581 q[      $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{INSTALLSITEARCH},'perllocal.pod').q[
1582         $(NOECHO) $(RM_F) .MM_tmp
1583
1584 doc_vendor_install ::
1585         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{INSTALLVENDORARCH}, 'perllocal.pod').q["
1586         $(NOECHO) $(MKPATH) $(INSTALLVENDORARCH)
1587         $(NOECHO) $(ECHO) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
1588         $(NOECHO) $(ECHO) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1589 ],@exe_files,
1590 q[      $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{INSTALLVENDORARCH},'perllocal.pod').q[
1591         $(NOECHO) $(RM_F) .MM_tmp
1592
1593 ];
1594
1595     push @m, q[
1596 uninstall :: uninstall_from_$(INSTALLDIRS)dirs
1597         $(NOECHO) $(NOOP)
1598
1599 uninstall_from_perldirs ::
1600         $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').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 uninstall_from_sitedirs ::
1606         $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'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
1612     join('',@m);
1613 }
1614
1615 =item perldepend (override)
1616
1617 Use VMS-style syntax for files; it's cheaper to just do it directly here
1618 than to have the MM_Unix method call C<catfile> repeatedly.  Also, if
1619 we have to rebuild Config.pm, use MM[SK] to do it.
1620
1621 =cut
1622
1623 sub perldepend {
1624     my($self) = @_;
1625     my(@m);
1626
1627     push @m, '
1628 $(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h
1629 $(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h
1630 $(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h
1631 $(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)fakethr.h, $(PERL_INC)form.h
1632 $(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h
1633 $(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h
1634 $(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h
1635 $(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)opnames.h, $(PERL_INC)patchlevel.h
1636 $(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlapi.h, $(PERL_INC)perlio.h
1637 $(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlsfio.h, $(PERL_INC)perlvars.h
1638 $(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h
1639 $(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h
1640 $(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
1641 $(OBJECT) : $(PERL_INC)thrdvar.h, $(PERL_INC)thread.h, $(PERL_INC)utf8.h
1642 $(OBJECT) : $(PERL_INC)util.h, $(PERL_INC)vmsish.h, $(PERL_INC)warnings.h
1643
1644 ' if $self->{OBJECT};
1645
1646     if ($self->{PERL_SRC}) {
1647         my(@macros);
1648         my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
1649         push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
1650         push(@macros,'DECC=1')    if $Config{'vms_cc_type'} eq 'decc';
1651         push(@macros,'GNUC=1')    if $Config{'vms_cc_type'} eq 'gcc';
1652         push(@macros,'SOCKET=1')  if $Config{'d_has_sockets'};
1653         push(@macros,qq["CC=$Config{'cc'}"])  if $Config{'cc'} =~ m!/!;
1654         $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
1655         push(@m,q[
1656 # Check for unpropagated config.sh changes. Should never happen.
1657 # We do NOT just update config.h because that is not sufficient.
1658 # An out of date config.h is not fatal but complains loudly!
1659 $(PERL_INC)config.h : $(PERL_SRC)config.sh
1660         $(NOOP)
1661
1662 $(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
1663         $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
1664         olddef = F$Environment("Default")
1665         Set Default $(PERL_SRC)
1666         $(MMS)],$mmsquals,);
1667         if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
1668             my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
1669             $target =~ s/\Q$prefix/[/;
1670             push(@m," $target");
1671         }
1672         else { push(@m,' $(MMS$TARGET)'); }
1673         push(@m,q[
1674         Set Default 'olddef'
1675 ]);
1676     }
1677
1678     push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
1679       if %{$self->{XS}};
1680
1681     join('',@m);
1682 }
1683
1684 =item makefile (override)
1685
1686 Use VMS commands and quoting.
1687
1688 =cut
1689
1690 sub makefile {
1691     my($self) = @_;
1692     my(@m,@cmd);
1693     # We do not know what target was originally specified so we
1694     # must force a manual rerun to be sure. But as it should only
1695     # happen very rarely it is not a significant problem.
1696     push @m, q[
1697 $(OBJECT) : $(FIRST_MAKEFILE)
1698 ] if $self->{OBJECT};
1699
1700     push @m,q[
1701 # We take a very conservative approach here, but it\'s worth it.
1702 # We move $(FIRST_MAKEFILE) to $(MAKEFILE_OLD) here to avoid gnu make looping.
1703 $(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
1704         $(NOECHO) $(ECHO) "$(FIRST_MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)"
1705         $(NOECHO) $(ECHO) "Cleaning current config before rebuilding $(FIRST_MAKEFILE) ..."
1706         - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
1707         - $(MMS)$(MMSQUALIFIERS) $(USEMAKEFILE)$(MAKEFILE_OLD) clean
1708         $(PERLRUN) Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[
1709         $(NOECHO) $(ECHO) "$(FIRST_MAKEFILE) has been rebuilt."
1710         $(NOECHO) $(ECHO) "Please run $(MMS) to build the extension."
1711 ];
1712
1713     join('',@m);
1714 }
1715
1716 =item find_tests (override)
1717
1718 =cut
1719
1720 sub find_tests {
1721     my $self = shift;
1722     return -d 't' ? 't/*.t' : '';
1723 }
1724
1725 =item test (override)
1726
1727 Use VMS commands for handling subdirectories.
1728
1729 =cut
1730
1731 sub test {
1732     my($self, %attribs) = @_;
1733     my($tests) = $attribs{TESTS} || $self->find_tests;
1734     my(@m);
1735     push @m,"
1736 TEST_VERBOSE = 0
1737 TEST_TYPE = test_\$(LINKTYPE)
1738 TEST_FILE = test.pl
1739 TESTDB_SW = -d
1740
1741 test :: \$(TEST_TYPE)
1742         \$(NOECHO) \$(NOOP)
1743
1744 testdb :: testdb_\$(LINKTYPE)
1745         \$(NOECHO) \$(NOOP)
1746
1747 ";
1748     foreach(@{$self->{DIR}}){
1749       my($vmsdir) = $self->fixpath($_,1);
1750       push(@m, '        If F$Search("',$vmsdir,'$(FIRST_MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'",
1751            '; print `$(MMS)$(MMSQUALIFIERS) $(PASTHRU2) test`'."\n");
1752     }
1753     push(@m, "\t\$(NOECHO) \$(ECHO) \"No tests defined for \$(NAME) extension.\"\n")
1754         unless $tests or -f "test.pl" or @{$self->{DIR}};
1755     push(@m, "\n");
1756
1757     push(@m, "test_dynamic :: pure_all\n");
1758     push(@m, $self->test_via_harness('$(FULLPERLRUN)', $tests)) if $tests;
1759     push(@m, $self->test_via_script('$(FULLPERLRUN)', 'test.pl')) if -f "test.pl";
1760     push(@m, "\t\$(NOECHO) \$(NOOP)\n") if (!$tests && ! -f "test.pl");
1761     push(@m, "\n");
1762
1763     push(@m, "testdb_dynamic :: pure_all\n");
1764     push(@m, $self->test_via_script('$(FULLPERLRUN) "$(TESTDB_SW)"', '$(TEST_FILE)'));
1765     push(@m, "\n");
1766
1767     # Occasionally we may face this degenerate target:
1768     push @m, "test_ : test_dynamic\n\n";
1769
1770     if ($self->needs_linking()) {
1771         push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
1772         push(@m, $self->test_via_harness('$(MAP_TARGET)', $tests)) if $tests;
1773         push(@m, $self->test_via_script('$(MAP_TARGET)', 'test.pl')) if -f 'test.pl';
1774         push(@m, "\n");
1775         push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
1776         push(@m, $self->test_via_script('$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
1777         push(@m, "\n");
1778     }
1779     else {
1780         push @m, "test_static :: test_dynamic\n\t\$(NOECHO) \$(NOOP)\n\n";
1781         push @m, "testdb_static :: testdb_dynamic\n\t\$(NOECHO) \$(NOOP)\n";
1782     }
1783
1784     join('',@m);
1785 }
1786
1787 =item makeaperl (override)
1788
1789 Undertake to build a new set of Perl images using VMS commands.  Since
1790 VMS does dynamic loading, it's not necessary to statically link each
1791 extension into the Perl image, so this isn't the normal build path.
1792 Consequently, it hasn't really been tested, and may well be incomplete.
1793
1794 =cut
1795
1796 use vars qw(%olbs);
1797
1798 sub makeaperl {
1799     my($self, %attribs) = @_;
1800     my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
1801       @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
1802     my(@m);
1803     push @m, "
1804 # --- MakeMaker makeaperl section ---
1805 MAP_TARGET    = $target
1806 ";
1807     return join '', @m if $self->{PARENT};
1808
1809     my($dir) = join ":", @{$self->{DIR}};
1810
1811     unless ($self->{MAKEAPERL}) {
1812         push @m, q{
1813 $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
1814         $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
1815         $(NOECHO) $(PERLRUNINST) \
1816                 Makefile.PL DIR=}, $dir, q{ \
1817                 FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
1818                 MAKEAPERL=1 NORECURS=1 };
1819
1820         push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
1821
1822 $(MAP_TARGET) :: $(MAKE_APERL_FILE)
1823         $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
1824 };
1825         push @m, "\n";
1826
1827         return join '', @m;
1828     }
1829
1830
1831     my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen);
1832     local($_);
1833
1834     # The front matter of the linkcommand...
1835     $linkcmd = join ' ', $Config{'ld'},
1836             grep($_, @Config{qw(large split ldflags ccdlflags)});
1837     $linkcmd =~ s/\s+/ /g;
1838
1839     # Which *.olb files could we make use of...
1840     local(%olbs);       # XXX can this be lexical?
1841     $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
1842     require File::Find;
1843     File::Find::find(sub {
1844         return unless m/\Q$self->{LIB_EXT}\E$/;
1845         return if m/^libperl/;
1846
1847         if( exists $self->{INCLUDE_EXT} ){
1848                 my $found = 0;
1849                 my $incl;
1850                 my $xx;
1851
1852                 ($xx = $File::Find::name) =~ s,.*?/auto/,,;
1853                 $xx =~ s,/?$_,,;
1854                 $xx =~ s,/,::,g;
1855
1856                 # Throw away anything not explicitly marked for inclusion.
1857                 # DynaLoader is implied.
1858                 foreach $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
1859                         if( $xx eq $incl ){
1860                                 $found++;
1861                                 last;
1862                         }
1863                 }
1864                 return unless $found;
1865         }
1866         elsif( exists $self->{EXCLUDE_EXT} ){
1867                 my $excl;
1868                 my $xx;
1869
1870                 ($xx = $File::Find::name) =~ s,.*?/auto/,,;
1871                 $xx =~ s,/?$_,,;
1872                 $xx =~ s,/,::,g;
1873
1874                 # Throw away anything explicitly marked for exclusion
1875                 foreach $excl (@{$self->{EXCLUDE_EXT}}){
1876                         return if( $xx eq $excl );
1877                 }
1878         }
1879
1880         $olbs{$ENV{DEFAULT}} = $_;
1881     }, grep( -d $_, @{$searchdirs || []}));
1882
1883     # We trust that what has been handed in as argument will be buildable
1884     $static = [] unless $static;
1885     @olbs{@{$static}} = (1) x @{$static};
1886
1887     $extra = [] unless $extra && ref $extra eq 'ARRAY';
1888     # Sort the object libraries in inverse order of
1889     # filespec length to try to insure that dependent extensions
1890     # will appear before their parents, so the linker will
1891     # search the parent library to resolve references.
1892     # (e.g. Intuit::DWIM will precede Intuit, so unresolved
1893     # references from [.intuit.dwim]dwim.obj can be found
1894     # in [.intuit]intuit.olb).
1895     for (sort { length($a) <=> length($b) } keys %olbs) {
1896         next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
1897         my($dir) = $self->fixpath($_,1);
1898         my($extralibs) = $dir . "extralibs.ld";
1899         my($extopt) = $dir . $olbs{$_};
1900         $extopt =~ s/$self->{LIB_EXT}$/.opt/;
1901         push @optlibs, "$dir$olbs{$_}";
1902         # Get external libraries this extension will need
1903         if (-f $extralibs ) {
1904             my %seenthis;
1905             open LIST,$extralibs or warn $!,next;
1906             while (<LIST>) {
1907                 chomp;
1908                 # Include a library in the link only once, unless it's mentioned
1909                 # multiple times within a single extension's options file, in which
1910                 # case we assume the builder needed to search it again later in the
1911                 # link.
1912                 my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
1913                 $libseen{$_}++;  $seenthis{$_}++;
1914                 next if $skip;
1915                 push @$extra,$_;
1916             }
1917             close LIST;
1918         }
1919         # Get full name of extension for ExtUtils::Miniperl
1920         if (-f $extopt) {
1921             open OPT,$extopt or die $!;
1922             while (<OPT>) {
1923                 next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
1924                 my $pkg = $1;
1925                 $pkg =~ s#__*#::#g;
1926                 push @staticpkgs,$pkg;
1927             }
1928         }
1929     }
1930     # Place all of the external libraries after all of the Perl extension
1931     # libraries in the final link, in order to maximize the opportunity
1932     # for XS code from multiple extensions to resolve symbols against the
1933     # same external library while only including that library once.
1934     push @optlibs, @$extra;
1935
1936     $target = "Perl$Config{'exe_ext'}" unless $target;
1937     my $shrtarget;
1938     ($shrtarget,$targdir) = fileparse($target);
1939     $shrtarget =~ s/^([^.]*)/$1Shr/;
1940     $shrtarget = $targdir . $shrtarget;
1941     $target = "Perlshr.$Config{'dlext'}" unless $target;
1942     $tmpdir = "[]" unless $tmpdir;
1943     $tmpdir = $self->fixpath($tmpdir,1);
1944     if (@optlibs) { $extralist = join(' ',@optlibs); }
1945     else          { $extralist = ''; }
1946     # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
1947     # that's what we're building here).
1948     push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
1949     if ($libperl) {
1950         unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
1951             print STDOUT "Warning: $libperl not found\n";
1952             undef $libperl;
1953         }
1954     }
1955     unless ($libperl) {
1956         if (defined $self->{PERL_SRC}) {
1957             $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
1958         } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
1959         } else {
1960             print STDOUT "Warning: $libperl not found
1961     If you're going to build a static perl binary, make sure perl is installed
1962     otherwise ignore this warning\n";
1963         }
1964     }
1965     $libperldir = $self->fixpath((fileparse($libperl))[1],1);
1966
1967     push @m, '
1968 # Fill in the target you want to produce if it\'s not perl
1969 MAP_TARGET    = ',$self->fixpath($target,0),'
1970 MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
1971 MAP_LINKCMD   = $linkcmd
1972 MAP_PERLINC   = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
1973 MAP_EXTRA     = $extralist
1974 MAP_LIBPERL = ",$self->fixpath($libperl,0),'
1975 ';
1976
1977
1978     push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
1979     foreach (@optlibs) {
1980         push @m,'       $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
1981     }
1982     push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
1983     push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
1984
1985     push @m,'
1986 $(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
1987         $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
1988 $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
1989         $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
1990         $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
1991         $(NOECHO) $(ECHO) "    $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
1992         $(NOECHO) $(ECHO) "To remove the intermediate files, say
1993         $(NOECHO) $(ECHO) "    $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
1994 ';
1995     push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
1996     push @m, "# More from the 255-char line length limit\n";
1997     foreach (@staticpkgs) {
1998         push @m,'       $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
1999     }
2000
2001     push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
2002         $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
2003         $(NOECHO) $(RM_F) %sWritemain.tmp
2004 MAKE_FRAG
2005
2006     push @m, q[
2007 # Still more from the 255-char line length limit
2008 doc_inst_perl :
2009         $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
2010         $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
2011         $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
2012         $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
2013         $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
2014         $(NOECHO) $(RM_F) .MM_tmp
2015 ];
2016
2017     push @m, "
2018 inst_perl : pure_inst_perl doc_inst_perl
2019         \$(NOECHO) \$(NOOP)
2020
2021 pure_inst_perl : \$(MAP_TARGET)
2022         $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
2023         $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
2024
2025 clean :: map_clean
2026         \$(NOECHO) \$(NOOP)
2027
2028 map_clean :
2029         \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
2030         \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
2031 ";
2032
2033     join '', @m;
2034 }
2035
2036 # --- Output postprocessing section ---
2037
2038 =item nicetext (override)
2039
2040 Insure that colons marking targets are preceded by space, in order
2041 to distinguish the target delimiter from a colon appearing as
2042 part of a filespec.
2043
2044 =cut
2045
2046 sub nicetext {
2047     my($self,$text) = @_;
2048     return $text if $text =~ m/^\w+\s*=/; # leave macro defs alone
2049     $text =~ s/([^\s:])(:+\s)/$1 $2/gs;
2050     $text;
2051 }
2052
2053 =item prefixify (override)
2054
2055 prefixifying on VMS is simple.  Each should simply be:
2056
2057     perl_root:[some.dir]
2058
2059 which can just be converted to:
2060
2061     volume:[your.prefix.some.dir]
2062
2063 otherwise you get the default layout.
2064
2065 In effect, your search prefix is ignored and $Config{vms_prefix} is
2066 used instead.
2067
2068 =cut
2069
2070 sub prefixify {
2071     my($self, $var, $sprefix, $rprefix, $default) = @_;
2072
2073     # Translate $(PERLPREFIX) to a real path.
2074     $rprefix = $self->eliminate_macros($rprefix);
2075     $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
2076
2077     $default = VMS::Filespec::vmsify($default)
2078       unless $default =~ /\[.*\]/;
2079
2080     (my $var_no_install = $var) =~ s/^install//;
2081     my $path = $self->{uc $var} || $Config{lc $var} ||
2082                $Config{lc $var_no_install};
2083
2084     if( !$path ) {
2085         print STDERR "  no Config found for $var.\n" if $Verbose >= 2;
2086         $path = $self->_prefixify_default($rprefix, $default);
2087     }
2088     elsif( $sprefix eq $rprefix ) {
2089         print STDERR "  no new prefix.\n" if $Verbose >= 2;
2090     }
2091     else {
2092
2093         print STDERR "  prefixify $var => $path\n"     if $Verbose >= 2;
2094         print STDERR "    from $sprefix to $rprefix\n" if $Verbose >= 2;
2095
2096         my($path_vol, $path_dirs) = $self->splitpath( $path );
2097         if( $path_vol eq $Config{vms_prefix}.':' ) {
2098             print STDERR "  $Config{vms_prefix}: seen\n" if $Verbose >= 2;
2099
2100             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
2101             $path = $self->_catprefix($rprefix, $path_dirs);
2102         }
2103         else {
2104             $path = $self->_prefixify_default($rprefix, $default);
2105         }
2106     }
2107
2108     print "    now $path\n" if $Verbose >= 2;
2109     return $self->{uc $var} = $path;
2110 }
2111
2112
2113 sub _prefixify_default {
2114     my($self, $rprefix, $default) = @_;
2115
2116     print STDERR "  cannot prefix, using default.\n" if $Verbose >= 2;
2117
2118     if( !$default ) {
2119         print STDERR "No default!\n" if $Verbose >= 1;
2120         return;
2121     }
2122     if( !$rprefix ) {
2123         print STDERR "No replacement prefix!\n" if $Verbose >= 1;
2124         return '';
2125     }
2126
2127     return $self->_catprefix($rprefix, $default);
2128 }
2129
2130 sub _catprefix {
2131     my($self, $rprefix, $default) = @_;
2132
2133     my($rvol, $rdirs) = $self->splitpath($rprefix);
2134     if( $rvol ) {
2135         return $self->catpath($rvol,
2136                                    $self->catdir($rdirs, $default),
2137                                    ''
2138                                   )
2139     }
2140     else {
2141         return $self->catdir($rdirs, $default);
2142     }
2143 }
2144
2145
2146 =item oneliner (o)
2147
2148 =cut
2149
2150 sub oneliner {
2151     my($self, $cmd, $switches) = @_;
2152     $switches = [] unless defined $switches;
2153
2154     # Strip leading and trailing newlines
2155     $cmd =~ s{^\n+}{};
2156     $cmd =~ s{\n+$}{};
2157
2158     $cmd = $self->quote_literal($cmd);
2159     $cmd = $self->escape_newlines($cmd);
2160
2161     # Switches must be quoted else they will be lowercased.
2162     $switches = join ' ', map { qq{"$_"} } @$switches;
2163
2164     return qq{\$(PERLRUN) $switches -e $cmd};
2165 }
2166
2167
2168 =item B<echo> (o)
2169
2170 perl trips up on "<foo>" thinking it's an input redirect.  So we use the
2171 native Write command instead.  Besides, its faster.
2172
2173 =cut
2174
2175 sub echo {
2176     my($self, $text, $file, $appending) = @_;
2177     $appending ||= 0;
2178
2179     my $opencmd = $appending ? 'Open/Append' : 'Open/Write';
2180
2181     my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
2182     push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) }
2183                 split /\n/, $text;
2184     push @cmds, '$(NOECHO) Close MMECHOFILE';
2185     return @cmds;
2186 }
2187
2188
2189 =item quote_literal
2190
2191 =cut
2192
2193 sub quote_literal {
2194     my($self, $text) = @_;
2195
2196     # I believe this is all we should need.
2197     $text =~ s{"}{""}g;
2198
2199     return qq{"$text"};
2200 }
2201
2202 =item escape_newlines
2203
2204 =cut
2205
2206 sub escape_newlines {
2207     my($self, $text) = @_;
2208
2209     $text =~ s{\n}{-\n}g;
2210
2211     return $text;
2212 }
2213
2214 =item max_exec_len
2215
2216 256 characters.
2217
2218 =cut
2219
2220 sub max_exec_len {
2221     my $self = shift;
2222
2223     return $self->{_MAX_EXEC_LEN} ||= 256;
2224 }
2225
2226 =item init_linker (o)
2227
2228 =cut
2229
2230 sub init_linker {
2231     my $self = shift;
2232     $self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
2233
2234     my $shr = $Config{dbgprefix} . 'PERLSHR';
2235     if ($self->{PERL_SRC}) {
2236         $self->{PERL_ARCHIVE} ||=
2237           $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
2238     }
2239     else {
2240         $self->{PERL_ARCHIVE} ||=
2241           $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
2242     }
2243
2244     $self->{PERL_ARCHIVE_AFTER} ||= '';
2245 }
2246
2247 =item eliminate_macros
2248
2249 Expands MM[KS]/Make macros in a text string, using the contents of
2250 identically named elements of C<%$self>, and returns the result
2251 as a file specification in Unix syntax.
2252
2253 NOTE:  This is the canonical version of the method.  The version in
2254 File::Spec::VMS is deprecated.
2255
2256 =cut
2257
2258 sub eliminate_macros {
2259     my($self,$path) = @_;
2260     return '' unless $path;
2261     $self = {} unless ref $self;
2262
2263     if ($path =~ /\s/) {
2264       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
2265     }
2266
2267     my($npath) = unixify($path);
2268     # sometimes unixify will return a string with an off-by-one trailing null
2269     $npath =~ s{\0$}{};
2270
2271     my($complex) = 0;
2272     my($head,$macro,$tail);
2273
2274     # perform m##g in scalar context so it acts as an iterator
2275     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
2276         if (defined $self->{$2}) {
2277             ($head,$macro,$tail) = ($1,$2,$3);
2278             if (ref $self->{$macro}) {
2279                 if (ref $self->{$macro} eq 'ARRAY') {
2280                     $macro = join ' ', @{$self->{$macro}};
2281                 }
2282                 else {
2283                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
2284                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
2285                     $macro = "\cB$macro\cB";
2286                     $complex = 1;
2287                 }
2288             }
2289             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
2290             $npath = "$head$macro$tail";
2291         }
2292     }
2293     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
2294     $npath;
2295 }
2296
2297 =item fixpath
2298
2299 Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
2300 in any directory specification, in order to avoid juxtaposing two
2301 VMS-syntax directories when MM[SK] is run.  Also expands expressions which
2302 are all macro, so that we can tell how long the expansion is, and avoid
2303 overrunning DCL's command buffer when MM[KS] is running.
2304
2305 If optional second argument has a TRUE value, then the return string is
2306 a VMS-syntax directory specification, if it is FALSE, the return string
2307 is a VMS-syntax file specification, and if it is not specified, fixpath()
2308 checks to see whether it matches the name of a directory in the current
2309 default directory, and returns a directory or file specification accordingly.
2310
2311 NOTE:  This is the canonical version of the method.  The version in
2312 File::Spec::VMS is deprecated.
2313
2314 =cut
2315
2316 sub fixpath {
2317     my($self,$path,$force_path) = @_;
2318     return '' unless $path;
2319     $self = bless {} unless ref $self;
2320     my($fixedpath,$prefix,$name);
2321
2322     if ($path =~ /\s/) {
2323       return join ' ',
2324              map { $self->fixpath($_,$force_path) }
2325              split /\s+/, $path;
2326     }
2327
2328     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
2329         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
2330             $fixedpath = vmspath($self->eliminate_macros($path));
2331         }
2332         else {
2333             $fixedpath = vmsify($self->eliminate_macros($path));
2334         }
2335     }
2336     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
2337         my($vmspre) = $self->eliminate_macros("\$($prefix)");
2338         # is it a dir or just a name?
2339         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
2340         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
2341         $fixedpath = vmspath($fixedpath) if $force_path;
2342     }
2343     else {
2344         $fixedpath = $path;
2345         $fixedpath = vmspath($fixedpath) if $force_path;
2346     }
2347     # No hints, so we try to guess
2348     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
2349         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
2350     }
2351
2352     # Trim off root dirname if it's had other dirs inserted in front of it.
2353     $fixedpath =~ s/\.000000([\]>])/$1/;
2354     # Special case for VMS absolute directory specs: these will have had device
2355     # prepended during trip through Unix syntax in eliminate_macros(), since
2356     # Unix syntax has no way to express "absolute from the top of this device's
2357     # directory tree".
2358     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
2359
2360     return $fixedpath;
2361 }
2362
2363
2364 =item os_flavor
2365
2366 VMS is VMS.
2367
2368 =cut
2369
2370 sub os_flavor {
2371     return('VMS');
2372 }
2373
2374 =back
2375
2376 =cut
2377
2378 1;
2379