mm_vms.pm

ARM上的如果你对底层感兴趣

                     my($bb) = $b =~ m!([^:>\]/]+)$!;
                     my($ahasdir) = (length($a) - length($ba) > 0);
                     my($bhasdir) = (length($b) - length($bb) > 0);
                     if    ($ahasdir and not $bhasdir) { return 1; }
                     elsif ($bhasdir and not $ahasdir) { return -1; }
                     else { $bb =~ /\d/ <=> $ba =~ /\d/
                            or substr($ba,0,1) cmp substr($bb,0,1)
                            or length($bb) <=> length($ba) } } @$names;
    # Image names containing Perl version use '_' instead of '.' under VMS
    foreach $name (@snames) { $name =~ s/\.(\d+)$/_$1/; }
    if ($trace >= 2){
	print "Looking for perl $ver by these names:\n";
	print "\t@snames,\n";
	print "in these dirs:\n";
	print "\t@sdirs\n";
    }
    foreach $dir (@sdirs){
	next unless defined $dir; # $self->{PERL_SRC} may be undefined
	$inabs++ if $self->file_name_is_absolute($dir);
	if ($inabs == 1) {
	    # We've covered relative dirs; everything else is an absolute
	    # dir (probably an installed location).  First, we'll try potential
	    # command names, to see whether we can avoid a long MCR expression.
	    foreach $name (@snames) { push(@cand,$name) if $name =~ /^[\w\-\$]+$/; }
	    $inabs++; # Should happen above in next $dir, but just in case . . .
	}
	foreach $name (@snames){
	    if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); }
	    else                     { push(@cand,$self->fixpath($name,0));    }
	}
    }
    foreach $name (@cand) {
	print "Checking $name\n" if ($trace >= 2);
	# If it looks like a potential command, try it without the MCR
	if ($name =~ /^[\w\-\$]+$/ &&
	    `$name -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) {
	    print "Using PERL=$name\n" if $trace;
	    return $name;
	}
	next unless $vmsfile = $self->maybe_command($name);
	$vmsfile =~ s/;[\d\-]*$//;  # Clip off version number; we can use a newer version as well
	print "Executing $vmsfile\n" if ($trace >= 2);
	if (`MCR $vmsfile -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) {
	    print "Using PERL=MCR $vmsfile\n" if $trace;
	    return "MCR $vmsfile";
	}
    }
    print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
    0; # false and not empty
}

=item path (override)

Translate logical name DCL$PATH as a searchlist, rather than trying
to C<split> string value of C<$ENV{'PATH'}>.

=cut

sub path {
    my(@dirs,$dir,$i);
    while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
    @dirs;
}

=item maybe_command (override)

Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
to check for DCL procedure.  If this fails, checks directories in DCL$PATH
and finally F<Sys$System:> for an executable file having the name specified,
with or without the F<.Exe>-equivalent suffix.

=cut

sub maybe_command {
    my($self,$file) = @_;
    return $file if -x $file && ! -d _;
    my(@dirs) = ('');
    my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
    my($dir,$ext);
    if ($file !~ m![/:>\]]!) {
	for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
	    $dir = $ENV{"DCL\$PATH;$i"};
	    $dir .= ':' unless $dir =~ m%[\]:]$%;
	    push(@dirs,$dir);
	}
	push(@dirs,'Sys$System:');
	foreach $dir (@dirs) {
	    my $sysfile = "$dir$file";
	    foreach $ext (@exts) {
		return $file if -x "$sysfile$ext" && ! -d _;
	    }
	}
    }
    return 0;
}

=item maybe_command_in_dirs (override)

Uses DCL argument quoting on test command line.

=cut

sub maybe_command_in_dirs {	# $ver is optional argument if looking for perl
    my($self, $names, $dirs, $trace, $ver) = @_;
    my($name, $dir);
    foreach $dir (@$dirs){
	next unless defined $dir; # $self->{PERL_SRC} may be undefined
	foreach $name (@$names){
	    my($abs,$tryabs);
	    if ($self->file_name_is_absolute($name)) {
		$abs = $name;
	    } else {
		$abs = $self->catfile($dir, $name);
	    }
	    print "Checking $abs for $name\n" if ($trace >= 2);
	    next unless $tryabs = $self->maybe_command($abs);
	    print "Substituting $tryabs instead of $abs\n" 
		if ($trace >= 2 and $tryabs ne $abs);
	    $abs = $tryabs;
	    if (defined $ver) {
		print "Executing $abs\n" if ($trace >= 2);
		if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) {
		    print "Using $abs\n" if $trace;
		    return $abs;
		}
	    } else { # Do not look for perl
		return $abs;
	    }
	}
    }
}

=item perl_script (override)

If name passed in doesn't specify a readable file, appends F<.com> or
F<.pl> and tries again, since it's customary to have file types on all files
under VMS.

=cut

sub perl_script {
    my($self,$file) = @_;
    return $file if -r $file && ! -d _;
    return "$file.com" if -r "$file.com";
    return "$file.pl" if -r "$file.pl";
    return '';
}

=item file_name_is_absolute (override)

Checks for VMS directory spec as well as Unix separators.

=cut

sub file_name_is_absolute {
    my($self,$file) = @_;
    # If it's a logical name, expand it.
    $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file};
    $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/;
}

=item replace_manpage_separator

Use as separator a character which is legal in a VMS-syntax file name.

=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);

    if ($self->{DEFINE} ne '') {
	my(@defs) = split(/\s+/,$self->{DEFINE});
	foreach $def (@defs) {
	    next unless $def;
	    if ($def =~ s/^-D//) {       # If it was a Unix-style definition
		$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 =
	    }
	}
	$self->{DEFINE} = join ',',@defs;
    }

    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)$(BASEEXT).$(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);