[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / Install.pm

package ExtUtils::Install;

use 5.006_001;
our(@ISA, @EXPORT, $VERSION);
$VERSION = substr q$Revision: 1.29 $, 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) {
	File::Spec->catfile($INSTALL_ROOT, $_[0]);
    } else {
	$_[0];
    }
}

sub install_rooted_dir {
    if (defined $INSTALL_ROOT) {
	File::Spec->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::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);
    use File::Spec;

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