The Install.pm third of

Subject: Proposed patches, Install.pm getopts.pl termcap.pl
Message-ID: <20001005180451.A22029@kstarr.celestial.com>

p4raw-id: //depot/perl@7210

diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm
index 36c7221..92db8c9 100644 (file)
--- a/lib/ExtUtils/Install.pm
+++ b/lib/ExtUtils/Install.pm
@@ -16,6 +16,28 @@ my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
 my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
 my $Inc_uninstall_warn_handler;
 
+# install relative to here
+
+my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
+
+use File::Spec;
+
+sub install_rooted_file {
+    if (defined $INSTALL_ROOT) {
+       MY->catfile($INSTALL_ROOT, $_[0]);
+    } else {
+       $_[0];
+    }
+}
+
+sub install_rooted_dir {
+    if (defined $INSTALL_ROOT) {
+       MY->catdir($INSTALL_ROOT, $_[0]);
+    } else {
+       $_[0];
+    }
+}
+
 #our(@EXPORT, @ISA, $Is_VMS);
 #use strict;
 
@@ -55,8 +77,9 @@ sub install {
        opendir DIR, $source_dir_or_file or next;
        for (readdir DIR) {
            next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
-           if (-w $hash{$source_dir_or_file} ||
-               mkpath($hash{$source_dir_or_file})) {
+               my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
+           if (-w $targetdir ||
+               mkpath($targetdir)) {
                last;
            } else {
                warn "Warning: You do not have permissions to " .
@@ -66,7 +89,8 @@ sub install {
        }
        closedir DIR;
     }
-    $packlist->read($pack{"read"}) if (-f $pack{"read"});
+    my $tmpfile = install_rooted_file($pack{"read"});
+    $packlist->read($tmpfile) if (-f $tmpfile);
     my $cwd = cwd();
 
     my($source);
@@ -80,11 +104,13 @@ sub install {
        #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 = $hash{$source};
+
+       my $targetroot = install_rooted_dir($hash{$source});
+
        if ($source eq "blib/lib" and
            exists $hash{"blib/arch"} and
            directory_not_empty("blib/arch")) {
-           $targetroot = $hash{"blib/arch"};
+           $targetroot = install_rooted_dir($hash{"blib/arch"});
             print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
        }
        chdir($source) or next;
@@ -93,8 +119,9 @@ sub install {
                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
            return unless -f _;
            return if $_ eq ".exists";
-           my $targetdir = MY->catdir($targetroot,$File::Find::dir);
-           my $targetfile = MY->catfile($targetdir,$_);
+           my $targetdir  = MY->catdir($targetroot, $File::Find::dir);
+           my $origfile   = $_;
+           my $targetfile = MY->catfile($targetdir, $_);
 
            my $diff = 0;
            if ( -f $targetfile && -s _ == $size) {
@@ -129,16 +156,16 @@ sub install {
            } else {
                inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
            }
-           $packlist->{$targetfile}++;
+           $packlist->{$origfile}++;
 
        }, ".");
        chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
     }
     if ($pack{'write'}) {
-       $dir = dirname($pack{'write'});
+       $dir = install_rooted_dir(dirname($pack{'write'}));
        mkpath($dir,0,0755);
        print "Writing $pack{'write'}\n";
-       $packlist->write($pack{'write'});
+       $packlist->write(install_rooted_file($pack{'write'}));
     }
 }
 
@@ -289,18 +316,20 @@ sub add {
 }
 
 sub DESTROY {
-    my $self = shift;
-    my($file,$i,$plural);
-    foreach $file (sort keys %$self) {
-       $plural = @{$self->{$file}} > 1 ? "s" : "";
-       print "## Differing version$plural of $file found. You might like to\n";
-       for (0..$#{$self->{$file}}) {
-           print "rm ", $self->{$file}[$_], "\n";
-           $i++;
+       unless(defined $INSTALL_ROOT) {
+               my $self = shift;
+               my($file,$i,$plural);
+               foreach $file (sort keys %$self) {
+               $plural = @{$self->{$file}} > 1 ? "s" : "";
+               print "## Differing version$plural of $file found. You might like to\n";
+               for (0..$#{$self->{$file}}) {
+                       print "rm ", $self->{$file}[$_], "\n";
+                       $i++;
+               }
+               }
+               $plural = $i>1 ? "all those files" : "this file";
+               print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
        }
-    }
-    $plural = $i>1 ? "all those files" : "this file";
-    print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
 }
 
 1;