lib/ExtUtils/MM_VMS.pm

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