This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Old RCS $Date$ tag
[perl5.git] / lib / ExtUtils / Install.pm
index 36c7221..695c02e 100644 (file)
@@ -1,9 +1,8 @@
 package ExtUtils::Install;
 
-use 5.005_64;
+use 5.006_001;
 our(@ISA, @EXPORT, $VERSION);
-$VERSION = substr q$Revision: 1.28 $, 10;
-# $Date: 1998/01/25 07:08:24 $
+$VERSION = 1.29
 
 use Exporter;
 use Carp ();
@@ -16,6 +15,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) {
+       File::Spec->catfile($INSTALL_ROOT, $_[0]);
+    } else {
+       $_[0];
+    }
+}
+
+sub install_rooted_dir {
+    if (defined $INSTALL_ROOT) {
+       File::Spec->catdir($INSTALL_ROOT, $_[0]);
+    } else {
+       $_[0];
+    }
+}
+
 #our(@EXPORT, @ISA, $Is_VMS);
 #use strict;
 
@@ -30,13 +51,13 @@ sub install {
     $nonono  ||= 0;
 
     use Cwd qw(cwd);
-    use ExtUtils::MakeMaker; # to implement a MY class
     use ExtUtils::Packlist;
     use File::Basename qw(dirname);
     use File::Copy qw(copy);
     use File::Find qw(find);
     use File::Path qw(mkpath);
     use File::Compare qw(compare);
+    use File::Spec;
 
     my(%hash) = %$hash;
     my(%pack, $dir, $warn_permissions);
@@ -55,8 +76,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 +88,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 +103,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 +118,8 @@ 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  = File::Spec->catdir($targetroot, $File::Find::dir);
+           my $targetfile = File::Spec->catfile($targetdir, $_);
 
            my $diff = 0;
            if ( -f $targetfile && -s _ == $size) {
@@ -129,16 +154,17 @@ sub install {
            } else {
                inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
            }
+           # Record the full pathname.
            $packlist->{$targetfile}++;
 
        }, ".");
        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'}));
     }
 }
 
@@ -159,12 +185,12 @@ sub install_default {
   @_ < 2 or die "install_default should be called with 0 or 1 argument";
   my $FULLEXT = @_ ? shift : $ARGV[0];
   defined $FULLEXT or die "Do not know to where to write install log";
-  my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
-  my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
-  my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
-  my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
-  my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
-  my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
+  my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
+  my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
+  my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
+  my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
+  my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
+  my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
   install({
           read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
           write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
@@ -205,7 +231,7 @@ sub inc_uninstall {
                                                  sitelibexp)}) {
        next if $dir eq ".";
        next if $seen_dir{$dir}++;
-       my($targetfile) = MY->catfile($dir,$libdir,$file);
+       my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
        next unless -f $targetfile;
 
        # The reason why we compare file's contents is, that we cannot
@@ -235,8 +261,21 @@ sub inc_uninstall {
     }
 }
 
+sub run_filter {
+    my ($cmd, $src, $dest) = @_;
+    open(my $CMD, "|$cmd >$dest") || die "Cannot fork: $!";
+    open(my $SRC, $src)           || die "Cannot open $src: $!";
+    my $buf;
+    my $sz = 1024;
+    while (my $len = sysread($SRC, $buf, $sz)) {
+       syswrite($CMD, $buf, $len);
+    }
+    close $SRC;
+    close $CMD or die "Filter command '$cmd' failed for $src";
+}
+
 sub pm_to_blib {
-    my($fromto,$autodir) = @_;
+    my($fromto,$autodir,$pm_filter) = @_;
 
     use File::Basename qw(dirname);
     use File::Copy qw(copy);
@@ -259,23 +298,37 @@ sub pm_to_blib {
 
     mkpath($autodir,0,0755);
     foreach (keys %$fromto) {
-       next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
-       unless (compare($_,$fromto->{$_})){
-           print "Skip $fromto->{$_} (unchanged)\n";
+       my $dest = $fromto->{$_};
+       next if -f $dest && -M $dest < -M $_;
+
+       # When a pm_filter is defined, we need to pre-process the source first
+       # to determine whether it has changed or not.  Therefore, only perform
+       # the comparison check when there's no filter to be ran.
+       #    -- RAM, 03/01/2001
+
+       my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;
+
+       if (!$need_filtering && 0 == compare($_,$dest)) {
+           print "Skip $dest (unchanged)\n";
            next;
        }
-       if (-f $fromto->{$_}){
-           forceunlink($fromto->{$_});
+       if (-f $dest){
+           forceunlink($dest);
        } else {
-           mkpath(dirname($fromto->{$_}),0,0755);
+           mkpath(dirname($dest),0,0755);
+       }
+       if ($need_filtering) {
+           run_filter($pm_filter, $_, $dest);
+           print "$pm_filter <$_ >$dest\n";
+       } else {
+           copy($_,$dest);
+           print "cp $_ $dest\n";
        }
-       copy($_,$fromto->{$_});
        my($mode,$atime,$mtime) = (stat)[2,8,9];
-       utime($atime,$mtime+$Is_VMS,$fromto->{$_});
-       chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
-       print "cp $_ $fromto->{$_}\n";
-       next unless /\.pm\z/;
-       autosplit($fromto->{$_},$autodir);
+       utime($atime,$mtime+$Is_VMS,$dest);
+       chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
+       next unless /\.pm$/;
+       autosplit($dest,$autodir);
     }
 }
 
@@ -289,18 +342,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;
@@ -363,6 +418,11 @@ no-don't-really-do-it-now switch.
 pm_to_blib() takes a hashref as the first argument and copies all keys
 of the hash to the corresponding values efficiently. Filenames with
 the extension pm are autosplit. Second argument is the autosplit
-directory.
+directory.  If third argument is not empty, it is taken as a filter command
+to be ran on each .pm file, the output of the command being what is finally
+copied, and the source for auto-splitting.
+
+You can have an environment variable PERL_INSTALL_ROOT set which will
+be prepended as a directory to each installed file (and directory).
 
 =cut