mm_vms.pm

UNIX下perl实现代码

Use VMS-style quoting on xsubpp command line.

=cut

sub tool_xsubpp {
    my($self) = @_;
    return '' unless $self->needs_linking;
    my($xsdir) = $self->catdir($self->{PERL_LIB},'ExtUtils');
    # drop back to old location if xsubpp is not in new location yet
    $xsdir = $self->catdir($self->{PERL_SRC},'ext') unless (-f $self->catfile($xsdir,'xsubpp'));
    my(@tmdeps) = '$(XSUBPPDIR)typemap';
    if( $self->{TYPEMAPS} ){
	my $typemap;
	foreach $typemap (@{$self->{TYPEMAPS}}){
		if( ! -f  $typemap ){
			warn "Typemap $typemap not found.\n";
		}
		else{
			push(@tmdeps, $self->fixpath($typemap,0));
		}
	}
    }
    push(@tmdeps, "typemap") if -f "typemap";
    my(@tmargs) = map("-typemap $_", @tmdeps);
    if( exists $self->{XSOPT} ){
	unshift( @tmargs, $self->{XSOPT} );
    }

    if ($Config{'ldflags'} && 
        $Config{'ldflags'} =~ m!/Debug!i &&
        (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)) {
        unshift(@tmargs,'-nolinenumbers');
    }
    my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,'xsubpp'));

    # What are the correct thresholds for version 1 && 2 Paul?
    if ( $xsubpp_version > 1.923 ){
	$self->{XSPROTOARG} = '' unless defined $self->{XSPROTOARG};
    } else {
	if (defined $self->{XSPROTOARG} && $self->{XSPROTOARG} =~ /\-prototypes/) {
	    print STDOUT qq{Warning: This extension wants to pass the switch "-prototypes" to xsubpp.
	Your version of xsubpp is $xsubpp_version and cannot handle this.
	Please upgrade to a more recent version of xsubpp.
};
	} else {
	    $self->{XSPROTOARG} = "";
	}
    }

    "
XSUBPPDIR = $xsdir
XSUBPP = \$(PERL) \"-I\$(PERL_ARCHLIB)\" \"-I\$(PERL_LIB)\" \$(XSUBPPDIR)xsubpp
XSPROTOARG = $self->{XSPROTOARG}
XSUBPPDEPS = @tmdeps
XSUBPPARGS = @tmargs
";
}

=item xsubpp_version (override)

Test xsubpp exit status according to VMS rules ($sts & 1 ==E<gt> good)
rather than Unix rules ($sts == 0 ==E<gt> good).

=cut

sub xsubpp_version
{
    my($self,$xsubpp) = @_;
    my ($version) ;
    return '' unless $self->needs_linking;

    # try to figure out the version number of the xsubpp on the system

    # first try the -v flag, introduced in 1.921 & 2.000a2

    my $command = "$self->{PERL} \"-I$self->{PERL_LIB}\" $xsubpp -v";
    print "Running: $command\n" if $Verbose;
    $version = `$command` ;
    if ($?) {
	use vmsish 'status';
	warn "Running '$command' exits with status $?";
    }
    chop $version ;

    return $1 if $version =~ /^xsubpp version (.*)/ ;

    # nope, then try something else

    my $counter = '000';
    my ($file) = 'temp' ;
    $counter++ while -e "$file$counter"; # don't overwrite anything
    $file .= $counter;

    local(*F);
    open(F, ">$file") or die "Cannot open file '$file': $!\n" ;
    print F <<EOM ;
MODULE = fred PACKAGE = fred

int
fred(a)
	int	a;
EOM

    close F ;

    $command = "$self->{PERL} $xsubpp $file";
    print "Running: $command\n" if $Verbose;
    my $text = `$command` ;
    if ($?) {
	use vmsish 'status';
	warn "Running '$command' exits with status $?";
    }
    unlink $file ;

    # gets 1.2 -> 1.92 and 2.000a1
    return $1 if $text =~ /automatically by xsubpp version ([\S]+)\s*/  ;

    # it is either 1.0 or 1.1
    return 1.1 if $text =~ /^Warning: ignored semicolon/ ;

    # none of the above, so 1.0
    return "1.0" ;
}

=item tools_other (override)

Adds a few MM[SK] macros, and shortens some the installatin commands,
in order to stay under DCL's 255-character limit.  Also changes
EQUALIZE_TIMESTAMP to set revision date of target file to one second
later than source file, since MMK interprets precisely equal revision
dates for a source and target file as a sign that the target needs
to be updated.

=cut

sub tools_other {
    my($self) = @_;
    qq!
# Assumes \$(MMS) invokes MMS or MMK
# (It is assumed in some cases later that the default makefile name
# (Descrip.MMS for MM[SK]) is used.)
USEMAKEFILE = /Descrip=
USEMACROS = /Macro=(
MACROEND = )
MAKEFILE = Descrip.MMS
SHELL = Posix
TOUCH = $self->{TOUCH}
CHMOD = $self->{CHMOD}
CP = $self->{CP}
MV = $self->{MV}
RM_F  = $self->{RM_F}
RM_RF = $self->{RM_RF}
SAY = Write Sys\$Output
UMASK_NULL = $self->{UMASK_NULL}
NOOP = $self->{NOOP}
NOECHO = $self->{NOECHO}
MKPATH = Create/Directory
EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\$ARGV[0]))[9]+1,\$ARGV[1])"
!. ($self->{PARENT} ? '' : 
qq!WARN_IF_OLD_PACKLIST = \$(PERL) -e "if (-f \$ARGV[0]){print qq[WARNING: Old package found (\$ARGV[0]); please check for collisions\\n]}"
MOD_INSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "install({split(' ',<STDIN>)},1);"
DOC_INSTALL = \$(PERL) -e "\@ARGV=split(/\\|/,<STDIN>);print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];while(\$key=shift && \$val=shift){print qq[=item *\\n\\nC<\$key: \$val>\\n\\n];}print qq[=back\\n\\n]"
UNINSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "uninstall(\$ARGV[0],1,1);"
!);
}

=item dist (override)

Provide VMSish defaults for some values, then hand off to
default MM_Unix method.

=cut

sub dist {
    my($self, %attribs) = @_;
    $attribs{VERSION}      ||= $self->{VERSION_SYM};
    $attribs{NAME}         ||= $self->{DISTNAME};
    $attribs{ZIPFLAGS}     ||= '-Vu';
    $attribs{COMPRESS}     ||= 'gzip';
    $attribs{SUFFIX}       ||= '-gz';
    $attribs{SHAR}         ||= 'vms_share';
    $attribs{DIST_DEFAULT} ||= 'zipdist';

    # Sanitize these for use in $(DISTVNAME) filespec
    $attribs{VERSION} =~ s/[^\w\$]/_/g;
    $attribs{NAME} =~ s/[^\w\$]/-/g;

    return ExtUtils::MM_Unix::dist($self,%attribs);
}

=item c_o (override)

Use VMS syntax on command line.  In particular, $(DEFINE) and
$(PERL_INC) have been pulled into $(CCCMD).  Also use MM[SK] macros.

=cut

sub c_o {
    my($self) = @_;
    return '' unless $self->needs_linking();
    '
.c$(OBJ_EXT) :
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c

.cpp$(OBJ_EXT) :
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp

.cxx$(OBJ_EXT) :
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx

';
}

=item xs_c (override)

Use MM[SK] macros.

=cut

sub xs_c {
    my($self) = @_;
    return '' unless $self->needs_linking();
    '
.xs.c :
	$(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
';
}

=item xs_o (override)

Use MM[SK] macros, and VMS command line for C compiler.

=cut

sub xs_o {	# many makes are too dumb to use xs_c then c_o
    my($self) = @_;
    return '' unless $self->needs_linking();
    '
.xs$(OBJ_EXT) :
	$(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
	$(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
';
}

=item top_targets (override)

Use VMS quoting on command line for Version_check.

=cut

sub top_targets {
    my($self) = shift;
    my(@m);
    push @m, '
all :: pure_all manifypods
	$(NOECHO) $(NOOP)

pure_all :: config pm_to_blib subdirs linkext
	$(NOECHO) $(NOOP)

subdirs :: $(MYEXTLIB)
	$(NOECHO) $(NOOP)

config :: $(MAKEFILE) $(INST_LIBDIR).exists
	$(NOECHO) $(NOOP)

config :: $(INST_ARCHAUTODIR).exists
	$(NOECHO) $(NOOP)

config :: $(INST_AUTODIR).exists
	$(NOECHO) $(NOOP)
';

    push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
    if (%{$self->{MAN1PODS}}) {
	push @m, q[
config :: $(INST_MAN1DIR).exists
	$(NOECHO) $(NOOP)
];
	push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
    }
    if (%{$self->{MAN3PODS}}) {
	push @m, q[
config :: $(INST_MAN3DIR).exists
	$(NOECHO) $(NOOP)
];
	push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
    }

    push @m, '
$(O_FILES) : $(H_FILES)
' if @{$self->{O_FILES} || []} && @{$self->{H} || []};

    push @m, q{
help :
	perldoc ExtUtils::MakeMaker
};

    push @m, q{
Version_check :
	$(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
	"-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')"
};

    join('',@m);
}

=item dlsyms (override)

Create VMS linker options files specifying universal symbols for this
extension's shareable image, and listing other shareable images or 
libraries to which it should be linked.

=cut

sub dlsyms {
    my($self,%attribs) = @_;

    return '' unless $self->needs_linking();

    my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
    my($vars)  = $attribs{DL_VARS}  || $self->{DL_VARS}  || [];
    my($funclist)  = $attribs{FUNCLIST}  || $self->{FUNCLIST}  || [];
    my(@m);

    unless ($self->{SKIPHASH}{'dynamic'}) {
	push(@m,'
dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
	$(NOECHO) $(NOOP)
');
    }

    push(@m,'
static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
	$(NOECHO) $(NOOP)
') unless $self->{SKIPHASH}{'static'};

    push @m,'
$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
	$(CP) $(MMS$SOURCE) $(MMS$TARGET)

$(BASEEXT).opt : Makefile.PL
	$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Mksymlists;" -
	',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
	neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),
	q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n];

    push @m, '	$(PERL) -e "print ""$(INST_STATIC)/Include=';
    if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
        $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) { 
        push @m, ($Config{d_vms_case_sensitive_symbols}
	           ? uc($self->{BASEEXT}) :'$(BASEEXT)');
    }
    else {  # We don't have a "main" object file, so pull 'em all in
       # Upcase module names if linker is being case-sensitive
       my($upcase) = $Config{d_vms_case_sensitive_symbols};
	my(@omods) = map { s/\.[^.]*$//;         # Trim off file type
	                   s[\$\(\w+_EXT\)][];   # even as a macro
	                   s/.*[:>\/\]]//;       # Trim off dir spec
			   $upcase ? uc($_) : $_;
	                 } split ' ', $self->eliminate_macros($self->{OBJECT});
        my($tmp,@lines,$elt) = '';
	$tmp = shift @omods;
	foreach $elt (@omods) {
	    $tmp .= ",$elt";
		if (length($tmp) > 80) { push @lines, $tmp;  $tmp = ''; }
	}
	push @lines, $tmp;
	push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
    }
	push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";

    if (length $self->{LDLOADLIBS}) {
	my($lib); my($line) = '';
	foreach $lib (split ' ', $self->{LDLOADLIBS}) {
	    $lib =~ s%\$%\\\$%g;  # Escape '$' in VMS filespecs
	    if (length($line) + length($lib) > 160) {
		push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
		$line = $lib . '\n';
	    }
	    else { $line .= $lib . '\n'; }
	}
	push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
    }

    join('',@m);

}

=item dynamic_lib (override)

Use VMS Link command.

=cut

sub dynamic_lib {
    my($self, %attribs) = @_;
    return '' unless $self->needs_linking(); #might be because of a subdir

    return '' unless $self->has_link_code();

    my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
    my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
    my $shr = $Config{'dbgprefix'} . 'PerlShr';
    my(@m);
    push @m,"

OTHERLDFLAGS = $otherldflags
INST_DYNAMIC_DEP = $inst_dynamic_dep

";
    push @m, '
$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
	$(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR)
	If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
	Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
';

    push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
    join('',@m);
}

=item dynamic_bs (override)

Use VMS-style quoting on Mkbootstrap command line.

=cut