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