[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 $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 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);
	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	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	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	198	$INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
	199	$Config{installsitearch} :
	200	$Config{installsitelib},
c3648e42	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	215	my ($packlist) = ExtUtils::Packlist->new($fil);
354f3b56	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	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	}
08ad6bd5	264
131aa089	265	sub run_filter {
	266	my ($cmd, $src, $dest) = @_;
	267	local SRC, CMD;
	268	open(CMD, "\|$cmd >$dest") \|\| die "Cannot fork: $!";
	269	open(SRC, $src) \|\| die "Cannot open $src: $!";
	270	my $buf;
	271	my $sz = 1024;
	272	while (my $len = sysread(SRC, $buf, $sz)) {
	273	syswrite(CMD, $buf, $len);
	274	}
	275	close SRC;
	276	close CMD or die "Filter command '$cmd' failed for $src";
	277	}
	278
08ad6bd5	279	sub pm_to_blib {
131aa089	280	my($fromto,$autodir,$pm_filter) = @_;
08ad6bd5	281
	282	use File::Basename qw(dirname);
	283	use File::Copy qw(copy);
	284	use File::Path qw(mkpath);
fb73857a	285	use File::Compare qw(compare);
08ad6bd5	286	use AutoSplit;
f1387719	287	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	288	# require $my_req; # Hairy, but for the first
08ad6bd5	289
68dc0745	290	if (!ref($fromto) && -r $fromto)
	291	{
	292	# Win32 has severe command line length limitations, but
	293	# can generate temporary files on-the-fly
	294	# so we pass name of file here - eval it to get hash
	295	open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
	296	my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
	297	eval $str;
	298	close(FROMTO);
	299	}
	300
08ad6bd5	301	mkpath($autodir,0,0755);
08ad6bd5	302	foreach (keys %$fromto) {
131aa089	303	my $dest = $fromto->{$_};
	304	next if -f $dest && -M $dest < -M $_;
	305
	306	# When a pm_filter is defined, we need to pre-process the source first
	307	# to determine whether it has changed or not. Therefore, only perform
	308	# the comparison check when there's no filter to be ran.
	309	# -- RAM, 03/01/2001
	310
	311	my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;
	312
	313	if (!$need_filtering && 0 == compare($_,$dest)) {
	314	print "Skip $dest (unchanged)\n";
08ad6bd5	315	next;
08ad6bd5	316	}
131aa089	317	if (-f $dest){
	318	forceunlink($dest);
	319	} else {
	320	mkpath(dirname($dest),0,0755);
	321	}
	322	if ($need_filtering) {
	323	run_filter($pm_filter, $_, $dest);
	324	print "$pm_filter <$_ >$dest\n";
08ad6bd5	325	} else {
131aa089	326	copy($_,$dest);
131aa089	327	print "cp $_ $dest\n";
08ad6bd5	328	}
cee7b94a	329	my($mode,$atime,$mtime) = (stat)[2,8,9];
131aa089	330	utime($atime,$mtime+$Is_VMS,$dest);
	331	chmod(0444 \| ( $mode & 0111 ? 0111 : 0 ),$dest);
	332	next unless /\.pm$/;
	333	autosplit($dest,$autodir);
08ad6bd5	334	}
4b6d56d3	335	}
4b6d56d3	336
f1387719	337	package ExtUtils::Install::Warn;
	338
	339	sub new { bless {}, shift }
	340
	341	sub add {
	342	my($self,$file,$targetfile) = @_;
	343	push @{$self->{$file}}, $targetfile;
	344	}
	345
	346	sub DESTROY {
a9d83807	347	unless(defined $INSTALL_ROOT) {
	348	my $self = shift;
	349	my($file,$i,$plural);
	350	foreach $file (sort keys %$self) {
	351	$plural = @{$self->{$file}} > 1 ? "s" : "";
	352	print "## Differing version$plural of $file found. You might like to\n";
	353	for (0..$#{$self->{$file}}) {
	354	print "rm ", $self->{$file}[$_], "\n";
	355	$i++;
	356	}
	357	}
	358	$plural = $i>1 ? "all those files" : "this file";
	359	print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
f1387719	360	}
f1387719	361	}
f1387719	362
4b6d56d3	363	1;
	364
	365	__END__
	366
	367	=head1 NAME
	368
	369	ExtUtils::Install - install files from here to there
	370
	371	=head1 SYNOPSIS
	372
	373	B<use ExtUtils::Install;>
	374
	375	B<install($hashref,$verbose,$nonono);>
	376
	377	B<uninstall($packlistfile,$verbose,$nonono);>
	378
08ad6bd5	379	B<pm_to_blib($hashref);>
08ad6bd5	380
4b6d56d3	381	=head1 DESCRIPTION
4b6d56d3	382
08ad6bd5	383	Both install() and uninstall() are specific to the way
4b6d56d3	384	ExtUtils::MakeMaker handles the installation and deinstallation of
	385	perl modules. They are not designed as general purpose tools.
	386
	387	install() takes three arguments. A reference to a hash, a verbose
	388	switch and a don't-really-do-it switch. The hash ref contains a
	389	mapping of directories: each key/value pair is a combination of
	390	directories to be copied. Key is a directory to copy from, value is a
	391	directory to copy to. The whole tree below the "from" directory will
	392	be copied preserving timestamps and permissions.
	393
	394	There are two keys with a special meaning in the hash: "read" and
	395	"write". After the copying is done, install will write the list of
1fef88e7	396	target files to the file named by C<$hashref-E<gt>{write}>. If there is
1fef88e7	397	another file named by C<$hashref-E<gt>{read}>, the contents of this file will
4b6d56d3	398	be merged into the written file. The read and the written file may be
a7665c5e	399	identical, but on AFS it is quite likely that people are installing to a
4b6d56d3	400	different directory than the one where the files later appear.
4b6d56d3	401
c3648e42	402	install_default() takes one or less arguments. If no arguments are
	403	specified, it takes $ARGV[0] as if it was specified as an argument.
	404	The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
	405	This function calls install() with the same arguments as the defaults
	406	the MakeMaker would use.
	407
de592821	408	The argument-less form is convenient for install scripts like
c3648e42	409
	410	perl -MExtUtils::Install -e install_default Tk/Canvas
	411
a7665c5e	412	Assuming this command is executed in a directory with a populated F<blib>
c3648e42	413	directory, it will proceed as if the F<blib> was build by MakeMaker on
	414	this machine. This is useful for binary distributions.
	415
4b6d56d3	416	uninstall() takes as first argument a file containing filenames to be
	417	unlinked. The second argument is a verbose switch, the third is a
	418	no-don't-really-do-it-now switch.
	419
08ad6bd5	420	pm_to_blib() takes a hashref as the first argument and copies all keys
	421	of the hash to the corresponding values efficiently. Filenames with
	422	the extension pm are autosplit. Second argument is the autosplit
131aa089	423	directory. If third argument is not empty, it is taken as a filter command
	424	to be ran on each .pm file, the output of the command being what is finally
	425	copied, and the source for auto-splitting.
4b6d56d3	426
ae1d6394	427	You can have an environment variable PERL_INSTALL_ROOT set which will
	428	be prepended as a directory to each installed file (and directory).
	429
08ad6bd5	430	=cut