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