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

package ExtUtils::Install;

$VERSION = substr q$Revision: 1.28 $, 10;
# $Date: 1998/01/25 07:08:24 $

use Exporter;
use Carp ();
use Config qw(%Config);
use vars qw(@ISA @EXPORT $VERSION);
@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;

#use vars qw( @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::MakeMaker; # to implement a MY class
    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);

    my(%hash) = %$hash;
    my(%pack, %write, $dir, $warn_permissions);
    # -w doesn't work reliably on FAT dirs
    $warn_permissions++ if $^O eq 'MSWin32';
    local(*DIR, *P);
    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";
	    if (-w $hash{$source_dir_or_file} ||
		mkpath($hash{$source_dir_or_file})) {
		last;
	    } else {
		warn "Warning: You do not have permissions to " .
		    "install into $hash{$source_dir_or_file}"
		    unless $warn_permissions++;
	    }
	}
	closedir DIR;
    }
    if (-f $pack{"read"}) {
	open P, $pack{"read"} or Carp::croak("Couldn't read $pack{'read'}");
	# Remember what you found
	while (<P>) {
	    chomp;
	    $write{$_}++;
	}
	close P;
    }
    my $cwd = cwd();
    my $umask = umask 0 unless $Is_VMS;

    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 = $hash{$source};
	if ($source eq "./blib/lib" and
	    exists $hash{"./blib/arch"} and
	    directory_not_empty("./blib/arch")) {
	    $targetroot = $hash{"./blib/arch"};
	}
	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 = MY->catdir($targetroot,$File::Find::dir);
	    my $targetfile = MY->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
	    }
	    $write{$targetfile}++;

	}, ".");
	chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
    }
    umask $umask unless $Is_VMS;
    if ($pack{'write'}) {
	$dir = dirname($pack{'write'});
	mkpath($dir,0,0755);
	print "Writing $pack{'write'}\n";
	open P, ">$pack{'write'}" or Carp::croak("Couldn't write $pack{'write'}: $!");
	for (sort keys %write) {
	    print P "$_\n";
	}
	close P;
    }
}

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 = 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');
  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 {
    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
    local *P;
    open P, $fil or Carp::croak("uninstall: Could not read packlist " .
				"file $fil: $!");
    while (<P>) {
	chomp;
	print "unlink $_\n" if $verbose;
	forceunlink($_) unless $nonono;
    }
    print "unlink $fil\n" if $verbose;
    close P;
    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) = MY->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|^\./|| ; # 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 pm_to_blib {
    my($fromto,$autodir) = @_;

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

    my $umask = umask 0022 unless $Is_VMS;
    mkpath($autodir,0,0755);
    foreach (keys %$fromto) {
	next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
	unless (compare($_,$fromto->{$_})){
	    print "Skip $fromto->{$_} (unchanged)\n";
	    next;
	}
	if (-f $fromto->{$_}){
	    forceunlink($fromto->{$_});
	} else {
	    mkpath(dirname($fromto->{$_}),0,0755);
	}
	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$/;
	autosplit($fromto->{$_},$autodir);
    }
    umask $umask unless $Is_VMS;
}

package ExtUtils::Install::Warn;

sub new { bless {}, shift }

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

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++;
	}
    }
    $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, 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 argumement-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 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.

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