mm_unix.pm

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

Deprecated method. Use libscan instead.

=cut

sub exescan {
    my($self,$path) = @_;
    $path;
}

=item extliblist

Called by init_others, and calls ext ExtUtils::Liblist. See
L<ExtUtils::Liblist> for details.

=cut

sub extliblist {
    my($self,$libs) = @_;
    require ExtUtils::Liblist;
    $self->ext($libs, $Verbose);
}

=item find_perl

Finds the executables PERL and FULLPERL

=cut

sub find_perl {
    my($self, $ver, $names, $dirs, $trace) = @_;
    my($name, $dir);
    if ($trace >= 2){
        print "Looking for perl $ver by these names:
@$names
in these dirs:
@$dirs
";
    }

    my $stderr_duped = 0;
    local *STDERR_COPY;
    unless ($Is_BSD) {
        if( open(STDERR_COPY, '>&STDERR') ) {
            $stderr_duped = 1;
        }
        else {
            warn <<WARNING;
find_perl() can't dup STDERR: $!
You might see some garbage while we search for Perl
WARNING
        }
    }

    foreach $name (@$names){
        foreach $dir (@$dirs){
            next unless defined $dir; # $self->{PERL_SRC} may be undefined
            my ($abs, $val);
            if ($self->file_name_is_absolute($name)) {     # /foo/bar
                $abs = $name;
            } elsif ($self->canonpath($name) eq 
                     $self->canonpath(basename($name))) {  # foo
                $abs = $self->catfile($dir, $name);
            } else {                                            # foo/bar
                $abs = $self->catfile($Curdir, $name);
            }
            print "Checking $abs\n" if ($trace >= 2);
            next unless $self->maybe_command($abs);
            print "Executing $abs\n" if ($trace >= 2);

            my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"};
            $version_check = "$Config{run} $version_check"
                if defined $Config{run} and length $Config{run};

            # To avoid using the unportable 2>&1 to suppress STDERR,
            # we close it before running the command.
            # However, thanks to a thread library bug in many BSDs
            # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 )
            # we cannot use the fancier more portable way in here
            # but instead need to use the traditional 2>&1 construct.
            if ($Is_BSD) {
                $val = `$version_check 2>&1`;
            } else {
                close STDERR if $stderr_duped;
                $val = `$version_check`;
                open STDERR, '>&STDERR_COPY' if $stderr_duped;
            }

            if ($val =~ /^VER_OK/m) {
                print "Using PERL=$abs\n" if $trace;
                return $abs;
            } elsif ($trace >= 2) {
                print "Result: '$val' ".($? >> 8)."\n";
            }
        }
    }
    print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
    0; # false and not empty
}


=item fixin

  $mm->fixin(@files);

Inserts the sharpbang or equivalent magic number to a set of @files.

=cut

sub fixin {    # stolen from the pink Camel book, more or less
    my ( $self, @files ) = @_;

    my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
    for my $file (@files) {
        my $file_new = "$file.new";
        my $file_bak = "$file.bak";

        local (*FIXIN);
        local (*FIXOUT);
        open( FIXIN, $file ) or croak "Can't process '$file': $!";
        local $/ = "\n";
        chomp( my $line = <FIXIN> );
        next unless $line =~ s/^\s*\#!\s*//;    # Not a shbang file.
        # Now figure out the interpreter name.
        my ( $cmd, $arg ) = split ' ', $line, 2;
        $cmd =~ s!^.*/!!;

        # Now look (in reverse) for interpreter in absolute PATH (unless perl).
        my $interpreter;
        if ( $cmd eq "perl" ) {
            if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
                $interpreter = $Config{startperl};
                $interpreter =~ s,^\#!,,;
            }
            else {
                $interpreter = $Config{perlpath};
            }
        }
        else {
            my (@absdirs)
                = reverse grep { $self->file_name_is_absolute } $self->path;
            $interpreter = '';
            my ($dir);
            foreach $dir (@absdirs) {
                if ( $self->maybe_command($cmd) ) {
                    warn "Ignoring $interpreter in $file\n"
                        if $Verbose && $interpreter;
                    $interpreter = $self->catfile( $dir, $cmd );
                }
            }
        }

        # Figure out how to invoke interpreter on this machine.

        my ($shb) = "";
        if ($interpreter) {
            print STDOUT "Changing sharpbang in $file to $interpreter"
                if $Verbose;

            # this is probably value-free on DOSISH platforms
            if ($does_shbang) {
                $shb .= "$Config{'sharpbang'}$interpreter";
                $shb .= ' ' . $arg if defined $arg;
                $shb .= "\n";
            }
            $shb .= qq{
eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
    if 0; # not running under some shell
} unless $Is_Win32;    # this won't work on win32, so don't
        }
        else {
            warn "Can't find $cmd in PATH, $file unchanged"
                if $Verbose;
            next;
        }

        unless ( open( FIXOUT, ">$file_new" ) ) {
            warn "Can't create new $file: $!\n";
            next;
        }

        # Print out the new #! line (or equivalent).
        local $\;
        local $/;
        print FIXOUT $shb, <FIXIN>;
        close FIXIN;
        close FIXOUT;

        chmod 0666, $file_bak;
        unlink $file_bak;
        unless ( _rename( $file, $file_bak ) ) {
            warn "Can't rename $file to $file_bak: $!";
            next;
        }
        unless ( _rename( $file_new, $file ) ) {
            warn "Can't rename $file_new to $file: $!";
            unless ( _rename( $file_bak, $file ) ) {
                warn "Can't rename $file_bak back to $file either: $!";
                warn "Leaving $file renamed as $file_bak\n";
            }
            next;
        }
        unlink $file_bak;
    }
    continue {
        close(FIXIN) if fileno(FIXIN);
        system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
    }
}


sub _rename {
    my($old, $new) = @_;

    foreach my $file ($old, $new) {
        if( $Is_VMS and basename($file) !~ /\./ ) {
            # rename() in 5.8.0 on VMS will not rename a file if it
            # does not contain a dot yet it returns success.
            $file = "$file.";
        }
    }

    return rename($old, $new);
}


=item force (o)

Writes an empty FORCE: target.

=cut

sub force {
    my($self) = shift;
    '# Phony target to force checking subdirectories.
FORCE :
	$(NOECHO) $(NOOP)
';
}

=item guess_name

Guess the name of this package by examining the working directory's
name. MakeMaker calls this only if the developer has not supplied a
NAME attribute.

=cut

# ';

sub guess_name {
    my($self) = @_;
    use Cwd 'cwd';
    my $name = basename(cwd());
    $name =~ s|[\-_][\d\.\-]+\z||;  # this is new with MM 5.00, we
                                    # strip minus or underline
                                    # followed by a float or some such
    print "Warning: Guessing NAME [$name] from current directory name.\n";
    $name;
}

=item has_link_code

Returns true if C, XS, MYEXTLIB or similar objects exist within this
object that need a compiler. Does not descend into subdirectories as
needs_linking() does.

=cut

sub has_link_code {
    my($self) = shift;
    return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
    if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
	$self->{HAS_LINK_CODE} = 1;
	return 1;
    }
    return $self->{HAS_LINK_CODE} = 0;
}


=item init_dirscan

Scans the directory structure and initializes DIR, XS, XS_FILES,
C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES.

Called by init_main.

=cut

sub init_dirscan {	# --- File and Directory Lists (.xs .pm .pod etc)
    my($self) = @_;
    my($name, %dir, %xs, %c, %h, %pl_files, %pm);

    my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t);

    # ignore the distdir
    $Is_VMS ? $ignore{"$self->{DISTVNAME}.dir"} = 1
            : $ignore{$self->{DISTVNAME}} = 1;

    @ignore{map lc, keys %ignore} = values %ignore if $Is_VMS;

    foreach $name ($self->lsdir($Curdir)){
	next if $name =~ /\#/;
	next if $name eq $Curdir or $name eq $Updir or $ignore{$name};
	next unless $self->libscan($name);
	if (-d $name){
	    next if -l $name; # We do not support symlinks at all
            next if $self->{NORECURS};
	    $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
	} elsif ($name =~ /\.xs\z/){
	    my($c); ($c = $name) =~ s/\.xs\z/.c/;
	    $xs{$name} = $c;
	    $c{$c} = 1;
	} elsif ($name =~ /\.c(pp|xx|c)?\z/i){  # .c .C .cpp .cxx .cc
	    $c{$name} = 1
		unless $name =~ m/perlmain\.c/; # See MAP_TARGET
	} elsif ($name =~ /\.h\z/i){
	    $h{$name} = 1;
	} elsif ($name =~ /\.PL\z/) {
	    ($pl_files{$name} = $name) =~ s/\.PL\z// ;
	} elsif (($Is_VMS || $Is_Dos) && $name =~ /[._]pl$/i) {
	    # case-insensitive filesystem, one dot per name, so foo.h.PL
	    # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
	    local($/); open(PL,$name); my $txt = <PL>; close PL;
	    if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
		($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
	    }
	    else { 
                $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); 
            }
	} elsif ($name =~ /\.(p[ml]|pod)\z/){
	    $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
	}
    }

    $self->{PL_FILES}   ||= \%pl_files;
    $self->{DIR}        ||= [sort keys %dir];
    $self->{XS}         ||= \%xs;
    $self->{C}          ||= [sort keys %c];
    $self->{H}          ||= [sort keys %h];
    $self->{PM}         ||= \%pm;

    my @o_files = @{$self->{C}};
    $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files];
}


=item init_MANPODS

Determines if man pages should be generated and initializes MAN1PODS
and MAN3PODS as appropriate.

=cut

sub init_MANPODS {
    my $self = shift;

    # Set up names of manual pages to generate from pods
    foreach my $man (qw(MAN1 MAN3)) {
	if ( $self->{"${man}PODS"}
             or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/
        ) {
            $self->{"${man}PODS"} ||= {};
        }
        else {
            my $init_method = "init_${man}PODS";
            $self->$init_method();
	}
    }
}


sub _has_pod {
    my($self, $file) = @_;

    local *FH;
    my($ispod)=0;
    if (open(FH,"<$file")) {
	while (<FH>) {
	    if (/^=(?:head\d+|item|pod)\b/) {
		$ispod=1;
		last;
	    }
	}
	close FH;
    } else {
	# If it doesn't exist yet, we assume, it has pods in it
	$ispod = 1;
    }

    return $ispod;
}


=item init_MAN1PODS

Initializes MAN1PODS from the list of EXE_FILES.

=cut

sub init_MAN1PODS {
    my($self) = @_;

    if ( exists $self->{EXE_FILES} ) {
	foreach my $name (@{$self->{EXE_FILES}}) {
	    next unless $self->_has_pod($name);

	    $self->{MAN1PODS}->{$name} =
		$self->catfile("\$(INST_MAN1DIR)", 
			       basename($name).".\$(MAN1EXT)");
	}
    }
}


=item init_MAN3PODS

Initializes MAN3PODS from the list of PM files.

=cut

sub init_MAN3PODS {
    my $self = shift;

    my %manifypods = (); # we collect the keys first, i.e. the files
                         # we have to convert to pod

    foreach my $name (keys %{$self->{PM}}) {
	if ($name =~ /\.pod\z/ ) {
	    $manifypods{$name} = $self->{PM}{$name};
	} elsif ($name =~ /\.p[ml]\z/ ) {
	    if( $self->_has_pod($name) ) {
		$manifypods{$name} = $self->{PM}{$name};
	    }
	}
    }

    my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};

    # Remove "Configure.pm" and similar, if it's not the only pod listed
    # To force inclusion, just name it "Configure.pod", or override 
    # MAN3PODS
    foreach my $name (keys %manifypods) {
	if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) {
	    delete $manifypods{$name};
	    next;
	}
	my($manpagename) = $name;
	$manpagename =~ s/\.p(od|m|l)\z//;
	# everything below lib is ok
	unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
	    $manpagename = $self->catfile(
	        split(/::/,$self->{PARENT_NAME}),$manpagename
	    );
	}
	$manpagename = $self->replace_manpage_separator($manpagename);
	$self->{MAN3PODS}->{$name} =
	    $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
    }
}


=item init_PM

Initializes PMLIBDIRS and PM from PMLIBDIRS.

=cut

sub init_PM {
    my $self = shift;

    # Some larger extensions often wish to install a number of *.pm/pl
    # files into the library in various locations.

    # The attribute PMLIBDIRS holds an array reference which lists
    # subdirectories which we should search for library files to
    # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ].  We
    # recursively search through the named directories (skipping any
    # which don't exist or contain Makefile.PL files).

    # For each *.pm or *.pl file found $self->libscan() is called with
    # the default installation path in $_[1]. The return value of
    # libscan defines the actual installation location.  The default
    # libscan function simply returns the path.  The file is skipped