[perl5.git] / lib / ExtUtils / Install.pm

package ExtUtils::Install;

use 5.006_001;
our(@ISA, @EXPORT, $VERSION);
$VERSION = substr q$Revision: 1.29 $, 10;
# $Date: 1998/01/25 07:08:24 $

use Exporter;
use Carp ();
use Config qw(%Config);
@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
$Is_VMS = $^O eq 'VMS';

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;

sub forceunlink {
    chmod 0666, $_[0];
    unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
}

sub install {
    my($hash,$verbose,$nonono,$inc_uninstall) = @_;
    $verbose ||= 0;
    $nonono  ||= 0;

    use Cwd qw(cwd);
    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);
    my($packlist) = ExtUtils::Packlist->new();
    # -w doesn't work reliably on FAT dirs
    $warn_permissions++ if $^O eq 'MSWin32';
    local(*DIR);
    for (qw/read write/) {
	$pack{$_}=$hash{$_};
	delete $hash{$_};
    }
    my($source_dir_or_file);
    foreach $source_dir_or_file (sort keys %hash) {
	#Check if there are files, and if yes, look if the corresponding
	#target directory is writable for us
	opendir DIR, $source_dir_or_file or next;
	for (readdir DIR) {
	    next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
		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 " .
		    "install into $hash{$source_dir_or_file}"
		    unless $warn_permissions++;
	    }
	}
	closedir DIR;
    }
    my $tmpfile = install_rooted_file($pack{"read"});
    $packlist->read($tmpfile) if (-f $tmpfile);
    my $cwd = cwd();

    my($source);
    MOD_INSTALL: foreach $source (sort keys %hash) {
	#copy the tree to the target directory without altering
	#timestamp and permission and remember for the .packlist
	#file. The packlist file contains the absolute paths of the
	#install locations. AFS users may call this a bug. We'll have
	#to reconsider how to add the means to satisfy AFS users also.

	#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 = install_rooted_dir($hash{$source});

	if ($source eq "blib/lib" and
	    exists $hash{"blib/arch"} and
	    directory_not_empty("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;
	find(sub {
	    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                         $atime,$mtime,$ctime,$blksize,$blocks) = stat;
	    return unless -f _;
	    return if $_ eq ".exists";
	    my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
	    my $targetfile = File::Spec->catfile($targetdir, $_);

	    my $diff = 0;
	    if ( -f $targetfile && -s _ == $size) {
		# We have a good chance, we can skip this one
		$diff = compare($_,$targetfile);
	    } else {
		print "$_ differs\n" if $verbose>1;
		$diff++;
	    }

	    if ($diff){
		if (-f $targetfile){
		    forceunlink($targetfile) unless $nonono;
		} else {
		    mkpath($targetdir,0,0755) unless $nonono;
		    print "mkpath($targetdir,0,0755)\n" if $verbose>1;
		}
		copy($_,$targetfile) unless $nonono;
		print "Installing $targetfile\n";
		utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
		print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
		$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
		chmod $mode, $targetfile;
		print "chmod($mode, $targetfile)\n" if $verbose>1;
	    } else {
		print "Skipping $targetfile (unchanged)\n" if $verbose;
	    }
	    
	    if (! defined $inc_uninstall) { # it's called 
	    } elsif ($inc_uninstall == 0){
		inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
	    } 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 = install_rooted_dir(dirname($pack{'write'}));
	mkpath($dir,0,0755);
	print "Writing $pack{'write'}\n";
	$packlist->write(install_rooted_file($pack{'write'}));
    }
}

sub directory_not_empty ($) {
  my($dir) = @_;
  my $files = 0;
  find(sub {
	   return if $_ eq ".exists";
	   if (-f) {
	     $File::Find::prune++;
	     $files = 1;
	   }
       }, $dir);
  return $files;
}

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 = 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",
	   $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
			 $Config{installsitearch} :
			 $Config{installsitelib},
	   $INST_ARCHLIB => $Config{installsitearch},
	   $INST_BIN => $Config{installbin} ,
	   $INST_SCRIPT => $Config{installscript},
	   $INST_MAN1DIR => $Config{installman1dir},
	   $INST_MAN3DIR => $Config{installman3dir},
	  },1,0,0);
}

sub uninstall {
    use ExtUtils::Packlist;
    my($fil,$verbose,$nonono) = @_;
    die "no packlist file found: $fil" unless -f $fil;
    # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
    # require $my_req; # Hairy, but for the first
    my ($packlist) = ExtUtils::Packlist->new($fil);
    foreach (sort(keys(%$packlist))) {
	chomp;
	print "unlink $_\n" if $verbose;
	forceunlink($_) unless $nonono;
    }
    print "unlink $fil\n" if $verbose;
    forceunlink($fil) unless $nonono;
}

sub inc_uninstall {
    my($file,$libdir,$verbose,$nonono) = @_;
    my($dir);
    my %seen_dir = ();
    foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
						  privlibexp
						  sitearchexp
						  sitelibexp)}) {
	next if $dir eq ".";
	next if $seen_dir{$dir}++;
	my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
	next unless -f $targetfile;

	# The reason why we compare file's contents is, that we cannot
	# know, which is the file we just installed (AFS). So we leave
	# an identical file in place
	my $diff = 0;
	if ( -f $targetfile && -s _ == -s $file) {
	    # We have a good chance, we can skip this one
	    $diff = compare($file,$targetfile);
	} else {
	    print "#$file and $targetfile differ\n" if $verbose>1;
	    $diff++;
	}

	next unless $diff;
	if ($nonono) {
	    if ($verbose) {
		$Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
		$libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
		$Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
	    }
	    # if not verbose, we just say nothing
	} else {
	    print "Unlinking $targetfile (shadowing?)\n";
	    forceunlink($targetfile);
	}
    }
}

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,$pm_filter) = @_;

    use File::Basename qw(dirname);
    use File::Copy qw(copy);
    use File::Path qw(mkpath);
    use File::Compare qw(compare);
    use AutoSplit;
    # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
    # require $my_req; # Hairy, but for the first

    if (!ref($fromto) && -r $fromto)
     {
      # Win32 has severe command line length limitations, but
      # can generate temporary files on-the-fly
      # so we pass name of file here - eval it to get hash 
      open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
      my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
      eval $str;
      close(FROMTO);
     }

    mkpath($autodir,0,0755);
    foreach (keys %$fromto) {
	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 $dest){
	    forceunlink($dest);
	} else {
	    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";
	}
	my($mode,$atime,$mtime) = (stat)[2,8,9];
	utime($atime,$mtime+$Is_VMS,$dest);
	chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
	next unless /\.pm$/;
	autosplit($dest,$autodir);
    }
}

package ExtUtils::Install::Warn;

sub new { bless {}, shift }

sub add {
    my($self,$file,$targetfile) = @_;
    push @{$self->{$file}}, $targetfile;
}

sub DESTROY {
	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";
	}
}

1;

__END__

=head1 NAME

ExtUtils::Install - install files from here to there

=head1 SYNOPSIS

B<use ExtUtils::Install;>

B<install($hashref,$verbose,$nonono);>

B<uninstall($packlistfile,$verbose,$nonono);>

B<pm_to_blib($hashref);>

=head1 DESCRIPTION

Both install() and uninstall() are specific to the way
ExtUtils::MakeMaker handles the installation and deinstallation of
perl modules. They are not designed as general purpose tools.

install() takes three arguments. A reference to a hash, a verbose
switch and a don't-really-do-it switch. The hash ref contains a
mapping of directories: each key/value pair is a combination of
directories to be copied. Key is a directory to copy from, value is a
directory to copy to. The whole tree below the "from" directory will
be copied preserving timestamps and permissions.

There are two keys with a special meaning in the hash: "read" and
"write". After the copying is done, install will write the list of
target files to the file named by C<$hashref-E<gt>{write}>. If there is
another file named by C<$hashref-E<gt>{read}>, the contents of this file will
be merged into the written file. The read and the written file may be
identical, but on AFS it is quite likely that people are installing to a
different directory than the one where the files later appear.

install_default() takes one or less arguments.  If no arguments are 
specified, it takes $ARGV[0] as if it was specified as an argument.  
The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.  
This function calls install() with the same arguments as the defaults 
the MakeMaker would use.

The argument-less form is convenient for install scripts like

  perl -MExtUtils::Install -e install_default Tk/Canvas

Assuming this command is executed in a directory with a populated F<blib> 
directory, it will proceed as if the F<blib> was build by MakeMaker on 
this machine.  This is useful for binary distributions.

uninstall() takes as first argument a file containing filenames to be
unlinked. The second argument is a verbose switch, the third is a
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.  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
Commit	Line	Data
4b6d56d3	1	package ExtUtils::Install;
4b6d56d3	2
3b825e41	3	use 5.006_001;
17f410f9	4	our(@ISA, @EXPORT, $VERSION);
88d01e8d	5	$VERSION = substr q$Revision: 1.29 $, 10;
456e5c25	6	# $Date: 1998/01/25 07:08:24 $
f1387719	7
08ad6bd5	8	use Exporter;
08ad6bd5	9	use Carp ();
c3648e42	10	use Config qw(%Config);
4b6d56d3	11	@ISA = ('Exporter');
c3648e42	12	@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
08ad6bd5	13	$Is_VMS = $^O eq 'VMS';
08ad6bd5	14
39e571d4	15	my $splitchar = $^O eq 'VMS' ? '\|' : ($^O eq 'os2' \|\| $^O eq 'dos') ? ';' : ':';
d6abf24b	16	my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} \|\| '';
f1387719	17	my $Inc_uninstall_warn_handler;
f1387719	18
a9d83807 BC	19	# install relative to here
	20
	21	my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
	22
	23	use File::Spec;
	24
	25	sub install_rooted_file {
	26	if (defined $INSTALL_ROOT) {
3ac85e8f	27	File::Spec->catfile($INSTALL_ROOT, $_[0]);
a9d83807 BC	28	} else {
	29	$_[0];
	30	}
	31	}
	32
	33	sub install_rooted_dir {
	34	if (defined $INSTALL_ROOT) {
3ac85e8f	35	File::Spec->catdir($INSTALL_ROOT, $_[0]);
a9d83807 BC	36	} else {
	37	$_[0];
	38	}
	39	}
	40
17f410f9	41	#our(@EXPORT, @ISA, $Is_VMS);
4b6d56d3	42	#use strict;
4b6d56d3	43
f1387719	44	sub forceunlink {
	45	chmod 0666, $_[0];
	46	unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
	47	}
08ad6bd5	48
4b6d56d3	49	sub install {
f1387719	50	my($hash,$verbose,$nonono,$inc_uninstall) = @_;
4b6d56d3	51	$verbose \|\|= 0;
4b6d56d3	52	$nonono \|\|= 0;
08ad6bd5	53
08ad6bd5	54	use Cwd qw(cwd);
354f3b56	55	use ExtUtils::Packlist;
08ad6bd5	56	use File::Basename qw(dirname);
	57	use File::Copy qw(copy);
	58	use File::Find qw(find);
	59	use File::Path qw(mkpath);
fb73857a	60	use File::Compare qw(compare);
3ac85e8f	61	use File::Spec;
08ad6bd5	62
4b6d56d3	63	my(%hash) = %$hash;
354f3b56 AB	64	my(%pack, $dir, $warn_permissions);
354f3b56 AB	65	my($packlist) = ExtUtils::Packlist->new();
3e3baf6d TB	66	# -w doesn't work reliably on FAT dirs
3e3baf6d TB	67	$warn_permissions++ if $^O eq 'MSWin32';
354f3b56	68	local(*DIR);
4b6d56d3	69	for (qw/read write/) {
	70	$pack{$_}=$hash{$_};
	71	delete $hash{$_};
	72	}
08ad6bd5	73	my($source_dir_or_file);
08ad6bd5	74	foreach $source_dir_or_file (sort keys %hash) {
4b6d56d3	75	#Check if there are files, and if yes, look if the corresponding
4b6d56d3	76	#target directory is writable for us
08ad6bd5	77	opendir DIR, $source_dir_or_file or next;
f1387719	78	for (readdir DIR) {
4b6d56d3	79	next if $_ eq "." \|\| $_ eq ".." \|\| $_ eq ".exists";
a9d83807 BC	80	my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
	81	if (-w $targetdir \|\|
	82	mkpath($targetdir)) {
4b6d56d3	83	last;
4b6d56d3	84	} else {
456e5c25 A	85	warn "Warning: You do not have permissions to " .
456e5c25 A	86	"install into $hash{$source_dir_or_file}"
cee7b94a	87	unless $warn_permissions++;
4b6d56d3	88	}
	89	}
	90	closedir DIR;
	91	}
a9d83807 BC	92	my $tmpfile = install_rooted_file($pack{"read"});
a9d83807 BC	93	$packlist->read($tmpfile) if (-f $tmpfile);
4b6d56d3	94	my $cwd = cwd();
4b6d56d3	95
4b6d56d3	96	my($source);
	97	MOD_INSTALL: foreach $source (sort keys %hash) {
	98	#copy the tree to the target directory without altering
	99	#timestamp and permission and remember for the .packlist
	100	#file. The packlist file contains the absolute paths of the
	101	#install locations. AFS users may call this a bug. We'll have
	102	#to reconsider how to add the means to satisfy AFS users also.
456e5c25 A	103
	104	#October 1997: we want to install .pm files into archlib if
	105	#there are any files in arch. So we depend on having ./blib/arch
	106	#hardcoded here.
a9d83807 BC	107
	108	my $targetroot = install_rooted_dir($hash{$source});
	109
e8aa0dbc AB	110	if ($source eq "blib/lib" and
	111	exists $hash{"blib/arch"} and
	112	directory_not_empty("blib/arch")) {
a9d83807	113	$targetroot = install_rooted_dir($hash{"blib/arch"});
dcc96bbd	114	print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
456e5c25	115	}
4b6d56d3	116	chdir($source) or next;
	117	find(sub {
	118	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	119	$atime,$mtime,$ctime,$blksize,$blocks) = stat;
	120	return unless -f _;
	121	return if $_ eq ".exists";
3ac85e8f DR	122	my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
3ac85e8f DR	123	my $targetfile = File::Spec->catfile($targetdir, $_);
4b6d56d3	124
f1387719	125	my $diff = 0;
4b6d56d3	126	if ( -f $targetfile && -s _ == $size) {
4b6d56d3	127	# We have a good chance, we can skip this one
fb73857a	128	$diff = compare($_,$targetfile);
4b6d56d3	129	} else {
	130	print "$_ differs\n" if $verbose>1;
	131	$diff++;
	132	}
	133
	134	if ($diff){
08ad6bd5	135	if (-f $targetfile){
f1387719	136	forceunlink($targetfile) unless $nonono;
08ad6bd5	137	} else {
	138	mkpath($targetdir,0,0755) unless $nonono;
	139	print "mkpath($targetdir,0,0755)\n" if $verbose>1;
	140	}
4b6d56d3	141	copy($_,$targetfile) unless $nonono;
f1387719	142	print "Installing $targetfile\n";
08ad6bd5	143	utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
4b6d56d3	144	print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
f1387719	145	$mode = 0444 \| ( $mode & 0111 ? 0111 : 0 );
4b6d56d3	146	chmod $mode, $targetfile;
	147	print "chmod($mode, $targetfile)\n" if $verbose>1;
	148	} else {
f1387719	149	print "Skipping $targetfile (unchanged)\n" if $verbose;
	150	}
	151
	152	if (! defined $inc_uninstall) { # it's called
	153	} elsif ($inc_uninstall == 0){
	154	inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
	155	} else {
	156	inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
4b6d56d3	157	}
8c05f1d0	158	# Record the full pathname.
007a26ab	159	$packlist->{$targetfile}++;
4b6d56d3	160
4b6d56d3	161	}, ".");
08ad6bd5	162	chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
4b6d56d3	163	}
4b6d56d3	164	if ($pack{'write'}) {
a9d83807	165	$dir = install_rooted_dir(dirname($pack{'write'}));
4b6d56d3	166	mkpath($dir,0,0755);
4b6d56d3	167	print "Writing $pack{'write'}\n";
a9d83807	168	$packlist->write(install_rooted_file($pack{'write'}));
4b6d56d3	169	}
	170	}
	171
456e5c25 A	172	sub directory_not_empty ($) {
	173	my($dir) = @_;
	174	my $files = 0;
	175	find(sub {
	176	return if $_ eq ".exists";
	177	if (-f) {
	178	$File::Find::prune++;
	179	$files = 1;
	180	}
	181	}, $dir);
	182	return $files;
	183	}
	184
c3648e42 IZ	185	sub install_default {
	186	@_ < 2 or die "install_default should be called with 0 or 1 argument";
	187	my $FULLEXT = @_ ? shift : $ARGV[0];
	188	defined $FULLEXT or die "Do not know to where to write install log";
5de3f0da DR	189	my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
	190	my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
	191	my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
	192	my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
	193	my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
	194	my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
c3648e42 IZ	195	install({
	196	read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
	197	write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
456e5c25 A	198	$INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
	199	$Config{installsitearch} :
	200	$Config{installsitelib},
c3648e42 IZ	201	$INST_ARCHLIB => $Config{installsitearch},
	202	$INST_BIN => $Config{installbin} ,
	203	$INST_SCRIPT => $Config{installscript},
	204	$INST_MAN1DIR => $Config{installman1dir},
	205	$INST_MAN3DIR => $Config{installman3dir},
	206	},1,0,0);
	207	}
	208
4b6d56d3	209	sub uninstall {
354f3b56	210	use ExtUtils::Packlist;
4b6d56d3	211	my($fil,$verbose,$nonono) = @_;
4b6d56d3	212	die "no packlist file found: $fil" unless -f $fil;
f1387719	213	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	214	# require $my_req; # Hairy, but for the first
354f3b56 AB	215	my ($packlist) = ExtUtils::Packlist->new($fil);
354f3b56 AB	216	foreach (sort(keys(%$packlist))) {
4b6d56d3	217	chomp;
4b6d56d3	218	print "unlink $_\n" if $verbose;
f1387719	219	forceunlink($_) unless $nonono;
4b6d56d3	220	}
4b6d56d3	221	print "unlink $fil\n" if $verbose;
f1387719	222	forceunlink($fil) unless $nonono;
	223	}
	224
	225	sub inc_uninstall {
	226	my($file,$libdir,$verbose,$nonono) = @_;
	227	my($dir);
f1387719	228	my %seen_dir = ();
456e5c25 A	229	foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
	230	privlibexp
	231	sitearchexp
	232	sitelibexp)}) {
f1387719	233	next if $dir eq ".";
f1387719	234	next if $seen_dir{$dir}++;
3ac85e8f	235	my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
f1387719	236	next unless -f $targetfile;
	237
	238	# The reason why we compare file's contents is, that we cannot
	239	# know, which is the file we just installed (AFS). So we leave
	240	# an identical file in place
	241	my $diff = 0;
	242	if ( -f $targetfile && -s _ == -s $file) {
	243	# We have a good chance, we can skip this one
fb73857a	244	$diff = compare($file,$targetfile);
f1387719	245	} else {
	246	print "#$file and $targetfile differ\n" if $verbose>1;
	247	$diff++;
	248	}
	249
	250	next unless $diff;
	251	if ($nonono) {
	252	if ($verbose) {
	253	$Inc_uninstall_warn_handler \|\|= new ExtUtils::Install::Warn;
4f44ac69	254	$libdir =~ s\|^\./\|\|s ; # That's just cosmetics, no need to port. It looks prettier.
f1387719	255	$Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
	256	}
	257	# if not verbose, we just say nothing
	258	} else {
	259	print "Unlinking $targetfile (shadowing?)\n";
	260	forceunlink($targetfile);
	261	}
	262	}
08ad6bd5	263	}
08ad6bd5	264
131aa089 RM	265	sub run_filter {
131aa089 RM	266	my ($cmd, $src, $dest) = @_;
c366adb4 JH	267	open(my $CMD, "\|$cmd >$dest") \|\| die "Cannot fork: $!";
c366adb4 JH	268	open(my $SRC, $src) \|\| die "Cannot open $src: $!";
131aa089 RM	269	my $buf;
131aa089 RM	270	my $sz = 1024;
c366adb4 JH	271	while (my $len = sysread($SRC, $buf, $sz)) {
c366adb4 JH	272	syswrite($CMD, $buf, $len);
131aa089	273	}
c366adb4 JH	274	close $SRC;
c366adb4 JH	275	close $CMD or die "Filter command '$cmd' failed for $src";
131aa089 RM	276	}
131aa089 RM	277
08ad6bd5	278	sub pm_to_blib {
131aa089	279	my($fromto,$autodir,$pm_filter) = @_;
08ad6bd5	280
	281	use File::Basename qw(dirname);
	282	use File::Copy qw(copy);
	283	use File::Path qw(mkpath);
fb73857a	284	use File::Compare qw(compare);
08ad6bd5	285	use AutoSplit;
f1387719	286	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	287	# require $my_req; # Hairy, but for the first
08ad6bd5	288
68dc0745	289	if (!ref($fromto) && -r $fromto)
	290	{
	291	# Win32 has severe command line length limitations, but
	292	# can generate temporary files on-the-fly
	293	# so we pass name of file here - eval it to get hash
	294	open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
	295	my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
	296	eval $str;
	297	close(FROMTO);
	298	}
	299
08ad6bd5	300	mkpath($autodir,0,0755);
08ad6bd5	301	foreach (keys %$fromto) {
131aa089 RM	302	my $dest = $fromto->{$_};
	303	next if -f $dest && -M $dest < -M $_;
	304
	305	# When a pm_filter is defined, we need to pre-process the source first
	306	# to determine whether it has changed or not. Therefore, only perform
	307	# the comparison check when there's no filter to be ran.
	308	# -- RAM, 03/01/2001
	309
	310	my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;
	311
	312	if (!$need_filtering && 0 == compare($_,$dest)) {
	313	print "Skip $dest (unchanged)\n";
08ad6bd5	314	next;
08ad6bd5	315	}
131aa089 RM	316	if (-f $dest){
	317	forceunlink($dest);
	318	} else {
	319	mkpath(dirname($dest),0,0755);
	320	}
	321	if ($need_filtering) {
	322	run_filter($pm_filter, $_, $dest);
	323	print "$pm_filter <$_ >$dest\n";
08ad6bd5	324	} else {
131aa089 RM	325	copy($_,$dest);
131aa089 RM	326	print "cp $_ $dest\n";
08ad6bd5	327	}
cee7b94a	328	my($mode,$atime,$mtime) = (stat)[2,8,9];
131aa089 RM	329	utime($atime,$mtime+$Is_VMS,$dest);
	330	chmod(0444 \| ( $mode & 0111 ? 0111 : 0 ),$dest);
	331	next unless /\.pm$/;
	332	autosplit($dest,$autodir);
08ad6bd5	333	}
4b6d56d3	334	}
4b6d56d3	335
f1387719	336	package ExtUtils::Install::Warn;
	337
	338	sub new { bless {}, shift }
	339
	340	sub add {
	341	my($self,$file,$targetfile) = @_;
	342	push @{$self->{$file}}, $targetfile;
	343	}
	344
	345	sub DESTROY {
a9d83807 BC	346	unless(defined $INSTALL_ROOT) {
	347	my $self = shift;
	348	my($file,$i,$plural);
	349	foreach $file (sort keys %$self) {
	350	$plural = @{$self->{$file}} > 1 ? "s" : "";
	351	print "## Differing version$plural of $file found. You might like to\n";
	352	for (0..$#{$self->{$file}}) {
	353	print "rm ", $self->{$file}[$_], "\n";
	354	$i++;
	355	}
	356	}
	357	$plural = $i>1 ? "all those files" : "this file";
	358	print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
f1387719	359	}
f1387719	360	}
f1387719	361
4b6d56d3	362	1;
	363
	364	__END__
	365
	366	=head1 NAME
	367
	368	ExtUtils::Install - install files from here to there
	369
	370	=head1 SYNOPSIS
	371
	372	B<use ExtUtils::Install;>
	373
	374	B<install($hashref,$verbose,$nonono);>
	375
	376	B<uninstall($packlistfile,$verbose,$nonono);>
	377
08ad6bd5	378	B<pm_to_blib($hashref);>
08ad6bd5	379
4b6d56d3	380	=head1 DESCRIPTION
4b6d56d3	381
08ad6bd5	382	Both install() and uninstall() are specific to the way
4b6d56d3	383	ExtUtils::MakeMaker handles the installation and deinstallation of
	384	perl modules. They are not designed as general purpose tools.
	385
	386	install() takes three arguments. A reference to a hash, a verbose
	387	switch and a don't-really-do-it switch. The hash ref contains a
	388	mapping of directories: each key/value pair is a combination of
	389	directories to be copied. Key is a directory to copy from, value is a
	390	directory to copy to. The whole tree below the "from" directory will
	391	be copied preserving timestamps and permissions.
	392
	393	There are two keys with a special meaning in the hash: "read" and
	394	"write". After the copying is done, install will write the list of
1fef88e7 JM	395	target files to the file named by C<$hashref-E<gt>{write}>. If there is
1fef88e7 JM	396	another file named by C<$hashref-E<gt>{read}>, the contents of this file will
4b6d56d3	397	be merged into the written file. The read and the written file may be
a7665c5e	398	identical, but on AFS it is quite likely that people are installing to a
4b6d56d3	399	different directory than the one where the files later appear.
4b6d56d3	400
c3648e42 IZ	401	install_default() takes one or less arguments. If no arguments are
	402	specified, it takes $ARGV[0] as if it was specified as an argument.
	403	The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
	404	This function calls install() with the same arguments as the defaults
	405	the MakeMaker would use.
	406
de592821	407	The argument-less form is convenient for install scripts like
c3648e42 IZ	408
	409	perl -MExtUtils::Install -e install_default Tk/Canvas
	410
a7665c5e	411	Assuming this command is executed in a directory with a populated F<blib>
c3648e42 IZ	412	directory, it will proceed as if the F<blib> was build by MakeMaker on
	413	this machine. This is useful for binary distributions.
	414
4b6d56d3	415	uninstall() takes as first argument a file containing filenames to be
	416	unlinked. The second argument is a verbose switch, the third is a
	417	no-don't-really-do-it-now switch.
	418
08ad6bd5	419	pm_to_blib() takes a hashref as the first argument and copies all keys
	420	of the hash to the corresponding values efficiently. Filenames with
	421	the extension pm are autosplit. Second argument is the autosplit
131aa089 RM	422	directory. If third argument is not empty, it is taken as a filter command
	423	to be ran on each .pm file, the output of the command being what is finally
	424	copied, and the source for auto-splitting.
4b6d56d3	425
ae1d6394 JH	426	You can have an environment variable PERL_INSTALL_ROOT set which will
	427	be prepended as a directory to each installed file (and directory).
	428
08ad6bd5	429	=cut