view release on metacpan or  search on metacpan

bundled/ExtUtils-Install/ExtUtils/Install.pm  view on Meta::CPAN

}


sub _chmod($$;$) {
    my ( $mode, $item, $verbose )=@_;
    $verbose ||= 0;
    if (chmod $mode, $item) {
        printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
    } else {
        my $err="$!";
        _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
                  $mode, $item, $err
            if -e $item;
    }
}

=begin _private

=over

=item _move_file_at_boot( $file, $target, $moan  )

OS-Specific, Win32/Cygwin

Schedules a file to be moved/renamed/deleted at next boot.
$file should be a filespec of an existing file
$target should be a ref to an array if the file is to be deleted
otherwise it should be a filespec for a rename. If the file is existing
it will be replaced.

Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred
and sets it to 1 to indicate that a move operation has been requested.

returns 1 on success, on failure if $moan is false errors are fatal.
If $moan is true then returns 0 on error and warns instead of dies.

=end _private

=cut

{
    my $Has_Win32API_File;
    sub _move_file_at_boot { #XXX OS-SPECIFIC
        my ( $file, $target, $moan  )= @_;
        Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
             unless $CanMoveAtBoot;

        my $descr= ref $target
                    ? "'$file' for deletion"
                    : "'$file' for installation as '$target'";

        # *note* CanMoveAtBoot is only incidentally the same condition as below
        # this needs not hold true in the future.
        $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
            ? (eval {require Win32API::File; 1} || 0)
            : 0 unless defined $Has_Win32API_File;
        if ( ! $Has_Win32API_File ) {

            my @msg=(
                "Cannot schedule $descr at reboot.",
                "Try installing Win32API::File to allow operations on locked files",
                "to be scheduled during reboot. Or try to perform the operation by",
                "hand yourself. (You may need to close other perl processes first)"
            );
            if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
            return 0;
        }
        my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
        $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
            unless ref $target;

        _chmod( 0666, $file );
        _chmod( 0666, $target ) unless ref $target;

        if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
            $MUST_REBOOT ||= ref $target ? 0 : 1;
            return 1;
        } else {
            my @msg=(
                "MoveFileEx $descr at reboot failed: $^E",
                "You may try to perform the operation by hand yourself. ",
                "(You may need to close other perl processes first).",
            );
            if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
        }
        return 0;
    }
}


=begin _private


=item _unlink_or_rename( $file, $tryhard, $installing )

OS-Specific, Win32/Cygwin

Tries to get a file out of the way by unlinking it or renaming it. On
some OS'es (Win32 based) DLL files can end up locked such that they can
be renamed but not deleted. Likewise sometimes a file can be locked such
that it cant even be renamed or changed except at reboot. To handle
these cases this routine finds a tempfile name that it can either rename
the file out of the way or use as a proxy for the install so that the
rename can happen later (at reboot).

  $file : the file to remove.
  $tryhard : should advanced tricks be used for deletion
  $installing : we are not merely deleting but we want to overwrite

When $tryhard is not true if the unlink fails its fatal. When $tryhard
is true then the file is attempted to be renamed. The renamed file is
then scheduled for deletion. If the rename fails then $installing
governs what happens. If it is false the failure is fatal. If it is true
then an attempt is made to schedule installation at boot using a
temporary file to hold the new file. If this fails then a fatal error is
thrown, if it succeeds it returns the temporary file name (which will be
a derivative of the original in the same directory) so that the caller can
use it to install under. In all other cases of success returns $file.
On failure throws a fatal error.

=end _private

=cut



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

    # this chmod was originally unconditional. However, its not needed on
    # POSIXy systems since permission to unlink a file is specified by the
    # directory rather than the file; and in fact it screwed up hard- and
    # symlinked files. Keep it for other platforms in case its still
    # needed there.
    if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) {
        _chmod( 0666, $file );
    }
    my $unlink_count = 0;
    while (unlink $file) { $unlink_count++; }
    return $file if $unlink_count > 0;
    my $error="$!";

    _choke("Cannot unlink '$file': $!")
          unless $CanMoveAtBoot && $tryhard;

    my $tmp= "AAA";
    ++$tmp while -e "$file.$tmp";
    $tmp= "$file.$tmp";

    warn "WARNING: Unable to unlink '$file': $error\n",
         "Going to try to rename it to '$tmp'.\n";

    if ( rename $file, $tmp ) {
        warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n";
        # when $installing we can set $moan to true.
        # IOW, if we cant delete the renamed file at reboot its
        # not the end of the world. The other cases are more serious
        # and need to be fatal.
        _move_file_at_boot( $tmp, [], $installing );
        return $file;