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