mm_vms.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package ExtUtils::MM_VMS;

use strict;

use ExtUtils::MakeMaker::Config;
require Exporter;

BEGIN {
    # so we can compile the thing on non-VMS platforms.
    if( $^O eq 'VMS' ) {
        require VMS::Filespec;
        VMS::Filespec->import;
    }
}

use File::Basename;

# $Revision can't be on the same line or SVN/K gets confused
use vars qw($Revision
            $VERSION @ISA);
$VERSION = '6.42';

require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );

use ExtUtils::MakeMaker qw($Verbose neatvalue);
$Revision = $ExtUtils::MakeMaker::Revision;


=head1 NAME

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

=head1 SYNOPSIS

  Do not use this directly.
  Instead, use ExtUtils::MM and it will figure out which MM_*
  class to use for you.

=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 4

=item wraplist

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

=cut

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

    foreach my $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;
}


# 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.
# XXX This hackery will die soon. --Schwern
sub ext {
    require ExtUtils::Liblist::Kid;
    goto &ExtUtils::Liblist::Kid::ext;
}

=back

=head2 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 4

=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 (keys %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;

    if( $self->{PERL_CORE} ) {
        # 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;
    }
    else {
        @sdirs  = @$dirs;
        @snames = @$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 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 pasthru (override)

VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
options.  This is used in every invocation of make in the VMS Makefile so
PASTHRU should not be necessary.  Using PASTHRU tends to blow commands past
the 256 character limit.

=cut

sub pasthru {
    return "PASTHRU=\n";
}


=item pm_to_blib (override)

VMS wants a dot in every file so we can't have one called 'pm_to_blib',
it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.

So in VMS its pm_to_blib.ts.

=cut

sub pm_to_blib {
    my $self = shift;

    my $make = $self->SUPER::pm_to_blib;

    $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
    $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};

    $make = <<'MAKE' . $make;
# 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)

MAKE

    return $make;
}


=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 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_DEST

(override) Because of the difficulty concatenating VMS filepaths we
must pre-expand the DEST* variables.

=cut

sub init_DEST {
    my $self = shift;

    $self->SUPER::init_DEST;

    # Expand DEST variables.
    foreach my $var ($self->installvars) {
        my $destvar = 'DESTINSTALL'.$var;
        $self->{$destvar} = File::Spec->eliminate_macros($self->{$destvar});
    }
}


=item init_DIRFILESEP

No seperator between a directory path and a filename on VMS.

=cut

sub init_DIRFILESEP {
    my($self) = shift;

    $self->{DIRFILESEP} = '';
    return 1;
}


=item init_main (override)


=cut

sub init_main {
    my($self) = shift;

    $self->SUPER::init_main;

    $self->{DEFINE} ||= '';
    if ($self->{DEFINE} ne '') {
        my(@terms) = split(/\s+/,$self->{DEFINE});
        my(@defs,@udefs);
        foreach my $def (@terms) {
            next unless $def;
            my $targ = \@defs;
            if ($def =~ s/^-([DU])//) {    # If it was a Unix-style definition
                $targ = \@udefs if $1 eq 'U';
                $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) . ')'; 
        }
    }
}

=item init_others (override)

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

DEV_NULL should probably be overriden with something.

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 init_others {
    my($self) = @_;

    $self->{NOOP}               = 'Continue';
    $self->{NOECHO}             ||= '@ ';

    $self->{MAKEFILE}		||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
    $self->{FIRST_MAKEFILE}     ||= $self->{MAKEFILE};
    $self->{MAKE_APERL_FILE}    ||= 'Makeaperl.MMS';
    $self->{MAKEFILE_OLD}       ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
#
#   If an extension is not specified, then MMS/MMK assumes an
#   an extension of .MMS.  If there really is no extension,
#   then a trailing "." needs to be appended to specify a
#   a null extension.
#
    $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
    $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
    $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
    $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;

    $self->{MACROSTART}         ||= '/Macro=(';
    $self->{MACROEND}           ||= ')';
    $self->{USEMAKEFILE}        ||= '/Descrip=';

    $self->{ECHO}     ||= '$(ABSPERLRUN) -le "print qq{@ARGV}"';
    $self->{ECHO_N}   ||= '$(ABSPERLRUN) -e  "print qq{@ARGV}"';
    $self->{TOUCH}    ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e touch';
    $self->{CHMOD}    ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e chmod'; 
    $self->{RM_F}     ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e rm_f';
    $self->{RM_RF}    ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e rm_rf';
    $self->{TEST_F}   ||= '$(ABSPERLRUN) "-MExtUtils::Command" -e test_f';
    $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';

    $self->{MOD_INSTALL} ||= 
      $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install({split(' ',<STDIN>)}, '$(VERBINST)', 0, '$(UNINST)');
CODE

    $self->{SHELL}    ||= 'Posix';

    $self->SUPER::init_others;

    # So we can copy files into directories with less fuss
    $self->{CP}         = '$(ABSPERLRUN) "-MExtUtils::Command" -e cp';
    $self->{MV}         = '$(ABSPERLRUN) "-MExtUtils::Command" -e mv';

    $self->{UMASK_NULL} = '! ';