perl/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_AmigaOS
	    %opts $packlist);
use subs qw(unlink link chmod);
require File::Path;
require File::Copy;

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_AmigaOS = $^O eq 'amigaos';

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_AmigaOS);
	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};
    my $link = $Is_AmigaOS ? \&CORE::symlink : \&CORE::link;
    eval {
      $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) = @_;

    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);

    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};
}

sub unixtoamiga
{
	my $unixpath = shift;

	my @parts = split("/",$unixpath);
	my $isdir = 0;
	$isdir = 1 if substr($unixpath,-1) eq "/";

	my $first = 1;
	my $amigapath = "";

	my $i = 0;

	for($i = 0; $i <= $#parts;$i++)
	{
		next if $parts[$i] eq ".";
		if($parts[$i] eq "..")
		{
			$parts[$i] = "/";
		}
		if($i == 0)
		{
			if($parts[$i] eq "")
			{
				$amigapath .= $parts[$i + 1] . ":";
				$i++;
				next;
			}
		}
		$amigapath .= $parts[$i];
		if($i != $#parts)
		{
			$amigapath .= "/" unless $parts[$i] eq "/" ;
		}
		else
		{
			if($isdir)
			{
				$amigapath .= "/" unless $parts[$i] eq "/" ;
			}
		}
	}

	return $amigapath;
}

sub amigaprotect
{
	my ($file,$bits) = @_;
	print "PROTECT: File $file\n";
	system("PROTECT $file $bits")
	      unless $opts{notify};
}

1;