mm_vms.pm

UNIX下perl实现代码

#   MM_VMS.pm
#   MakeMaker default methods for VMS
#   This package is inserted into @ISA of MakeMaker's MM before the
#   built-in ExtUtils::MM_Unix methods if MakeMaker.pm is run under VMS.
#
#   Author:  Charles Bailey  [e-mail]

package ExtUtils::MM_VMS;

use Carp qw( &carp );
use Config;
require Exporter;
use VMS::Filespec;
use File::Basename;
use File::Spec;
our($Revision, @ISA);
$Revision = '5.56 (27-Apr-1999)';

@ISA = qw( File::Spec );
unshift @MM::ISA, 'ExtUtils::MM_VMS';

Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue');

=head1 NAME

ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker

=head1 SYNOPSIS

 use ExtUtils::MM_VMS; # Done internally by ExtUtils::MakeMaker if needed

=head1 DESCRIPTION

See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

=head2 Methods always loaded

=over

=item wraplist

Converts a list into a string wrapped at approximately 80 columns.

=cut

sub wraplist {
    my($self) = shift;
    my($line,$hlen) = ('',0);
    my($word);

    foreach $word (@_) {
      # Perl bug -- seems to occasionally insert extra elements when
      # traversing array (scalar(@array) doesn't show them, but
      # foreach(@array) does) (5.00307)
      next unless $word =~ /\w/;
      $line .= ' ' if length($line);
      if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
      $line .= $word;
      $hlen += length($word) + 2;
    }
    $line;
}

=item rootdir (override)

Returns a string representing of the root directory.

=cut

sub rootdir {
    return '';
}

package ExtUtils::MM_VMS;

sub ExtUtils::MM_VMS::ext;
sub ExtUtils::MM_VMS::guess_name;
sub ExtUtils::MM_VMS::find_perl;
sub ExtUtils::MM_VMS::path;
sub ExtUtils::MM_VMS::maybe_command;
sub ExtUtils::MM_VMS::maybe_command_in_dirs;
sub ExtUtils::MM_VMS::perl_script;
sub ExtUtils::MM_VMS::file_name_is_absolute;
sub ExtUtils::MM_VMS::replace_manpage_separator;
sub ExtUtils::MM_VMS::init_others;
sub ExtUtils::MM_VMS::constants;
sub ExtUtils::MM_VMS::cflags;
sub ExtUtils::MM_VMS::const_cccmd;
sub ExtUtils::MM_VMS::pm_to_blib;
sub ExtUtils::MM_VMS::tool_autosplit;
sub ExtUtils::MM_VMS::tool_xsubpp;
sub ExtUtils::MM_VMS::xsubpp_version;
sub ExtUtils::MM_VMS::tools_other;
sub ExtUtils::MM_VMS::dist;
sub ExtUtils::MM_VMS::c_o;
sub ExtUtils::MM_VMS::xs_c;
sub ExtUtils::MM_VMS::xs_o;
sub ExtUtils::MM_VMS::top_targets;
sub ExtUtils::MM_VMS::dlsyms;
sub ExtUtils::MM_VMS::dynamic_lib;
sub ExtUtils::MM_VMS::dynamic_bs;
sub ExtUtils::MM_VMS::static_lib;
sub ExtUtils::MM_VMS::manifypods;
sub ExtUtils::MM_VMS::processPL;
sub ExtUtils::MM_VMS::installbin;
sub ExtUtils::MM_VMS::subdir_x;
sub ExtUtils::MM_VMS::clean;
sub ExtUtils::MM_VMS::realclean;
sub ExtUtils::MM_VMS::dist_basics;
sub ExtUtils::MM_VMS::dist_core;
sub ExtUtils::MM_VMS::dist_dir;
sub ExtUtils::MM_VMS::dist_test;
sub ExtUtils::MM_VMS::install;
sub ExtUtils::MM_VMS::perldepend;
sub ExtUtils::MM_VMS::makefile;
sub ExtUtils::MM_VMS::test;
sub ExtUtils::MM_VMS::test_via_harness;
sub ExtUtils::MM_VMS::test_via_script;
sub ExtUtils::MM_VMS::makeaperl;
sub ExtUtils::MM_VMS::ext;
sub ExtUtils::MM_VMS::nicetext;

#use SelfLoader;
sub AUTOLOAD {
    my $code;
    if (defined fileno(DATA)) {
	my $fh = select DATA;
	my $o = $/;			# For future reads from the file.
	$/ = "\n__END__\n";
	$code = <DATA>;
	$/ = $o;
	select $fh;
	close DATA;
	eval $code;
	if ($@) {
	    $@ =~ s/ at .*\n//;
	    Carp::croak $@;
	}
    } else {
	warn "AUTOLOAD called unexpectedly for $AUTOLOAD"; 
    }
    defined(&$AUTOLOAD) or die "Myloader inconsistency error";
    goto &$AUTOLOAD;
}

1;

#__DATA__


# This isn't really an override.  It's just here because ExtUtils::MM_VMS
# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
# in MM_VMS, then AUTOLOAD is called, and bad things happen.  So, we just
# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
sub ext {
  require ExtUtils::Liblist;
  ExtUtils::Liblist::Kid::ext(@_);
}

=back

=head2 SelfLoaded methods

Those methods which override default MM_Unix methods are marked
"(override)", while methods unique to MM_VMS are marked "(specific)".
For overridden methods, documentation is limited to an explanation
of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
documentation for more details.

=over

=item guess_name (override)

Try to determine name of extension being built.  We begin with the name
of the current directory.  Since VMS filenames are case-insensitive,
however, we look for a F<.pm> file whose name matches that of the current
directory (presumably the 'main' F<.pm> file for this extension), and try
to find a C<package> statement from which to obtain the Mixed::Case
package name.

=cut

sub guess_name {
    my($self) = @_;
    my($defname,$defpm,@pm,%xs,$pm);
    local *PM;

    $defname = basename(fileify($ENV{'DEFAULT'}));
    $defname =~ s![\d\-_]*\.dir.*$!!;  # Clip off .dir;1 suffix, and package version
    $defpm = $defname;
    # Fallback in case for some reason a user has copied the files for an
    # extension into a working directory whose name doesn't reflect the
    # extension's name.  We'll use the name of a unique .pm file, or the
    # first .pm file with a matching .xs file.
    if (not -e "${defpm}.pm") {
      @pm = map { s/.pm$//; $_ } glob('*.pm');
      if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
      elsif (@pm) {
        %xs = map { s/.xs$//; ($_,1) } glob('*.xs');
        if (%xs) { foreach $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } }
      }
    }
    if (open(PM,"${defpm}.pm")){
        while (<PM>) {
            if (/^\s*package\s+([^;]+)/i) {
                $defname = $1;
                last;
            }
        }
        print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
                     "defaulting package name to $defname\n"
            if eof(PM);
        close PM;
    }
    else {
        print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
                     "defaulting package name to $defname\n";
    }
    $defname =~ s#[\d.\-_]+$##;
    $defname;
}

=item find_perl (override)

Use VMS file specification syntax and CLI commands to find and
invoke Perl images.

=cut

sub find_perl {
    my($self, $ver, $names, $dirs, $trace) = @_;
    my($name,$dir,$vmsfile,@sdirs,@snames,@cand);
    my($rslt);
    my($inabs) = 0;
    local *TCF;
    # Check in relative directories first, so we pick up the current
    # version of Perl if we're running MakeMaker as part of the main build.
    @sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
                    my($absb) = $self->file_name_is_absolute($b);
                    if ($absa && $absb) { return $a cmp $b }
                    else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
                  } @$dirs;
    # Check miniperl before perl, and check names likely to contain
    # version numbers before "generic" names, so we pick up an
    # executable that's less likely to be from an old installation.
    @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!;  # basename
                     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\-\$]+$/) {
            open(TCF,">temp_mmvms.com") || die('unable to open temp file');
            print TCF "\$ set message/nofacil/nosever/noident/notext\n";
            print TCF "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
            close TCF;
            $rslt = `\@temp_mmvms.com` ;
            unlink('temp_mmvms.com');
            if ($rslt =~ /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);
        open(TCF,">temp_mmvms.com") || die('unable to open temp file');
        print TCF "\$ set message/nofacil/nosever/noident/notext\n";
        print TCF "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
        close TCF;
        $rslt = `\@temp_mmvms.com`;
        unlink('temp_mmvms.com');
        if ($rslt =~ /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.