This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1d24023a3b62278ba90480e43d3e52437ff3849d
[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.79_01';
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 ];
1194     push @m,
1195 q[      $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1196         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1197 ] unless $self->{NO_PACKLIST};
1198
1199     push @m,
1200 q[      $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
1201         $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp
1202         $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp
1203         $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
1204         $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
1205         $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp
1206         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1207         $(NOECHO) $(RM_F) .MM_tmp
1208         $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
1209
1210 # Likewise
1211 pure_site_install ::
1212 ];
1213     push @m,
1214 q[      $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1215         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1216 ] unless $self->{NO_PACKLIST};
1217
1218     push @m,
1219 q[      $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
1220         $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp
1221         $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp
1222         $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
1223         $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp
1224         $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp
1225         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1226         $(NOECHO) $(RM_F) .MM_tmp
1227         $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
1228
1229 pure_vendor_install ::
1230 ];
1231     push @m,
1232 q[      $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
1233         $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
1234 ] unless $self->{NO_PACKLIST};
1235
1236     push @m,
1237 q[      $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
1238         $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp
1239         $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp
1240         $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
1241         $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp
1242         $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp
1243         $(NOECHO) $(MOD_INSTALL) <.MM_tmp
1244         $(NOECHO) $(RM_F) .MM_tmp
1245
1246 ];
1247
1248     push @m, q[
1249 # Ditto
1250 doc_perl_install ::
1251         $(NOECHO) $(NOOP)
1252
1253 # And again
1254 doc_site_install ::
1255         $(NOECHO) $(NOOP)
1256
1257 doc_vendor_install ::
1258         $(NOECHO) $(NOOP)
1259
1260 ] if $self->{NO_PERLLOCAL};
1261
1262     push @m, q[
1263 # Ditto
1264 doc_perl_install ::
1265         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
1266         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1267         $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
1268         $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1269         $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
1270         $(NOECHO) $(RM_F) .MM_tmp
1271
1272 # And again
1273 doc_site_install ::
1274         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
1275         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1276         $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
1277         $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1278         $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
1279         $(NOECHO) $(RM_F) .MM_tmp
1280
1281 doc_vendor_install ::
1282         $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
1283         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1284         $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
1285         $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
1286         $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
1287         $(NOECHO) $(RM_F) .MM_tmp
1288
1289 ] unless $self->{NO_PERLLOCAL};
1290
1291     push @m, q[
1292 uninstall :: uninstall_from_$(INSTALLDIRS)dirs
1293         $(NOECHO) $(NOOP)
1294
1295 uninstall_from_perldirs ::
1296         $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
1297         $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
1298         $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
1299         $(NOECHO) $(ECHO) "the appropriate files.  Sorry for the inconvenience."
1300
1301 uninstall_from_sitedirs ::
1302         $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
1303         $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
1304         $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
1305         $(NOECHO) $(ECHO) "the appropriate files.  Sorry for the inconvenience."
1306 ];
1307
1308     join('',@m);
1309 }
1310
1311 =item perldepend (override)
1312
1313 Use VMS-style syntax for files; it's cheaper to just do it directly here
1314 than to have the MM_Unix method call C<catfile> repeatedly.  Also, if
1315 we have to rebuild Config.pm, use MM[SK] to do it.
1316
1317 =cut
1318
1319 sub perldepend {
1320     my($self) = @_;
1321     my(@m);
1322
1323     if ($self->{OBJECT}) {
1324         # Need to add an object file dependency on the perl headers.
1325         # this is very important for XS modules in perl.git development.
1326
1327         push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC)
1328     }
1329
1330     if ($self->{PERL_SRC}) {
1331         my(@macros);
1332         my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
1333         push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
1334         push(@macros,'DECC=1')    if $Config{'vms_cc_type'} eq 'decc';
1335         push(@macros,'GNUC=1')    if $Config{'vms_cc_type'} eq 'gcc';
1336         push(@macros,'SOCKET=1')  if $Config{'d_has_sockets'};
1337         push(@macros,qq["CC=$Config{'cc'}"])  if $Config{'cc'} =~ m!/!;
1338         $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
1339         push(@m,q[
1340 # Check for unpropagated config.sh changes. Should never happen.
1341 # We do NOT just update config.h because that is not sufficient.
1342 # An out of date config.h is not fatal but complains loudly!
1343 $(PERL_INC)config.h : $(PERL_SRC)config.sh
1344         $(NOOP)
1345
1346 $(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
1347         $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
1348         olddef = F$Environment("Default")
1349         Set Default $(PERL_SRC)
1350         $(MMS)],$mmsquals,);
1351         if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
1352             my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
1353             $target =~ s/\Q$prefix/[/;
1354             push(@m," $target");
1355         }
1356         else { push(@m,' $(MMS$TARGET)'); }
1357         push(@m,q[
1358         Set Default 'olddef'
1359 ]);
1360     }
1361
1362     push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
1363       if %{$self->{XS}};
1364
1365     join('',@m);
1366 }
1367
1368
1369 =item makeaperl (override)
1370
1371 Undertake to build a new set of Perl images using VMS commands.  Since
1372 VMS does dynamic loading, it's not necessary to statically link each
1373 extension into the Perl image, so this isn't the normal build path.
1374 Consequently, it hasn't really been tested, and may well be incomplete.
1375
1376 =cut
1377
1378 our %olbs;  # needs to be localized
1379
1380 sub makeaperl {
1381     my($self, %attribs) = @_;
1382     my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
1383       @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
1384     my(@m);
1385     push @m, "
1386 # --- MakeMaker makeaperl section ---
1387 MAP_TARGET    = $target
1388 ";
1389     return join '', @m if $self->{PARENT};
1390
1391     my($dir) = join ":", @{$self->{DIR}};
1392
1393     unless ($self->{MAKEAPERL}) {
1394         push @m, q{
1395 $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
1396         $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
1397         $(NOECHO) $(PERLRUNINST) \
1398                 Makefile.PL DIR=}, $dir, q{ \
1399                 FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
1400                 MAKEAPERL=1 NORECURS=1 };
1401
1402         push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
1403
1404 $(MAP_TARGET) :: $(MAKE_APERL_FILE)
1405         $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
1406 };
1407         push @m, "\n";
1408
1409         return join '', @m;
1410     }
1411
1412
1413     my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen);
1414     local($_);
1415
1416     # The front matter of the linkcommand...
1417     $linkcmd = join ' ', $Config{'ld'},
1418             grep($_, @Config{qw(large split ldflags ccdlflags)});
1419     $linkcmd =~ s/\s+/ /g;
1420
1421     # Which *.olb files could we make use of...
1422     local(%olbs);       # XXX can this be lexical?
1423     $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
1424     require File::Find;
1425     File::Find::find(sub {
1426         return unless m/\Q$self->{LIB_EXT}\E$/;
1427         return if m/^libperl/;
1428
1429         if( exists $self->{INCLUDE_EXT} ){
1430                 my $found = 0;
1431
1432                 (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
1433                 $xx =~ s,/?$_,,;
1434                 $xx =~ s,/,::,g;
1435
1436                 # Throw away anything not explicitly marked for inclusion.
1437                 # DynaLoader is implied.
1438                 foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
1439                         if( $xx eq $incl ){
1440                                 $found++;
1441                                 last;
1442                         }
1443                 }
1444                 return unless $found;
1445         }
1446         elsif( exists $self->{EXCLUDE_EXT} ){
1447                 (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
1448                 $xx =~ s,/?$_,,;
1449                 $xx =~ s,/,::,g;
1450
1451                 # Throw away anything explicitly marked for exclusion
1452                 foreach my $excl (@{$self->{EXCLUDE_EXT}}){
1453                         return if( $xx eq $excl );
1454                 }
1455         }
1456
1457         $olbs{$ENV{DEFAULT}} = $_;
1458     }, grep( -d $_, @{$searchdirs || []}));
1459
1460     # We trust that what has been handed in as argument will be buildable
1461     $static = [] unless $static;
1462     @olbs{@{$static}} = (1) x @{$static};
1463
1464     $extra = [] unless $extra && ref $extra eq 'ARRAY';
1465     # Sort the object libraries in inverse order of
1466     # filespec length to try to insure that dependent extensions
1467     # will appear before their parents, so the linker will
1468     # search the parent library to resolve references.
1469     # (e.g. Intuit::DWIM will precede Intuit, so unresolved
1470     # references from [.intuit.dwim]dwim.obj can be found
1471     # in [.intuit]intuit.olb).
1472     for (sort { length($a) <=> length($b) } keys %olbs) {
1473         next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
1474         my($dir) = $self->fixpath($_,1);
1475         my($extralibs) = $dir . "extralibs.ld";
1476         my($extopt) = $dir . $olbs{$_};
1477         $extopt =~ s/$self->{LIB_EXT}$/.opt/;
1478         push @optlibs, "$dir$olbs{$_}";
1479         # Get external libraries this extension will need
1480         if (-f $extralibs ) {
1481             my %seenthis;
1482             open my $list, "<", $extralibs or warn $!,next;
1483             while (<$list>) {
1484                 chomp;
1485                 # Include a library in the link only once, unless it's mentioned
1486                 # multiple times within a single extension's options file, in which
1487                 # case we assume the builder needed to search it again later in the
1488                 # link.
1489                 my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
1490                 $libseen{$_}++;  $seenthis{$_}++;
1491                 next if $skip;
1492                 push @$extra,$_;
1493             }
1494         }
1495         # Get full name of extension for ExtUtils::Miniperl
1496         if (-f $extopt) {
1497             open my $opt, '<', $extopt or die $!;
1498             while (<$opt>) {
1499                 next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
1500                 my $pkg = $1;
1501                 $pkg =~ s#__*#::#g;
1502                 push @staticpkgs,$pkg;
1503             }
1504         }
1505     }
1506     # Place all of the external libraries after all of the Perl extension
1507     # libraries in the final link, in order to maximize the opportunity
1508     # for XS code from multiple extensions to resolve symbols against the
1509     # same external library while only including that library once.
1510     push @optlibs, @$extra;
1511
1512     $target = "Perl$Config{'exe_ext'}" unless $target;
1513     my $shrtarget;
1514     ($shrtarget,$targdir) = fileparse($target);
1515     $shrtarget =~ s/^([^.]*)/$1Shr/;
1516     $shrtarget = $targdir . $shrtarget;
1517     $target = "Perlshr.$Config{'dlext'}" unless $target;
1518     $tmpdir = "[]" unless $tmpdir;
1519     $tmpdir = $self->fixpath($tmpdir,1);
1520     if (@optlibs) { $extralist = join(' ',@optlibs); }
1521     else          { $extralist = ''; }
1522     # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
1523     # that's what we're building here).
1524     push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
1525     if ($libperl) {
1526         unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
1527             print "Warning: $libperl not found\n";
1528             undef $libperl;
1529         }
1530     }
1531     unless ($libperl) {
1532         if (defined $self->{PERL_SRC}) {
1533             $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
1534         } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
1535         } else {
1536             print "Warning: $libperl not found
1537     If you're going to build a static perl binary, make sure perl is installed
1538     otherwise ignore this warning\n";
1539         }
1540     }
1541     $libperldir = $self->fixpath((fileparse($libperl))[1],1);
1542
1543     push @m, '
1544 # Fill in the target you want to produce if it\'s not perl
1545 MAP_TARGET    = ',$self->fixpath($target,0),'
1546 MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
1547 MAP_LINKCMD   = $linkcmd
1548 MAP_PERLINC   = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
1549 MAP_EXTRA     = $extralist
1550 MAP_LIBPERL = ",$self->fixpath($libperl,0),'
1551 ';
1552
1553
1554     push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
1555     foreach (@optlibs) {
1556         push @m,'       $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
1557     }
1558     push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
1559     push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
1560
1561     push @m,'
1562 $(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
1563         $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
1564 $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
1565         $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
1566         $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
1567         $(NOECHO) $(ECHO) "    $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
1568         $(NOECHO) $(ECHO) "To remove the intermediate files, say
1569         $(NOECHO) $(ECHO) "    $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
1570 ';
1571     push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
1572     push @m, "# More from the 255-char line length limit\n";
1573     foreach (@staticpkgs) {
1574         push @m,'       $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
1575     }
1576
1577     push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
1578         $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
1579         $(NOECHO) $(RM_F) %sWritemain.tmp
1580 MAKE_FRAG
1581
1582     push @m, q[
1583 # Still more from the 255-char line length limit
1584 doc_inst_perl :
1585         $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
1586         $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
1587         $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
1588         $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
1589         $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
1590         $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
1591         $(NOECHO) $(RM_F) .MM_tmp
1592 ];
1593
1594     push @m, "
1595 inst_perl : pure_inst_perl doc_inst_perl
1596         \$(NOECHO) \$(NOOP)
1597
1598 pure_inst_perl : \$(MAP_TARGET)
1599         $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
1600         $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
1601
1602 clean :: map_clean
1603         \$(NOECHO) \$(NOOP)
1604
1605 map_clean :
1606         \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
1607         \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
1608 ";
1609
1610     join '', @m;
1611 }
1612
1613
1614 # --- Output postprocessing section ---
1615
1616 =item maketext_filter (override)
1617
1618 Insure that colons marking targets are preceded by space, in order
1619 to distinguish the target delimiter from a colon appearing as
1620 part of a filespec.
1621
1622 =cut
1623
1624 sub maketext_filter {
1625     my($self, $text) = @_;
1626
1627     $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
1628     return $text;
1629 }
1630
1631 =item prefixify (override)
1632
1633 prefixifying on VMS is simple.  Each should simply be:
1634
1635     perl_root:[some.dir]
1636
1637 which can just be converted to:
1638
1639     volume:[your.prefix.some.dir]
1640
1641 otherwise you get the default layout.
1642
1643 In effect, your search prefix is ignored and $Config{vms_prefix} is
1644 used instead.
1645
1646 =cut
1647
1648 sub prefixify {
1649     my($self, $var, $sprefix, $rprefix, $default) = @_;
1650
1651     # Translate $(PERLPREFIX) to a real path.
1652     $rprefix = $self->eliminate_macros($rprefix);
1653     $rprefix = vmspath($rprefix) if $rprefix;
1654     $sprefix = vmspath($sprefix) if $sprefix;
1655
1656     $default = vmsify($default)
1657       unless $default =~ /\[.*\]/;
1658
1659     (my $var_no_install = $var) =~ s/^install//;
1660     my $path = $self->{uc $var} ||
1661                $ExtUtils::MM_Unix::Config_Override{lc $var} ||
1662                $Config{lc $var} || $Config{lc $var_no_install};
1663
1664     if( !$path ) {
1665         warn "  no Config found for $var.\n" if $Verbose >= 2;
1666         $path = $self->_prefixify_default($rprefix, $default);
1667     }
1668     elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
1669         # do nothing if there's no prefix or if its relative
1670     }
1671     elsif( $sprefix eq $rprefix ) {
1672         warn "  no new prefix.\n" if $Verbose >= 2;
1673     }
1674     else {
1675
1676         warn "  prefixify $var => $path\n"     if $Verbose >= 2;
1677         warn "    from $sprefix to $rprefix\n" if $Verbose >= 2;
1678
1679         my($path_vol, $path_dirs) = $self->splitpath( $path );
1680         if( $path_vol eq $Config{vms_prefix}.':' ) {
1681             warn "  $Config{vms_prefix}: seen\n" if $Verbose >= 2;
1682
1683             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
1684             $path = $self->_catprefix($rprefix, $path_dirs);
1685         }
1686         else {
1687             $path = $self->_prefixify_default($rprefix, $default);
1688         }
1689     }
1690
1691     print "    now $path\n" if $Verbose >= 2;
1692     return $self->{uc $var} = $path;
1693 }
1694
1695
1696 sub _prefixify_default {
1697     my($self, $rprefix, $default) = @_;
1698
1699     warn "  cannot prefix, using default.\n" if $Verbose >= 2;
1700
1701     if( !$default ) {
1702         warn "No default!\n" if $Verbose >= 1;
1703         return;
1704     }
1705     if( !$rprefix ) {
1706         warn "No replacement prefix!\n" if $Verbose >= 1;
1707         return '';
1708     }
1709
1710     return $self->_catprefix($rprefix, $default);
1711 }
1712
1713 sub _catprefix {
1714     my($self, $rprefix, $default) = @_;
1715
1716     my($rvol, $rdirs) = $self->splitpath($rprefix);
1717     if( $rvol ) {
1718         return $self->catpath($rvol,
1719                                    $self->catdir($rdirs, $default),
1720                                    ''
1721                                   )
1722     }
1723     else {
1724         return $self->catdir($rdirs, $default);
1725     }
1726 }
1727
1728
1729 =item cd
1730
1731 =cut
1732
1733 sub cd {
1734     my($self, $dir, @cmds) = @_;
1735
1736     $dir = vmspath($dir);
1737
1738     my $cmd = join "\n\t", map "$_", @cmds;
1739
1740     # No leading tab makes it look right when embedded
1741     my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
1742 startdir = F$Environment("Default")
1743         Set Default %s
1744         %s
1745         Set Default 'startdir'
1746 MAKE_FRAG
1747
1748     # No trailing newline makes this easier to embed
1749     chomp $make_frag;
1750
1751     return $make_frag;
1752 }
1753
1754
1755 =item oneliner
1756
1757 =cut
1758
1759 sub oneliner {
1760     my($self, $cmd, $switches) = @_;
1761     $switches = [] unless defined $switches;
1762
1763     # Strip leading and trailing newlines
1764     $cmd =~ s{^\n+}{};
1765     $cmd =~ s{\n+$}{};
1766
1767     $cmd = $self->quote_literal($cmd);
1768     $cmd = $self->escape_newlines($cmd);
1769
1770     # Switches must be quoted else they will be lowercased.
1771     $switches = join ' ', map { qq{"$_"} } @$switches;
1772
1773     return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
1774 }
1775
1776
1777 =item B<echo>
1778
1779 perl trips up on "<foo>" thinking it's an input redirect.  So we use the
1780 native Write command instead.  Besides, its faster.
1781
1782 =cut
1783
1784 sub echo {
1785     my($self, $text, $file, $opts) = @_;
1786
1787     # Compatibility with old options
1788     if( !ref $opts ) {
1789         my $append = $opts;
1790         $opts = { append => $append || 0 };
1791     }
1792     my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write';
1793
1794     $opts->{allow_variables} = 0 unless defined $opts->{allow_variables};
1795
1796     my $ql_opts = { allow_variables => $opts->{allow_variables} };
1797
1798     my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
1799     push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) }
1800                 split /\n/, $text;
1801     push @cmds, '$(NOECHO) Close MMECHOFILE';
1802     return @cmds;
1803 }
1804
1805
1806 =item quote_literal
1807
1808 =cut
1809
1810 sub quote_literal {
1811     my($self, $text, $opts) = @_;
1812     $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
1813
1814     # I believe this is all we should need.
1815     $text =~ s{"}{""}g;
1816
1817     $text = $opts->{allow_variables}
1818       ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
1819
1820     return qq{"$text"};
1821 }
1822
1823 =item escape_dollarsigns
1824
1825 Quote, don't escape.
1826
1827 =cut
1828
1829 sub escape_dollarsigns {
1830     my($self, $text) = @_;
1831
1832     # Quote dollar signs which are not starting a variable
1833     $text =~ s{\$ (?!\() }{"\$"}gx;
1834
1835     return $text;
1836 }
1837
1838
1839 =item escape_all_dollarsigns
1840
1841 Quote, don't escape.
1842
1843 =cut
1844
1845 sub escape_all_dollarsigns {
1846     my($self, $text) = @_;
1847
1848     # Quote dollar signs
1849     $text =~ s{\$}{"\$\"}gx;
1850
1851     return $text;
1852 }
1853
1854 =item escape_newlines
1855
1856 =cut
1857
1858 sub escape_newlines {
1859     my($self, $text) = @_;
1860
1861     $text =~ s{\n}{-\n}g;
1862
1863     return $text;
1864 }
1865
1866 =item max_exec_len
1867
1868 256 characters.
1869
1870 =cut
1871
1872 sub max_exec_len {
1873     my $self = shift;
1874
1875     return $self->{_MAX_EXEC_LEN} ||= 256;
1876 }
1877
1878 =item init_linker
1879
1880 =cut
1881
1882 sub init_linker {
1883     my $self = shift;
1884     $self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
1885
1886     my $shr = $Config{dbgprefix} . 'PERLSHR';
1887     if ($self->{PERL_SRC}) {
1888         $self->{PERL_ARCHIVE} ||=
1889           $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
1890     }
1891     else {
1892         $self->{PERL_ARCHIVE} ||=
1893           $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
1894     }
1895
1896     $self->{PERL_ARCHIVE_AFTER} ||= '';
1897 }
1898
1899
1900 =item catdir (override)
1901
1902 =item catfile (override)
1903
1904 Eliminate the macros in the output to the MMS/MMK file.
1905
1906 (File::Spec::VMS used to do this for us, but it's being removed)
1907
1908 =cut
1909
1910 sub catdir {
1911     my $self = shift;
1912
1913     # Process the macros on VMS MMS/MMK
1914     my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_  } @_;
1915
1916     my $dir = $self->SUPER::catdir(@args);
1917
1918     # Fix up the directory and force it to VMS format.
1919     $dir = $self->fixpath($dir, 1);
1920
1921     return $dir;
1922 }
1923
1924 sub catfile {
1925     my $self = shift;
1926
1927     # Process the macros on VMS MMS/MMK
1928     my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_  } @_;
1929
1930     my $file = $self->SUPER::catfile(@args);
1931
1932     $file = vmsify($file);
1933
1934     return $file
1935 }
1936
1937
1938 =item eliminate_macros
1939
1940 Expands MM[KS]/Make macros in a text string, using the contents of
1941 identically named elements of C<%$self>, and returns the result
1942 as a file specification in Unix syntax.
1943
1944 NOTE:  This is the canonical version of the method.  The version in
1945 File::Spec::VMS is deprecated.
1946
1947 =cut
1948
1949 sub eliminate_macros {
1950     my($self,$path) = @_;
1951     return '' unless $path;
1952     $self = {} unless ref $self;
1953
1954     if ($path =~ /\s/) {
1955       return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
1956     }
1957
1958     my($npath) = unixify($path);
1959     # sometimes unixify will return a string with an off-by-one trailing null
1960     $npath =~ s{\0$}{};
1961
1962     my($complex) = 0;
1963     my($head,$macro,$tail);
1964
1965     # perform m##g in scalar context so it acts as an iterator
1966     while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
1967         if (defined $self->{$2}) {
1968             ($head,$macro,$tail) = ($1,$2,$3);
1969             if (ref $self->{$macro}) {
1970                 if (ref $self->{$macro} eq 'ARRAY') {
1971                     $macro = join ' ', @{$self->{$macro}};
1972                 }
1973                 else {
1974                     print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
1975                           "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
1976                     $macro = "\cB$macro\cB";
1977                     $complex = 1;
1978                 }
1979             }
1980             else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
1981             $npath = "$head$macro$tail";
1982         }
1983     }
1984     if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
1985     $npath;
1986 }
1987
1988 =item fixpath
1989
1990    my $path = $mm->fixpath($path);
1991    my $path = $mm->fixpath($path, $is_dir);
1992
1993 Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
1994 in any directory specification, in order to avoid juxtaposing two
1995 VMS-syntax directories when MM[SK] is run.  Also expands expressions which
1996 are all macro, so that we can tell how long the expansion is, and avoid
1997 overrunning DCL's command buffer when MM[KS] is running.
1998
1999 fixpath() checks to see whether the result matches the name of a
2000 directory in the current default directory and returns a directory or
2001 file specification accordingly.  C<$is_dir> can be set to true to
2002 force fixpath() to consider the path to be a directory or false to force
2003 it to be a file.
2004
2005 NOTE:  This is the canonical version of the method.  The version in
2006 File::Spec::VMS is deprecated.
2007
2008 =cut
2009
2010 sub fixpath {
2011     my($self,$path,$force_path) = @_;
2012     return '' unless $path;
2013     $self = bless {}, $self unless ref $self;
2014     my($fixedpath,$prefix,$name);
2015
2016     if ($path =~ /[ \t]/) {
2017       return join ' ',
2018              map { $self->fixpath($_,$force_path) }
2019              split /[ \t]+/, $path;
2020     }
2021
2022     if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
2023         if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
2024             $fixedpath = vmspath($self->eliminate_macros($path));
2025         }
2026         else {
2027             $fixedpath = vmsify($self->eliminate_macros($path));
2028         }
2029     }
2030     elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
2031         my($vmspre) = $self->eliminate_macros("\$($prefix)");
2032         # is it a dir or just a name?
2033         $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
2034         $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
2035         $fixedpath = vmspath($fixedpath) if $force_path;
2036     }
2037     else {
2038         $fixedpath = $path;
2039         $fixedpath = vmspath($fixedpath) if $force_path;
2040     }
2041     # No hints, so we try to guess
2042     if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
2043         $fixedpath = vmspath($fixedpath) if -d $fixedpath;
2044     }
2045
2046     # Trim off root dirname if it's had other dirs inserted in front of it.
2047     $fixedpath =~ s/\.000000([\]>])/$1/;
2048     # Special case for VMS absolute directory specs: these will have had device
2049     # prepended during trip through Unix syntax in eliminate_macros(), since
2050     # Unix syntax has no way to express "absolute from the top of this device's
2051     # directory tree".
2052     if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
2053
2054     return $fixedpath;
2055 }
2056
2057
2058 =item os_flavor
2059
2060 VMS is VMS.
2061
2062 =cut
2063
2064 sub os_flavor {
2065     return('VMS');
2066 }
2067
2068 =back
2069
2070
2071 =head1 AUTHOR
2072
2073 Original author Charles Bailey F<bailey@newman.upenn.edu>
2074
2075 Maintained by Michael G Schwern F<schwern@pobox.com>
2076
2077 See L<ExtUtils::MakeMaker> for patching and contact information.
2078
2079
2080 =cut
2081
2082 1;
2083