[p5sagit/p5-mst-13.2.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 $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: $!");
    }
    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 run_filter {
    my ($cmd, $src, $dest) = @_;
    local *SRC, *CMD;
    open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
    open(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
17f410f9	3	use 5.005_64;
17f410f9	4	our(@ISA, @EXPORT, $VERSION);
456e5c25	5	$VERSION = substr q$Revision: 1.28 $, 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	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	64	my(%pack, $dir, $warn_permissions);
354f3b56	65	my($packlist) = ExtUtils::Packlist->new();
3e3baf6d	66	# -w doesn't work reliably on FAT dirs
3e3baf6d	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	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	85	warn "Warning: You do not have permissions to " .
456e5c25	86	"install into $hash{$source_dir_or_file}"
cee7b94a	87	unless $warn_permissions++;
4b6d56d3	88	}
	89	}
	90	closedir DIR;
	91	}
a9d83807	92	my $tmpfile = install_rooted_file($pack{"read"});
a9d83807	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	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	107
	108	my $targetroot = install_rooted_dir($hash{$source});
	109
e8aa0dbc	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	122	my $targetdir = MY->catdir($targetroot, $File::Find::dir);
a9d83807	123	my $targetfile = MY->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	}
007a26ab	158	$packlist->{$targetfile}++;
4b6d56d3	159
4b6d56d3	160	}, ".");
08ad6bd5	161	chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
4b6d56d3	162	}
4b6d56d3	163	if ($pack{'write'}) {
a9d83807	164	$dir = install_rooted_dir(dirname($pack{'write'}));
4b6d56d3	165	mkpath($dir,0,0755);
4b6d56d3	166	print "Writing $pack{'write'}\n";
a9d83807	167	$packlist->write(install_rooted_file($pack{'write'}));
4b6d56d3	168	}
	169	}
	170
456e5c25	171	sub directory_not_empty ($) {
	172	my($dir) = @_;
	173	my $files = 0;
	174	find(sub {
	175	return if $_ eq ".exists";
	176	if (-f) {
	177	$File::Find::prune++;
	178	$files = 1;
	179	}
	180	}, $dir);
	181	return $files;
	182	}
	183
c3648e42	184	sub install_default {
	185	@_ < 2 or die "install_default should be called with 0 or 1 argument";
	186	my $FULLEXT = @_ ? shift : $ARGV[0];
	187	defined $FULLEXT or die "Do not know to where to write install log";
	188	my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
	189	my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
	190	my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
	191	my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
	192	my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
	193	my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
	194	install({
	195	read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
	196	write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
456e5c25	197	$INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
	198	$Config{installsitearch} :
	199	$Config{installsitelib},
c3648e42	200	$INST_ARCHLIB => $Config{installsitearch},
	201	$INST_BIN => $Config{installbin} ,
	202	$INST_SCRIPT => $Config{installscript},
	203	$INST_MAN1DIR => $Config{installman1dir},
	204	$INST_MAN3DIR => $Config{installman3dir},
	205	},1,0,0);
	206	}
	207
4b6d56d3	208	sub uninstall {
354f3b56	209	use ExtUtils::Packlist;
4b6d56d3	210	my($fil,$verbose,$nonono) = @_;
4b6d56d3	211	die "no packlist file found: $fil" unless -f $fil;
f1387719	212	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	213	# require $my_req; # Hairy, but for the first
354f3b56	214	my ($packlist) = ExtUtils::Packlist->new($fil);
354f3b56	215	foreach (sort(keys(%$packlist))) {
4b6d56d3	216	chomp;
4b6d56d3	217	print "unlink $_\n" if $verbose;
f1387719	218	forceunlink($_) unless $nonono;
4b6d56d3	219	}
4b6d56d3	220	print "unlink $fil\n" if $verbose;
f1387719	221	forceunlink($fil) unless $nonono;
	222	}
	223
	224	sub inc_uninstall {
	225	my($file,$libdir,$verbose,$nonono) = @_;
	226	my($dir);
f1387719	227	my %seen_dir = ();
456e5c25	228	foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
	229	privlibexp
	230	sitearchexp
	231	sitelibexp)}) {
f1387719	232	next if $dir eq ".";
f1387719	233	next if $seen_dir{$dir}++;
456e5c25	234	my($targetfile) = MY->catfile($dir,$libdir,$file);
f1387719	235	next unless -f $targetfile;
	236
	237	# The reason why we compare file's contents is, that we cannot
	238	# know, which is the file we just installed (AFS). So we leave
	239	# an identical file in place
	240	my $diff = 0;
	241	if ( -f $targetfile && -s _ == -s $file) {
	242	# We have a good chance, we can skip this one
fb73857a	243	$diff = compare($file,$targetfile);
f1387719	244	} else {
	245	print "#$file and $targetfile differ\n" if $verbose>1;
	246	$diff++;
	247	}
	248
	249	next unless $diff;
	250	if ($nonono) {
	251	if ($verbose) {
	252	$Inc_uninstall_warn_handler \|\|= new ExtUtils::Install::Warn;
4f44ac69	253	$libdir =~ s\|^\./\|\|s ; # That's just cosmetics, no need to port. It looks prettier.
f1387719	254	$Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
	255	}
	256	# if not verbose, we just say nothing
	257	} else {
	258	print "Unlinking $targetfile (shadowing?)\n";
	259	forceunlink($targetfile);
	260	}
	261	}
08ad6bd5	262	}
08ad6bd5	263
131aa089	264	sub run_filter {
	265	my ($cmd, $src, $dest) = @_;
	266	local SRC, CMD;
	267	open(CMD, "\|$cmd >$dest") \|\| die "Cannot fork: $!";
	268	open(SRC, $src) \|\| die "Cannot open $src: $!";
	269	my $buf;
	270	my $sz = 1024;
	271	while (my $len = sysread(SRC, $buf, $sz)) {
	272	syswrite(CMD, $buf, $len);
	273	}
	274	close SRC;
	275	close CMD or die "Filter command '$cmd' failed for $src";
	276	}
	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	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	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	325	copy($_,$dest);
131aa089	326	print "cp $_ $dest\n";
08ad6bd5	327	}
cee7b94a	328	my($mode,$atime,$mtime) = (stat)[2,8,9];
131aa089	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	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	395	target files to the file named by C<$hashref-E<gt>{write}>. If there is
1fef88e7	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	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	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	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	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	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