X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4c3ca3f48a3e5f7633cf0ffcb5ac673bdbcf7f45..ee483bcc6527f06545fd67f1a3ca6dc07e36882d:/install_lib.pl

diff --git a/install_lib.pl b/install_lib.pl
index 8d37a0c..ac17bd8 100644
--- a/install_lib.pl
+++ b/install_lib.pl
@@ -4,21 +4,23 @@
 # Probably installhtml needs to join the club.
 
 use strict;
-use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare
+use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare $Is_AmigaOS
 	    %opts $packlist);
 use subs qw(unlink link chmod);
+require File::Path;
+require File::Copy;
 
-use Config;
 BEGIN {
-    if ($Config{userelocatableinc}) {
+    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 doesits ... expansion off that location.
+	# Config.pm does its ... expansion off that location.
 
-	my $location = $Config{initialinstalllocation};
+        my $location = $Config::Config{initialinstalllocation};
 	die <<'OS' unless defined $location;
 $Config{initialinstalllocation} is not defined - can't install a relocatable
 perl without this.
@@ -33,8 +35,8 @@ OS
 	# You never saw us. We weren't here.
 
 	require Config;
-	Config->import;
     }
+    Config->import;
 }
 
 if ($Config{d_umask}) {
@@ -47,6 +49,7 @@ $Is_OS2 = $^O eq 'os2';
 $Is_Cygwin = $^O eq 'cygwin';
 $Is_Darwin = $^O eq 'darwin';
 $Is_NetWare = $Config{osname} eq 'NetWare';
+$Is_AmigaOS = $^O eq 'amigaos';
 
 sub unlink {
     my(@names) = @_;
@@ -56,7 +59,7 @@ sub unlink {
 
     foreach my $name (@names) {
 	next unless -e $name;
-	chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare);
+	chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare || $Is_AmigaOS);
 	print "  unlink $name\n" if $opts{verbose};
 	( CORE::unlink($name) and ++$cnt
 	  or warn "Couldn't unlink $name: $!\n" ) unless $opts{notify};
@@ -74,15 +77,16 @@ sub link {
     $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 {
-	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' };
-    };
+      $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"
@@ -110,21 +114,92 @@ sub chmod {
       unless $opts{notify};
 }
 
-
 sub samepath {
     my($p1, $p2) = @_;
 
     return (lc($p1) eq lc($p2)) if ($Is_W32 || $Is_NetWare);
 
-    if ($p1 ne $p2) {
-	my($dev1, $ino1, $dev2, $ino2);
-	($dev1, $ino1) = stat($p1);
-	($dev2, $ino2) = stat($p2);
-	($dev1 ~~ $dev2 && $ino1 ~~ $ino2);
-    }
-    else {
-	1;
+    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;