install.pm

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

}

=item _have_write_access

Abstract a -w check that tries to use POSIX::access() if possible.

=cut


{
    my  $has_posix;
    sub _have_write_access {
        my $dir=shift;
        if (!defined $has_posix) {
            $has_posix=eval "local $^W; require POSIX; 1" || 0;
        }
        if ($has_posix) {
            return POSIX::access($dir, POSIX::W_OK());
        } else {
            return -w $dir;
        }
    }
}


=item _can_write_dir(C<$dir>)

Checks whether a given directory is writable, taking account
the possibility that the directory might not exist and would have to
be created first.

Returns a list, containing: C<($writable, $determined_by, @create)>

C<$writable> says whether whether the directory is (hypothetically) writable

C<$determined_by> is the directory the status was determined from. It will be
either the C<$dir>, or one of its parents.

C<@create> is a list of directories that would probably have to be created
to make the requested directory. It may not actually be correct on
relative paths with C<..> in them. But for our purposes it should work ok

=cut


sub _can_write_dir {
    my $dir=shift;
    return
        unless defined $dir and length $dir;

    my ($vol, $dirs, $file) = File::Spec->splitpath(File::Spec->rel2abs($dir),1);
    my @dirs = File::Spec->splitdir($dirs);
    my $path='';
    my @make;
    while (@dirs) {
        $dir = File::Spec->catdir($vol,@dirs);
        next if ( $dir eq $path );
        if ( ! -e $dir ) {
            unshift @make,$dir;
            next;
        }
        if ( _have_write_access($dir) ) {
            return 1,$dir,@make
        } else {
            return 0,$dir,@make
        }
    } continue {
        pop @dirs;
    }
    return 0;
}

=item _mkpath($dir,$show,$mode,$verbose,$fake)

Wrapper around File::Path::mkpath() to handle errors.

If $verbose is true and >1 then additional diagnostics will be produced, also
this will force $show to true.

If $fake is true then the directory will not be created but a check will be
made to see whether it would be possible to write to the directory, or that
it would be possible to create the directory.

If $fake is not true dies if the directory can not be created or is not
writable.

=cut

sub _mkpath {
    my ($dir,$show,$mode,$verbose,$fake)=@_;
    if ( $verbose && $verbose > 1 && ! -d $dir) {
        $show= 1;
        printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
    }
    if (!$fake) {
        if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
            _choke("Can't create '$dir'","$@");
        }

    }
    my ($can,$root,@make)=_can_write_dir($dir);
    if (!$can) {
        my @msg=(
            "Can't create '$dir'",
            $root ? "Do not have write permissions on '$root'"
                  : "Unknown Error"
        );
        if ($fake) {
            _warnonce @msg;
        } else {
            _choke @msg;
        }
    } elsif ($show and $fake) {
        print "$_\n" for @make;
    }
}

=item _copy($from,$to,$verbose,$fake)

Wrapper around File::Copy::copy to handle errors.

If $verbose is true and >1 then additional dignostics will be emitted.

If $fake is true then the copy will not actually occur.

Dies if the copy fails.

=cut


sub _copy {
    my ( $from, $to, $verbose, $nonono)=@_;
    if ($verbose && $verbose>1) {
        printf "copy(%s,%s)\n", $from, $to;
    }
    if (!$nonono) {
        File::Copy::copy($from,$to)
            or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
    }
}

=item _chdir($from)

Wrapper around chdir to catch errors.

If not called in void context returns the cwd from before the chdir.

dies on error.

=cut

sub _chdir {
    my ($dir)= @_;
    my $ret;
    if (defined wantarray) {
        $ret= cwd;
    }
    chdir $dir
        or _choke("Couldn't chdir to '$dir': $!");
    return $ret;
}

=end _private

=cut

sub install { #XXX OS-SPECIFIC
    my($from_to,$verbose,$nonono,$inc_uninstall,$skip) = @_;
    $verbose ||= 0;
    $nonono  ||= 0;

    $skip= _get_install_skip($skip,$verbose);

    my(%from_to) = %$from_to;
    my(%pack, $dir, %warned);
    my($packlist) = ExtUtils::Packlist->new();

    local(*DIR);
    for (qw/read write/) {
        $pack{$_}=$from_to{$_};
        delete $from_to{$_};
    }
    my $tmpfile = install_rooted_file($pack{"read"});
    $packlist->read($tmpfile) if (-f $tmpfile);
    my $cwd = cwd();
    my @found_files;
    my %check_dirs;
    
    MOD_INSTALL: foreach my $source (sort keys %from_to) {
        #copy the tree to the target directory without altering
        #timestamp and permission and remember for the .packlist
        #file. The packlist file contains the absolute paths of the
        #install locations. AFS users may call this a bug. We'll have
        #to reconsider how to add the means to satisfy AFS users also.

        #October 1997: we want to install .pm files into archlib if
        #there are any files in arch. So we depend on having ./blib/arch
        #hardcoded here.

        my $targetroot = install_rooted_dir($from_to{$source});

        my $blib_lib  = File::Spec->catdir('blib', 'lib');
        my $blib_arch = File::Spec->catdir('blib', 'arch');
        if ($source eq $blib_lib and
            exists $from_to{$blib_arch} and
            directory_not_empty($blib_arch)
        ){
            $targetroot = install_rooted_dir($from_to{$blib_arch});
            print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
        }

        next unless -d $source;
        _chdir($source);
        # 5.5.3's File::Find missing no_chdir option
        # XXX OS-SPECIFIC
        # File::Find seems to always be Unixy except on MacPerl :(
        my $current_directory= $Is_MacPerl ? $Curdir : '.';
        find(sub {
            my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];

            return if !-f _;
            my $origfile = $_;

            return if $origfile eq ".exists";
            my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
            my $targetfile = File::Spec->catfile($targetdir, $origfile);
            my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
            my $sourcefile = File::Spec->catfile($sourcedir, $origfile);

            for my $pat (@$skip) {
                if ( $sourcefile=~/$pat/ ) {
                    print "Skipping $targetfile (filtered)\n"
                        if $verbose>1;
                    return;
                }
            }
            # we have to do this for back compat with old File::Finds
            # and because the target is relative
            my $save_cwd = _chdir($cwd); 
            my $diff = 0;
            if ( -f $targetfile && -s _ == $size) {
                # We have a good chance, we can skip this one
                $diff = compare($sourcefile, $targetfile);
            } else {
                $diff++;
            }
            $check_dirs{$targetdir}++ 
                unless -w $targetfile;
            
            push @found_files,
                [ $diff, $File::Find::dir, $origfile,
                  $mode, $size, $atime, $mtime,
                  $targetdir, $targetfile, $sourcedir, $sourcefile,
                  
                ];  
            #restore the original directory we were in when File::Find
            #called us so that it doesnt get horribly confused.
            _chdir($save_cwd);                
        }, $current_directory ); 
        _chdir($cwd);
    }   
    
    foreach my $targetdir (sort keys %check_dirs) {
        _mkpath( $targetdir, 0, 0755, $verbose, $nonono );
    }
    foreach my $found (@found_files) {
        my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
            $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
        
        my $realtarget= $targetfile;
        if ($diff) {
            if (-f $targetfile) {
                print "_unlink_or_rename($targetfile)\n" if $verbose>1;
                $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
                    unless $nonono;
            } elsif ( ! -d $targetdir ) {
                _mkpath( $targetdir, 0, 0755, $verbose, $nonono );
            }
            print "Installing $targetfile\n";
            _copy( $sourcefile, $targetfile, $verbose, $nonono, );
            #XXX OS-SPECIFIC
            print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
            utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;


            $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
            $mode = $mode | 0222
                if $realtarget ne $targetfile;
            _chmod( $mode, $targetfile, $verbose );
        } else {
            print "Skipping $targetfile (unchanged)\n" if $verbose;
        }

        if ( $inc_uninstall ) {
            inc_uninstall($sourcefile,$ffd, $verbose,
                          $nonono,
                          $realtarget ne $targetfile ? $realtarget : "");
        }

        # Record the full pathname.
        $packlist->{$targetfile}++;
    }

    if ($pack{'write'}) {
        $dir = install_rooted_dir(dirname($pack{'write'}));
        _mkpath( $dir, 0, 0755, $verbose, $nonono );
        print "Writing $pack{'write'}\n";
        $packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
    }

    _do_cleanup($verbose);
}

=begin _private

=item _do_cleanup

Standardize finish event for after another instruction has occured.
Handles converting $MUST_REBOOT to a die for instance.

=end _private

=cut

sub _do_cleanup {
    my ($verbose) = @_;
    if ($MUST_REBOOT) {
        die _estr "Operation not completed! ",
            "You must reboot to complete the installation.",
            "Sorry.";
    } elsif (defined $MUST_REBOOT & $verbose) {
        warn _estr "Installation will be completed at the next reboot.\n",
             "However it is not necessary to reboot immediately.\n";
    }
}

=begin _undocumented

=item install_rooted_file( $file )

Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
is defined.

=item install_rooted_dir( $dir )

Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
is defined.

=end _undocumented

=cut


sub install_rooted_file {
    if (defined $INSTALL_ROOT) {
        File::Spec->catfile($INSTALL_ROOT, $_[0]);
    } else {
        $_[0];
    }
}


sub install_rooted_dir {
    if (defined $INSTALL_ROOT) {
        File::Spec->catdir($INSTALL_ROOT, $_[0]);
    } else {
        $_[0];
    }
}

=begin _undocumented

=item forceunlink( $file, $tryhard )

Tries to delete a file. If $tryhard is true then we will use whatever
devious tricks we can to delete the file. Currently this only applies to
Win32 in that it will try to use Win32API::File to schedule a delete at
reboot. A wrapper for _unlink_or_rename().

=end _undocumented

=cut