File Coverage

lib/ExtUtils/MM_VMS.pm
Criterion Covered Total %
statement 16 712 2.2
branch 1 398 0.3
condition 0 149 0.0
subroutine 6 60 10.0
total 23 1319 1.7


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