lib/ExtUtils/MM_VMS.pm

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