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