spelling: till -> until

[perl5.git] / install_lib.pl

#!perl

# Initialisation code and subroutines shared between installperl and installman
# Probably installhtml needs to join the club.

use strict;
use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare
	    %opts $packlist);
use subs qw(unlink link chmod);
require File::Path;

BEGIN {
    require Config;
    if ($Config::Config{userelocatableinc}) {
	# This might be a considered a hack. Need to get information about the
	# configuration from Config.pm *before* Config.pm expands any .../
	# prefixes.
	#
	# So we set $^X to pretend that we're the already installed perl, so
	# Config.pm does its ... expansion off that location.

        my $location = $Config::Config{initialinstalllocation};
	die <<'OS' unless defined $location;
$Config{initialinstalllocation} is not defined - can't install a relocatable
perl without this.
OS
	$^X = "$location/perl";
	# And then remove all trace of ever having loaded Config.pm, so that
	# it will reload with the revised $^X
	undef %Config::;
	delete $INC{"Config.pm"};
	delete $INC{"Config_heavy.pl"};
	delete $INC{"Config_git.pl"};
	# You never saw us. We weren't here.

	require Config;
    }
    Config->import;
}

if ($Config{d_umask}) {
    umask(022); # umasks like 077 aren't that useful for installations
}

$Is_VMS = $^O eq 'VMS';
$Is_W32 = $^O eq 'MSWin32';
$Is_OS2 = $^O eq 'os2';
$Is_Cygwin = $^O eq 'cygwin';
$Is_Darwin = $^O eq 'darwin';
$Is_NetWare = $Config{osname} eq 'NetWare';

sub unlink {
    my(@names) = @_;
    my($cnt) = 0;

    return scalar(@names) if $Is_VMS;

    foreach my $name (@names) {
	next unless -e $name;
	chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare);
	print "  unlink $name\n" if $opts{verbose};
	( CORE::unlink($name) and ++$cnt
	  or warn "Couldn't unlink $name: $!\n" ) unless $opts{notify};
    }
    return $cnt;
}

sub link {
    my($from,$to) = @_;
    my($success) = 0;

    my $xfrom = $from;
    $xfrom =~ s/^\Q$opts{destdir}\E// if $opts{destdir};
    my $xto = $to;
    $xto =~ s/^\Q$opts{destdir}\E// if $opts{destdir};
    print $opts{verbose} ? "  ln $xfrom $xto\n" : "  $xto\n"
	unless $opts{silent};
    eval {
	CORE::link($from, $to)
	    ? $success++
	    : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
	      ? die "AFS"  # okay inside eval {}
	      : die "Couldn't link $from to $to: $!\n"
	  unless $opts{notify};
	$packlist->{$xto} = { from => $xfrom, type => 'link' };
    };
    if ($@) {
	warn "Replacing link() with File::Copy::copy(): $@";
	print $opts{verbose} ? "  cp $from $xto\n" : "  $xto\n"
	    unless $opts{silent};
	print "  creating new version of $xto\n"
		 if $Is_VMS and -e $to and !$opts{silent};
	unless ($opts{notify} or File::Copy::copy($from, $to) and ++$success) {
	    # Might have been that F::C::c can't overwrite the target
	    warn "Couldn't copy $from to $to: $!\n"
		unless -f $to and (chmod(0666, $to), unlink $to)
			and File::Copy::copy($from, $to) and ++$success;
	}
	$packlist->{$xto} = { type => 'file' };
    }
    $success;
}

sub chmod {
    my($mode,$name) = @_;

    return if ($^O eq 'dos');
    printf "  chmod %o %s\n", $mode, $name if $opts{verbose};
    CORE::chmod($mode,$name)
	|| warn sprintf("Couldn't chmod %o %s: $!\n", $mode, $name)
      unless $opts{notify};
}

sub samepath {
    my($p1, $p2) = @_;

    return (lc($p1) eq lc($p2)) if ($Is_W32 || $Is_NetWare);

    return 1
        if $p1 eq $p2;

    my ($dev1, $ino1) = stat $p1;
    return 0
        unless defined $dev1;
    my ($dev2, $ino2) = stat $p2;

    return $dev1 == $dev2 && $ino1 == $ino2;
}

sub safe_rename {
    my($from,$to) = @_;
    if (-f $to and not unlink($to)) {
        my($i);
        for ($i = 1; $i < 50; $i++) {
            last if rename($to, "$to.$i");
        }
        warn("Cannot rename to '$to.$i': $!"), return 0
           if $i >= 50; # Give up!
    }
    link($from,$to) || return 0;
    unlink($from);
}

sub mkpath {
    File::Path::mkpath(shift , $opts{verbose}, 0777) unless $opts{notify};
}

1;