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