[p5sagit/p5-mst-13.2.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 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);

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