mm_vms.pm

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

#   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 vars qw($Revision);
$Revision = '5.42 (31-Mar-1997)';

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 eliminate_macros

Expands MM[KS]/Make macros in a text string, using the contents of
identically named elements of C<%$self>, and returns the result
as a file specification in Unix syntax.

=cut

sub eliminate_macros {
    my($self,$path) = @_;
    unless ($path) {
	print "eliminate_macros('') = ||\n" if $Verbose >= 3;
	return '';
    }
    my($npath) = unixify($path);
    my($complex) = 0;
    my($head,$macro,$tail);

    # perform m##g in scalar context so it acts as an iterator
    while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) { 
        if ($self->{$2}) {
            ($head,$macro,$tail) = ($1,$2,$3);
            if (ref $self->{$macro}) {
                if (ref $self->{$macro} eq 'ARRAY') {
                    print "Note: expanded array macro \$($macro) in $path\n" if $Verbose;
                    $macro = join ' ', @{$self->{$macro}};
                }
                else {
                    print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
                          "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
                    $macro = "\cB$macro\cB";
                    $complex = 1;
                }
            }
            else { ($macro = unixify($self->{$macro})) =~ s#/$##; }
            $npath = "$head$macro$tail";
        }
    }
    if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
    print "eliminate_macros($path) = |$npath|\n" if $Verbose >= 3;
    $npath;
}

=item fixpath

Catchall routine to clean up problem MM[SK]/Make macros.  Expands macros
in any directory specification, in order to avoid juxtaposing two
VMS-syntax directories when MM[SK] is run.  Also expands expressions which
are all macro, so that we can tell how long the expansion is, and avoid
overrunning DCL's command buffer when MM[KS] is running.

If optional second argument has a TRUE value, then the return string is
a VMS-syntax directory specification, if it is FALSE, the return string
is a VMS-syntax file specification, and if it is not specified, fixpath()
checks to see whether it matches the name of a directory in the current
default directory, and returns a directory or file specification accordingly.

=cut

sub fixpath {
    my($self,$path,$force_path) = @_;
    unless ($path) {
	print "eliminate_macros('') = ||\n" if $Verbose >= 3;
	return '';
    }
    my($fixedpath,$prefix,$name);

    if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) { 
        if ($force_path or $path =~ /(?:DIR\)|\])$/) {
            $fixedpath = vmspath($self->eliminate_macros($path));
        }
        else {
            $fixedpath = vmsify($self->eliminate_macros($path));
        }
    }
    elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
        my($vmspre) = $self->eliminate_macros("\$($prefix)");
        # is it a dir or just a name?
        $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : '';
        $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
        $fixedpath = vmspath($fixedpath) if $force_path;
    }
    else {
        $fixedpath = $path;
        $fixedpath = vmspath($fixedpath) if $force_path;
    }
    # No hints, so we try to guess
    if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
        $fixedpath = vmspath($fixedpath) if -d $fixedpath;
    }
    # Trim off root dirname if it's had other dirs inserted in front of it.
    $fixedpath =~ s/\.000000([\]>])/$1/;
    print "fixpath($path) = |$fixedpath|\n" if $Verbose >= 3;
    $fixedpath;
}

=item catdir

Concatenates a list of file specifications, and returns the result as a
VMS-syntax directory specification.

=cut

sub catdir {
    my($self,@dirs) = @_;
    my($dir) = pop @dirs;
    @dirs = grep($_,@dirs);
    my($rslt);
    if (@dirs) {
      my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
      my($spath,$sdir) = ($path,$dir);
      $spath =~ s/.dir$//; $sdir =~ s/.dir$//; 
      $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
      $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
    }
    else { 
      if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
      else                          { $rslt = vmspath($dir); }
    }
    print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
    $rslt;
}

=item catfile

Concatenates a list of file specifications, and returns the result as a
VMS-syntax directory specification.

=cut

sub catfile {
    my($self,@files) = @_;
    my($file) = pop @files;
    @files = grep($_,@files);
    my($rslt);
    if (@files) {
      my($path) = (@files == 1 ? $files[0] : $self->catdir(@files));
      my($spath) = $path;
      $spath =~ s/.dir$//;
      if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; }
      else {
          $rslt = $self->eliminate_macros($spath);
          $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
      }
    }
    else { $rslt = vmsify($file); }
    print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
    $rslt;
}

=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 curdir (override)

Returns a string representing of the current directory.

=cut

sub curdir {
    return '[]';
}

=item rootdir (override)

Returns a string representing of the root directory.

=cut

sub rootdir {
    return '';
}

=item updir (override)

Returns a string representing of the parent directory.

=cut

sub updir {
    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, 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.
sub ext {
  ExtUtils::Liblist::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($inabs) = 0;
    # 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