mm_vms.pm

UNIX下perl实现代码

=cut

sub replace_manpage_separator {
    my($self,$man) = @_;
    $man = unixify($man);
    $man =~ s#/+#__#g;
    $man;
}

=item init_others (override)

Provide VMS-specific forms of various utility commands, then hand
off to the default MM_Unix method.

=cut

sub init_others {
    my($self) = @_;

    $self->{NOOP} = 'Continue';
    $self->{FIRST_MAKEFILE} ||= 'Descrip.MMS';
    $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
    $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
    $self->{NOECHO} ||= '@ ';
    $self->{RM_F} = '$(PERL) -e "foreach (@ARGV) { 1 while ( -d $_ ? rmdir $_ : unlink $_)}"';
    $self->{RM_RF} = '$(PERL) "-I$(PERL_LIB)" -e "use File::Path; @dirs = map(VMS::Filespec::unixify($_),@ARGV); rmtree(\@dirs,0,0)"';
    $self->{TOUCH} = '$(PERL) -e "$t=time; foreach (@ARGV) { -e $_ ? utime($t,$t,@ARGV) : (open(F,qq(>$_)),close F)}"';
    $self->{CHMOD} = '$(PERL) -e "chmod @ARGV"';  # expect Unix syntax from MakeMaker
    $self->{CP} = 'Copy/NoConfirm';
    $self->{MV} = 'Rename/NoConfirm';
    $self->{UMASK_NULL} = '! ';  
    &ExtUtils::MM_Unix::init_others;
}

=item constants (override)

Fixes up numerous file and directory macros to insure VMS syntax
regardless of input syntax.  Also adds a few VMS-specific macros
and makes lists of files comma-separated.

=cut

sub constants {
    my($self) = @_;
    my(@m,$def,$macro);

    # Be kind about case for pollution
    for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }

    if ($self->{DEFINE} ne '') {
	my(@terms) = split(/\s+/,$self->{DEFINE});
	my(@defs,@udefs);
	foreach $def (@terms) {
	    next unless $def;
	    my $targ = \@defs;
	    if ($def =~ s/^-([DU])//) {       # If it was a Unix-style definition
		if ($1 eq 'U') { $targ = \@udefs; }
		$def =~ s/='(.*)'$/=$1/;  # then remove shell-protection ''
		$def =~ s/^'(.*)'$/$1/;   # from entire term or argument
	    }
	    if ($def =~ /=/) {
		$def =~ s/"/""/g;  # Protect existing " from DCL
		$def = qq["$def"]; # and quote to prevent parsing of =
	    }
	    push @$targ, $def;
	}
	$self->{DEFINE} = '';
	if (@defs)  { $self->{DEFINE}  = '/Define=(' . join(',',@defs)  . ')'; }
	if (@udefs) { $self->{DEFINE} .= '/Undef=('  . join(',',@udefs) . ')'; }
    }

    if ($self->{OBJECT} =~ /\s/) {
	$self->{OBJECT} =~ s/(\\)?\n+\s+/ /g;
	$self->{OBJECT} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{OBJECT})));
    }
    $self->{LDFROM} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{LDFROM})));


    # Fix up directory specs
    $self->{ROOTEXT} = $self->{ROOTEXT} ? $self->fixpath($self->{ROOTEXT},1)
                                        : '[]';
    foreach $macro ( qw [
            INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB INST_EXE INSTALLPRIVLIB
            INSTALLARCHLIB INSTALLSCRIPT INSTALLBIN PERL_LIB PERL_ARCHLIB
            PERL_INC PERL_SRC FULLEXT INST_MAN1DIR INSTALLMAN1DIR
            INST_MAN3DIR INSTALLMAN3DIR INSTALLSITELIB INSTALLSITEARCH
            SITELIBEXP SITEARCHEXP ] ) {
	next unless defined $self->{$macro};
	$self->{$macro} = $self->fixpath($self->{$macro},1);
    }
    $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC},q(VMS))
	if ($self->{PERL_SRC});
                        


    # Fix up file specs
    foreach $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKE_APERL_FILE MYEXTLIB] ) {
	next unless defined $self->{$macro};
	$self->{$macro} = $self->fixpath($self->{$macro},0);
    }

    foreach $macro (qw/
	      AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION VERSION_SYM XS_VERSION
	      INST_BIN INST_EXE INST_LIB INST_ARCHLIB INST_SCRIPT PREFIX
	      INSTALLDIRS INSTALLPRIVLIB  INSTALLARCHLIB INSTALLSITELIB
	      INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
	      PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
	      FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_VMS
	      PERL_INC PERL FULLPERL
	      / ) {
	next unless defined $self->{$macro};
	push @m, "$macro = $self->{$macro}\n";
    }


    push @m, q[
VERSION_MACRO = VERSION
DEFINE_VERSION = "$(VERSION_MACRO)=""$(VERSION)"""
XS_VERSION_MACRO = XS_VERSION
XS_DEFINE_VERSION = "$(XS_VERSION_MACRO)=""$(XS_VERSION)"""

MAKEMAKER = ],$self->catfile($self->{PERL_LIB},'ExtUtils','MakeMaker.pm'),qq[
MM_VERSION = $ExtUtils::MakeMaker::VERSION
MM_REVISION = $ExtUtils::MakeMaker::Revision
MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision

# FULLEXT = Pathname for extension directory (eg DBD/Oracle).
# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT.
# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
# DLBASE  = Basename part of dynamic library. May be just equal BASEEXT.
];

    for $tmp (qw/
	      FULLEXT VERSION_FROM OBJECT LDFROM
	      /	) {
	next unless defined $self->{$tmp};
	push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n";
    }

    for $tmp (qw/
	      BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE
	      /	) {
	next unless defined $self->{$tmp};
	push @m, "$tmp = $self->{$tmp}\n";
    }

    for $tmp (qw/ XS MAN1PODS MAN3PODS PM /) {
	next unless defined $self->{$tmp};
	my(%tmp,$key);
	for $key (keys %{$self->{$tmp}}) {
	    $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0);
	}
	$self->{$tmp} = \%tmp;
    }

    for $tmp (qw/ C O_FILES H /) {
	next unless defined $self->{$tmp};
	my(@tmp,$val);
	for $val (@{$self->{$tmp}}) {
	    push(@tmp,$self->fixpath($val,0));
	}
	$self->{$tmp} = \@tmp;
    }

    push @m,'

# Handy lists of source code files:
XS_FILES = ',$self->wraplist(sort keys %{$self->{XS}}),'
C_FILES  = ',$self->wraplist(@{$self->{C}}),'
O_FILES  = ',$self->wraplist(@{$self->{O_FILES}} ),'
H_FILES  = ',$self->wraplist(@{$self->{H}}),'
MAN1PODS = ',$self->wraplist(sort keys %{$self->{MAN1PODS}}),'
MAN3PODS = ',$self->wraplist(sort keys %{$self->{MAN3PODS}}),'

';

    for $tmp (qw/
	      INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
	      /) {
	next unless defined $self->{$tmp};
	push @m, "$tmp = $self->{$tmp}\n";
    }

push @m,"
.SUFFIXES :
.SUFFIXES : \$(OBJ_EXT) .c .cpp .cxx .xs

# Here is the Config.pm that we are using/depend on
CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h \$(VERSION_FROM)

# Where to put things:
INST_LIBDIR      = $self->{INST_LIBDIR}
INST_ARCHLIBDIR  = $self->{INST_ARCHLIBDIR}

INST_AUTODIR     = $self->{INST_AUTODIR}
INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
";

    if ($self->has_link_code()) {
	push @m,'
INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT)$(LIB_EXT)
INST_DYNAMIC = $(INST_ARCHAUTODIR)$(DLBASE).$(DLEXT)
INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs
';
    } else {
	my $shr = $Config{'dbgprefix'} . 'PERLSHR';
	push @m,'
INST_STATIC =
INST_DYNAMIC =
INST_BOOT =
EXPORT_LIST = $(BASEEXT).opt
PERL_ARCHIVE = ',($ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"),'
';
    }

    $self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ];
    $self->{PM_TO_BLIB} = [ %{$self->{PM}} ];
    push @m,'
TO_INST_PM = ',$self->wraplist(@{$self->{TO_INST_PM}}),'

PM_TO_BLIB = ',$self->wraplist(@{$self->{PM_TO_BLIB}}),'
';

    join('',@m);
}

=item cflags (override)

Bypass shell script and produce qualifiers for CC directly (but warn
user if a shell script for this extension exists).  Fold multiple
/Defines into one, since some C compilers pay attention to only one
instance of this qualifier on the command line.

=cut

sub cflags {
    my($self,$libperl) = @_;
    my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
    my($definestr,$undefstr,$flagoptstr) = ('','','');
    my($incstr) = '/Include=($(PERL_INC)';
    my($name,$sys,@m);

    ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
    print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
         " required to modify CC command for $self->{'BASEEXT'}\n"
    if ($Config{$name});

    if ($quals =~ / -[DIUOg]/) {
	while ($quals =~ / -([Og])(\d*)\b/) {
	    my($type,$lvl) = ($1,$2);
	    $quals =~ s/ -$type$lvl\b\s*//;
	    if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
	    else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
	}
	while ($quals =~ / -([DIU])(\S+)/) {
	    my($type,$def) = ($1,$2);
	    $quals =~ s/ -$type$def\s*//;
	    $def =~ s/"/""/g;
	    if    ($type eq 'D') { $definestr .= qq["$def",]; }
	    elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
	    else                 { $undefstr  .= qq["$def",]; }
	}
    }
    if (length $quals and $quals !~ m!/!) {
	warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
	$quals = '';
    }
    $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
    if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
    if (length $undefstr)  { chop($undefstr);  $quals .= "/Undef=($undefstr)";   }
    # Deal with $self->{DEFINE} here since some C compilers pay attention
    # to only one /Define clause on command line, so we have to
    # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
    # ($self->{DEFINE} has already been VMSified in constants() above)
    if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
    for $type (qw(Def Undef)) {
	my(@terms);
	while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
		my $term = $1;
		$term =~ s:^\((.+)\)$:$1:;
		push @terms, $term;
	    }
	if ($type eq 'Def') {
	    push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
	}
	if (@terms) {
	    $quals =~ s:/${type}i?n?e?=[^/]+::ig;
	    $quals .= "/${type}ine=(" . join(',',@terms) . ')';
	}
    }

    $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";

    # Likewise with $self->{INC} and /Include
    if ($self->{'INC'}) {
	my(@includes) = split(/\s+/,$self->{INC});
	foreach (@includes) {
	    s/^-I//;
	    $incstr .= ','.$self->fixpath($_,1);
	}
    }
    $quals .= "$incstr)";
#    $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
    $self->{CCFLAGS} = $quals;

    $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
    if ($self->{OPTIMIZE} !~ m!/!) {
	if    ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
	elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
	    $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
	}
	else {
	    warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
	    $self->{OPTIMIZE} = '/Optimize';
	}
    }

    return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
SPLIT =
LARGE =
};
}

=item const_cccmd (override)

Adds directives to point C preprocessor to the right place when
handling #include E<lt>sys/foo.hE<gt> directives.  Also constructs CC
command line a bit differently than MM_Unix method.

=cut

sub const_cccmd {
    my($self,$libperl) = @_;
    my(@m);

    return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
    return '' unless $self->needs_linking();
    if ($Config{'vms_cc_type'} eq 'gcc') {
        push @m,'
.FIRST
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
    }
    elsif ($Config{'vms_cc_type'} eq 'vaxc') {
        push @m,'
.FIRST
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
    }
    else {
        push @m,'
.FIRST
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
		($Config{'arch'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
	',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
    }

    push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");

    $self->{CONST_CCCMD} = join('',@m);
}

=item pm_to_blib (override)

DCL I<still> accepts a maximum of 255 characters on a command
line, so we write the (potentially) long list of file names
to a temp file, then persuade Perl to read it instead of the
command line to find args.

=cut

sub pm_to_blib {
    my($self) = @_;
    my($line,$from,$to,@m);
    my($autodir) = $self->catdir('$(INST_LIB)','auto');
    my(@files) = @{$self->{PM_TO_BLIB}};

    push @m, q{

# Dummy target to match Unix target name; we use pm_to_blib.ts as
# timestamp file to avoid repeated invocations under VMS
pm_to_blib : pm_to_blib.ts
	$(NOECHO) $(NOOP)

# As always, keep under DCL's 255-char limit
pm_to_blib.ts : $(TO_INST_PM)
	$(NOECHO) $(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp
};

    $line = '';  # avoid uninitialized var warning
    while ($from = shift(@files),$to = shift(@files)) {
	$line .= " $from $to";
	if (length($line) > 128) {
	    push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n");
	    $line = '';
	}
    }
    push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line;

    push(@m,q[	$(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[','$(PM_FILTER)')" <.MM_tmp]);
    push(@m,qq[
	\$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
	\$(NOECHO) \$(TOUCH) pm_to_blib.ts
]);

    join('',@m);
}

=item tool_autosplit (override)

Use VMS-style quoting on command line.

=cut

sub tool_autosplit{
    my($self, %attribs) = @_;
    my($asl) = "";
    $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
    q{
# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;"
};
}

=item tool_sxubpp (override)