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