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

package ExtUtils::Install;

use 5.005_64;
our(@ISA, @EXPORT, $VERSION);
$VERSION = substr q$Revision: 1.28 $, 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) {
	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;

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";
		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  = MY->catdir($targetroot, $File::Find::dir);
	    my $origfile   = $_;
	    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->{$origfile}++;

	}, ".");
	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 = 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;
    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|^\./||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);
     }

    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\z/;
	autosplit($fromto->{$_},$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.

=cut
Commit	Line	Data
4b6d56d3	1	package ExtUtils::Install;
4b6d56d3	2
17f410f9 GS	3	use 5.005_64;
17f410f9 GS	4	our(@ISA, @EXPORT, $VERSION);
456e5c25 A	5	$VERSION = substr q$Revision: 1.28 $, 10;
456e5c25 A	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) {
	27	MY->catfile($INSTALL_ROOT, $_[0]);
	28	} else {
	29	$_[0];
	30	}
	31	}
	32
	33	sub install_rooted_dir {
	34	if (defined $INSTALL_ROOT) {
	35	MY->catdir($INSTALL_ROOT, $_[0]);
	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
	54	use Cwd qw(cwd);
	55	use ExtUtils::MakeMaker; # to implement a MY class
354f3b56	56	use ExtUtils::Packlist;
08ad6bd5	57	use File::Basename qw(dirname);
	58	use File::Copy qw(copy);
	59	use File::Find qw(find);
	60	use File::Path qw(mkpath);
fb73857a	61	use File::Compare qw(compare);
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";
a9d83807 BC	122	my $targetdir = MY->catdir($targetroot, $File::Find::dir);
	123	my $origfile = $_;
	124	my $targetfile = MY->catfile($targetdir, $_);
4b6d56d3	125
f1387719	126	my $diff = 0;
4b6d56d3	127	if ( -f $targetfile && -s _ == $size) {
4b6d56d3	128	# We have a good chance, we can skip this one
fb73857a	129	$diff = compare($_,$targetfile);
4b6d56d3	130	} else {
	131	print "$_ differs\n" if $verbose>1;
	132	$diff++;
	133	}
	134
	135	if ($diff){
08ad6bd5	136	if (-f $targetfile){
f1387719	137	forceunlink($targetfile) unless $nonono;
08ad6bd5	138	} else {
	139	mkpath($targetdir,0,0755) unless $nonono;
	140	print "mkpath($targetdir,0,0755)\n" if $verbose>1;
	141	}
4b6d56d3	142	copy($_,$targetfile) unless $nonono;
f1387719	143	print "Installing $targetfile\n";
08ad6bd5	144	utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
4b6d56d3	145	print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
f1387719	146	$mode = 0444 \| ( $mode & 0111 ? 0111 : 0 );
4b6d56d3	147	chmod $mode, $targetfile;
	148	print "chmod($mode, $targetfile)\n" if $verbose>1;
	149	} else {
f1387719	150	print "Skipping $targetfile (unchanged)\n" if $verbose;
	151	}
	152
	153	if (! defined $inc_uninstall) { # it's called
	154	} elsif ($inc_uninstall == 0){
	155	inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
	156	} else {
	157	inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
4b6d56d3	158	}
a9d83807	159	$packlist->{$origfile}++;
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";
	189	my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
	190	my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
	191	my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
	192	my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
	193	my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
	194	my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
	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}++;
456e5c25	235	my($targetfile) = MY->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	}
	264
	265	sub pm_to_blib {
	266	my($fromto,$autodir) = @_;
	267
	268	use File::Basename qw(dirname);
	269	use File::Copy qw(copy);
	270	use File::Path qw(mkpath);
fb73857a	271	use File::Compare qw(compare);
08ad6bd5	272	use AutoSplit;
f1387719	273	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	274	# require $my_req; # Hairy, but for the first
08ad6bd5	275
68dc0745	276	if (!ref($fromto) && -r $fromto)
	277	{
	278	# Win32 has severe command line length limitations, but
	279	# can generate temporary files on-the-fly
	280	# so we pass name of file here - eval it to get hash
	281	open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
	282	my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
	283	eval $str;
	284	close(FROMTO);
	285	}
	286
08ad6bd5	287	mkpath($autodir,0,0755);
	288	foreach (keys %$fromto) {
	289	next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
fb73857a	290	unless (compare($_,$fromto->{$_})){
08ad6bd5	291	print "Skip $fromto->{$_} (unchanged)\n";
	292	next;
	293	}
	294	if (-f $fromto->{$_}){
f1387719	295	forceunlink($fromto->{$_});
08ad6bd5	296	} else {
	297	mkpath(dirname($fromto->{$_}),0,0755);
	298	}
	299	copy($_,$fromto->{$_});
cee7b94a	300	my($mode,$atime,$mtime) = (stat)[2,8,9];
	301	utime($atime,$mtime+$Is_VMS,$fromto->{$_});
	302	chmod(0444 \| ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
08ad6bd5	303	print "cp $_ $fromto->{$_}\n";
4f44ac69	304	next unless /\.pm\z/;
08ad6bd5	305	autosplit($fromto->{$_},$autodir);
08ad6bd5	306	}
4b6d56d3	307	}
4b6d56d3	308
f1387719	309	package ExtUtils::Install::Warn;
	310
	311	sub new { bless {}, shift }
	312
	313	sub add {
	314	my($self,$file,$targetfile) = @_;
	315	push @{$self->{$file}}, $targetfile;
	316	}
	317
	318	sub DESTROY {
a9d83807 BC	319	unless(defined $INSTALL_ROOT) {
	320	my $self = shift;
	321	my($file,$i,$plural);
	322	foreach $file (sort keys %$self) {
	323	$plural = @{$self->{$file}} > 1 ? "s" : "";
	324	print "## Differing version$plural of $file found. You might like to\n";
	325	for (0..$#{$self->{$file}}) {
	326	print "rm ", $self->{$file}[$_], "\n";
	327	$i++;
	328	}
	329	}
	330	$plural = $i>1 ? "all those files" : "this file";
	331	print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
f1387719	332	}
f1387719	333	}
f1387719	334
4b6d56d3	335	1;
	336
	337	__END__
	338
	339	=head1 NAME
	340
	341	ExtUtils::Install - install files from here to there
	342
	343	=head1 SYNOPSIS
	344
	345	B<use ExtUtils::Install;>
	346
	347	B<install($hashref,$verbose,$nonono);>
	348
	349	B<uninstall($packlistfile,$verbose,$nonono);>
	350
08ad6bd5	351	B<pm_to_blib($hashref);>
08ad6bd5	352
4b6d56d3	353	=head1 DESCRIPTION
4b6d56d3	354
08ad6bd5	355	Both install() and uninstall() are specific to the way
4b6d56d3	356	ExtUtils::MakeMaker handles the installation and deinstallation of
	357	perl modules. They are not designed as general purpose tools.
	358
	359	install() takes three arguments. A reference to a hash, a verbose
	360	switch and a don't-really-do-it switch. The hash ref contains a
	361	mapping of directories: each key/value pair is a combination of
	362	directories to be copied. Key is a directory to copy from, value is a
	363	directory to copy to. The whole tree below the "from" directory will
	364	be copied preserving timestamps and permissions.
	365
	366	There are two keys with a special meaning in the hash: "read" and
	367	"write". After the copying is done, install will write the list of
1fef88e7 JM	368	target files to the file named by C<$hashref-E<gt>{write}>. If there is
1fef88e7 JM	369	another file named by C<$hashref-E<gt>{read}>, the contents of this file will
4b6d56d3	370	be merged into the written file. The read and the written file may be
a7665c5e	371	identical, but on AFS it is quite likely that people are installing to a
4b6d56d3	372	different directory than the one where the files later appear.
4b6d56d3	373
c3648e42 IZ	374	install_default() takes one or less arguments. If no arguments are
	375	specified, it takes $ARGV[0] as if it was specified as an argument.
	376	The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
	377	This function calls install() with the same arguments as the defaults
	378	the MakeMaker would use.
	379
de592821	380	The argument-less form is convenient for install scripts like
c3648e42 IZ	381
	382	perl -MExtUtils::Install -e install_default Tk/Canvas
	383
a7665c5e	384	Assuming this command is executed in a directory with a populated F<blib>
c3648e42 IZ	385	directory, it will proceed as if the F<blib> was build by MakeMaker on
	386	this machine. This is useful for binary distributions.
	387
4b6d56d3	388	uninstall() takes as first argument a file containing filenames to be
	389	unlinked. The second argument is a verbose switch, the third is a
	390	no-don't-really-do-it-now switch.
	391
08ad6bd5	392	pm_to_blib() takes a hashref as the first argument and copies all keys
	393	of the hash to the corresponding values efficiently. Filenames with
	394	the extension pm are autosplit. Second argument is the autosplit
	395	directory.
4b6d56d3	396
08ad6bd5	397	=cut