install.pm

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

sub forceunlink {
    my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
    _unlink_or_rename( $file, $tryhard );
}

=begin _undocumented

=item directory_not_empty( $dir )

Returns 1 if there is an .exists file somewhere in a directory tree.
Returns 0 if there is not.

=end _undocumented

=cut

sub directory_not_empty ($) {
  my($dir) = @_;
  my $files = 0;
  find(sub {
           return if $_ eq ".exists";
           if (-f) {
             $File::Find::prune++;
             $files = 1;
           }
       }, $dir);
  return $files;
}


=item B<install_default> I<DISCOURAGED>

    install_default();
    install_default($fullext);

Calls install() with arguments to copy a module from blib/ to the
default site installation location.

$fullext is the name of the module converted to a directory
(ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
will attempt to read it from @ARGV.

This is primarily useful for install scripts.

B<NOTE> This function is not really useful because of the hard-coded
install location with no way to control site vs core vs vendor
directories and the strange way in which the module name is given.
Consider its use discouraged.

=cut

sub install_default {
  @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
  my $FULLEXT = @_ ? shift : $ARGV[0];
  defined $FULLEXT or die "Do not know to where to write install log";
  my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
  my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
  my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
  my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
  my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
  my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
  install({
           read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
           write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
           $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
                         $Config{installsitearch} :
                         $Config{installsitelib},
           $INST_ARCHLIB => $Config{installsitearch},
           $INST_BIN => $Config{installbin} ,
           $INST_SCRIPT => $Config{installscript},
           $INST_MAN1DIR => $Config{installman1dir},
           $INST_MAN3DIR => $Config{installman3dir},
          },1,0,0);
}


=item B<uninstall>

    uninstall($packlist_file);
    uninstall($packlist_file, $verbose, $dont_execute);

Removes the files listed in a $packlist_file.

If $verbose is true, will print out each file removed.  Default is
false.

If $dont_execute is true it will only print what it was going to do
without actually doing it.  Default is false.

=cut

sub uninstall {
    my($fil,$verbose,$nonono) = @_;
    $verbose ||= 0;
    $nonono  ||= 0;

    die _estr "ERROR: no packlist file found: '$fil'"
        unless -f $fil;
    # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
    # require $my_req; # Hairy, but for the first
    my ($packlist) = ExtUtils::Packlist->new($fil);
    foreach (sort(keys(%$packlist))) {
        chomp;
        print "unlink $_\n" if $verbose;
        forceunlink($_,'tryhard') unless $nonono;
    }
    print "unlink $fil\n" if $verbose;
    forceunlink($fil, 'tryhard') unless $nonono;
    _do_cleanup($verbose);
}

=begin _undocumented

=item inc_uninstall($filepath,$libdir,$verbose,$nonono,$ignore)

Remove shadowed files. If $ignore is true then it is assumed to hold
a filename to ignore. This is used to prevent spurious warnings from
occuring when doing an install at reboot.

=end _undocumented

=cut

sub inc_uninstall {
    my($filepath,$libdir,$verbose,$nonono,$ignore) = @_;
    my($dir);
    $ignore||="";
    my $file = (File::Spec->splitpath($filepath))[2];
    my %seen_dir = ();

    my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
      ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';

    foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
                                                  privlibexp
                                                  sitearchexp
                                                  sitelibexp)}) {
        my $canonpath = File::Spec->canonpath($dir);
        next if $canonpath eq $Curdir;
        next if $seen_dir{$canonpath}++;
        my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
        next unless -f $targetfile;

        # The reason why we compare file's contents is, that we cannot
        # know, which is the file we just installed (AFS). So we leave
        # an identical file in place
        my $diff = 0;
        if ( -f $targetfile && -s _ == -s $filepath) {
            # We have a good chance, we can skip this one
            $diff = compare($filepath,$targetfile);
        } else {
            $diff++;
        }
        print "#$file and $targetfile differ\n" if $diff && $verbose > 1;

        next if !$diff or $targetfile eq $ignore;
        if ($nonono) {
            if ($verbose) {
                $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
                $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
                $Inc_uninstall_warn_handler->add(
                                     File::Spec->catfile($libdir, $file),
                                     $targetfile
                                    );
            }
            # if not verbose, we just say nothing
        } else {
            print "Unlinking $targetfile (shadowing?)\n" if $verbose;
            forceunlink($targetfile,'tryhard');
        }
    }
}

=begin _undocumented

=item run_filter($cmd,$src,$dest)

Filter $src using $cmd into $dest.

=end _undocumented

=cut

sub run_filter {
    my ($cmd, $src, $dest) = @_;
    local(*CMD, *SRC);
    open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
    open(SRC, $src)           || die "Cannot open $src: $!";
    my $buf;
    my $sz = 1024;
    while (my $len = sysread(SRC, $buf, $sz)) {
        syswrite(CMD, $buf, $len);
    }
    close SRC;
    close CMD or die "Filter command '$cmd' failed for $src";
}


=item B<pm_to_blib>

    pm_to_blib(\%from_to, $autosplit_dir);
    pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);

Copies each key of %from_to to its corresponding value efficiently.
Filenames with the extension .pm are autosplit into the $autosplit_dir.
Any destination directories are created.

$filter_cmd is an optional shell command to run each .pm file through
prior to splitting and copying.  Input is the contents of the module,
output the new module contents.

You can have an environment variable PERL_INSTALL_ROOT set which will
be prepended as a directory to each installed file (and directory).

=cut

sub pm_to_blib {
    my($fromto,$autodir,$pm_filter) = @_;

    _mkpath($autodir,0,0755);
    while(my($from, $to) = each %$fromto) {
        if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
            print "Skip $to (unchanged)\n";
            next;
        }

        # When a pm_filter is defined, we need to pre-process the source first
        # to determine whether it has changed or not.  Therefore, only perform
        # the comparison check when there's no filter to be ran.
        #    -- RAM, 03/01/2001

        my $need_filtering = defined $pm_filter && length $pm_filter &&
                             $from =~ /\.pm$/;

        if (!$need_filtering && 0 == compare($from,$to)) {
            print "Skip $to (unchanged)\n";
            next;
        }
        if (-f $to){
            # we wont try hard here. its too likely to mess things up.
            forceunlink($to);
        } else {
            _mkpath(dirname($to),0,0755);
        }
        if ($need_filtering) {
            run_filter($pm_filter, $from, $to);
            print "$pm_filter <$from >$to\n";
        } else {
            _copy( $from, $to );
            print "cp $from $to\n";
        }
        my($mode,$atime,$mtime) = (stat $from)[2,8,9];
        utime($atime,$mtime+$Is_VMS,$to);
        _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
        next unless $from =~ /\.pm$/;
        _autosplit($to,$autodir);
    }
}


=begin _private

=item _autosplit

From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
the file being split.  This causes problems on systems with mandatory
locking (ie. Windows).  So we wrap it and close the filehandle.

=end _private

=cut

sub _autosplit { #XXX OS-SPECIFIC
    my $retval = autosplit(@_);
    close *AutoSplit::IN if defined *AutoSplit::IN{IO};

    return $retval;
}


package ExtUtils::Install::Warn;

sub new { bless {}, shift }

sub add {
    my($self,$file,$targetfile) = @_;
    push @{$self->{$file}}, $targetfile;
}

sub DESTROY {
    unless(defined $INSTALL_ROOT) {
        my $self = shift;
        my($file,$i,$plural);
        foreach $file (sort keys %$self) {
            $plural = @{$self->{$file}} > 1 ? "s" : "";
            print "## Differing version$plural of $file found. You might like to\n";
            for (0..$#{$self->{$file}}) {
                print "rm ", $self->{$file}[$_], "\n";
                $i++;
            }
        }
        $plural = $i>1 ? "all those files" : "this file";
        my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
                 ? ( $Config::Config{make} || 'make' ).' install UNINST=1'
                 : './Build install uninst=1';
        print "## Running '$inst' will unlink $plural for you.\n";
    }
}

=begin _private

=item _invokant

Does a heuristic on the stack to see who called us for more intelligent
error messages. Currently assumes we will be called only by Module::Build
or by ExtUtils::MakeMaker.

=end _private

=cut

sub _invokant {
    my @stack;
    my $frame = 0;
    while (my $file = (caller($frame++))[1]) {
        push @stack, (File::Spec->splitpath($file))[2];
    }

    my $builder;
    my $top = pop @stack;
    if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
        $builder = 'Module::Build';
    } else {
        $builder = 'ExtUtils::MakeMaker';
    }
    return $builder;
}


=back

=head1 ENVIRONMENT

=over 4

=item B<PERL_INSTALL_ROOT>

Will be prepended to each install path.

=item B<EU_INSTALL_IGNORE_SKIP>

Will prevent the automatic use of INSTALL.SKIP as the install skip file.

=item B<EU_INSTALL_SITE_SKIPFILE>

If there is no INSTALL.SKIP file in the make directory then this value
can be used to provide a default.

=back

=head1 AUTHOR

Original author lost in the mists of time.  Probably the same as Makemaker.

Production release currently maintained by demerphq C<yves at cpan.org>

Send bug reports via http://rt.cpan.org/.  Please send your
generated Makefile along with your report.

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>


=cut

1;