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

package ExtUtils::Install;

use 5.00503;
use vars qw(@ISA @EXPORT $VERSION);
$VERSION = 1.32;

use Exporter;
use Carp ();
use Config qw(%Config);
@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
$Is_VMS     = $^O eq 'VMS';
$Is_MacPerl = $^O eq 'MacOS';

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;
my $Curdir = File::Spec->curdir;
my $Updir  = File::Spec->updir;


=head1 NAME

ExtUtils::Install - install files from here to there

=head1 SYNOPSIS

  use ExtUtils::Install;

  install({ 'blib/lib' => 'some/install/dir' } );

  uninstall($packlist);

  pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });


=head1 DESCRIPTION

Handles the installing and uninstalling of perl modules, scripts, man
pages, etc...

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.

=head2 Functions

=over 4

=item B<install>

    install(\%from_to);
    install(\%from_to, $verbose, $dont_execute);

Copies each directory tree of %from_to to its corresponding value
preserving timestamps and permissions.

There are two keys with a special meaning in the hash: "read" and
"write".  These contain packlist files.  After the copying is done,
install() will write the list of target files to $from_to{write}. If
$from_to{read} is given 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.

If $verbose is true, will print out each file removed.  Default is
false.

If $dont_execute is true it will only print what it was going to do
without actually doing it.  Default is false.

=cut

sub install {
    my($from_to,$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);

    my(%from_to) = %$from_to;
    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{$_}=$from_to{$_};
	delete $from_to{$_};
    }
    my($source_dir_or_file);
    foreach $source_dir_or_file (sort keys %from_to) {
	#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 $Curdir || $_ eq $Updir || $_ eq ".exists";
            my $targetdir = install_rooted_dir($from_to{$source_dir_or_file});
	    if ($nonono) {
		if (!-w $targetdir) {
		    print "mkpath($targetdir)\n" if $verbose>1;
		}
		last;
	    } else {
		if (-w $targetdir ||
		    mkpath($targetdir)) {
		    last;
		} else {
		    warn "Warning: You do not have permissions to " .
			"install into $from_to{$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();

    MOD_INSTALL: foreach my $source (sort keys %from_to) {
	#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($from_to{$source});

        my $blib_lib  = File::Spec->catdir('blib', 'lib');
        my $blib_arch = File::Spec->catdir('blib', 'arch');
	if ($source eq $blib_lib and
	    exists $from_to{$blib_arch} and
	    directory_not_empty($blib_arch)) {
	    $targetroot = install_rooted_dir($from_to{$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 ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
	    return unless -f _;
	    return if $_ eq ".exists";
	    my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
	    my $targetfile = File::Spec->catfile($targetdir, $_);
            my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
            my $sourcefile = File::Spec->catfile($sourcedir, $_);

            my $save_cwd = cwd;
            chdir $cwd;  # in case the target is relative
                         # 5.5.3's File::Find missing no_chdir option.

	    my $diff = 0;
	    if ( -f $targetfile && -s _ == $size) {
		# We have a good chance, we can skip this one
		$diff = compare($sourcefile, $targetfile);
	    } else {
		print "$sourcefile 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($sourcefile, $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) {
		inc_uninstall($sourcefile,$File::Find::dir,$verbose, 
                              $inc_uninstall ? 0 : 1);
	    }

	    # Record the full pathname.
	    $packlist->{$targetfile}++;

            # File::Find can get confused if you chdir in here.
            chdir $save_cwd;

        # File::Find seems to always be Unixy except on MacPerl :(
	}, $Is_MacPerl ? $Curdir : '.' );
	chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
    }
    if ($pack{'write'}) {
	$dir = install_rooted_dir(dirname($pack{'write'}));
	mkpath($dir,0,0755) unless $nonono;
	print "Writing $pack{'write'}\n";
	$packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
    }
}

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];
    }
}


sub forceunlink {
    chmod 0666, $_[0];
    unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
}


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;
}


=item B<install_default> I<DISCOURAGED>

    install_default();
    install_default($fullext);

Calls install() with arguments to copy a module from blib/ to the
default site installation location.

$fullext is the name of the module converted to a directory
(ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
will attempt to read it from @ARGV.

This is primarily useful for install scripts.

B<NOTE> This function is not really useful because of the hard-coded
install location with no way to control site vs core vs vendor
directories and the strange way in which the module name is given.
Consider its use discouraged.

=cut

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);
}


=item B<uninstall>

    uninstall($packlist_file);
    uninstall($packlist_file, $verbose, $dont_execute);

Removes the files listed in a $packlist_file.

If $verbose is true, will print out each file removed.  Default is
false.

If $dont_execute is true it will only print what it was going to do
without actually doing it.  Default is false.

=cut

sub uninstall {
    use ExtUtils::Packlist;
    my($fil,$verbose,$nonono) = @_;
    $verbose ||= 0;
    $nonono  ||= 0;

    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 $Curdir;
	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(
                                     File::Spec->catfile($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(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";
}


=item B<pm_to_blib>

    pm_to_blib(\%from_to, $autosplit_dir);
    pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);

Copies each key of %from_to to its corresponding value efficiently.
Filenames with the extension .pm are autosplit into the $autosplit_dir.

$filter_cmd is an optional shell command to run each .pm file through
prior to splitting and copying.  Input is the contents of the module,
output the new module contents.

You can have an environment variable PERL_INSTALL_ROOT set which will
be prepended as a directory to each installed file (and directory).

=cut

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);
    while(my($from, $to) = each %$fromto) {
	if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
            print "Skip $to (unchanged)\n";
            next;
        }

	# 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 && 
                             $from =~ /\.pm$/;

	if (!$need_filtering && 0 == compare($from,$to)) {
	    print "Skip $to (unchanged)\n";
	    next;
	}
	if (-f $to){
	    forceunlink($to);
	} else {
	    mkpath(dirname($to),0,0755);
	}
	if ($need_filtering) {
	    run_filter($pm_filter, $from, $to);
	    print "$pm_filter <$from >$to\n";
	} else {
	    copy($from,$to);
	    print "cp $from $to\n";
	}
	my($mode,$atime,$mtime) = (stat $from)[2,8,9];
	utime($atime,$mtime+$Is_VMS,$to);
	chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
	next unless $from =~ /\.pm$/;
	_autosplit($to,$autodir);
    }
}


=begin _private

=item _autosplit

From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
the file being split.  This causes problems on systems with mandatory
locking (ie. Windows).  So we wrap it and close the filehandle.

=end _private

=cut

sub _autosplit {
    my $retval = autosplit(@_);
    close *AutoSplit::IN if defined *AutoSplit::IN{IO};

    return $retval;
}


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";
    }
}

=back


=head1 ENVIRONMENT

=over 4

=item B<PERL_INSTALL_ROOT>

Will be prepended to each install path.

=back

=head1 AUTHOR

Original author lost in the mists of time.  Probably the same as Makemaker.

Currently maintained by Michael G Schwern <F<schwern@pobox.com>>

Send patches and ideas to <F<makemaker@perl.org>>.

Send bug reports via http://rt.cpan.org/.  Please send your
generated Makefile along with your report.

For more up-to-date information, see http://www.makemaker.org.


=head1 LICENSE

This program is free software; you can redistribute it and/or 
modify it under the same terms as Perl itself.

See F<http://www.perl.com/perl/misc/Artistic.html>


=cut

1;
Commit	Line	Data
4b6d56d3	1	package ExtUtils::Install;
4b6d56d3	2
57b1a898	3	use 5.00503;
57b1a898	4	use vars qw(@ISA @EXPORT $VERSION);
dedf98bc	5	$VERSION = 1.32;
f1387719	6
08ad6bd5	7	use Exporter;
08ad6bd5	8	use Carp ();
c3648e42	9	use Config qw(%Config);
4b6d56d3	10	@ISA = ('Exporter');
c3648e42	11	@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
479d2113	12	$Is_VMS = $^O eq 'VMS';
479d2113	13	$Is_MacPerl = $^O eq 'MacOS';
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;
479d2113	24	my $Curdir = File::Spec->curdir;
479d2113	25	my $Updir = File::Spec->updir;
a9d83807	26
a9d83807	27
479d2113	28	=head1 NAME
a9d83807	29
479d2113	30	ExtUtils::Install - install files from here to there
4b6d56d3	31
479d2113	32	=head1 SYNOPSIS
	33
	34	use ExtUtils::Install;
	35
	36	install({ 'blib/lib' => 'some/install/dir' } );
	37
	38	uninstall($packlist);
	39
	40	pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
	41
	42
	43	=head1 DESCRIPTION
	44
	45	Handles the installing and uninstalling of perl modules, scripts, man
	46	pages, etc...
	47
	48	Both install() and uninstall() are specific to the way
	49	ExtUtils::MakeMaker handles the installation and deinstallation of
	50	perl modules. They are not designed as general purpose tools.
	51
	52	=head2 Functions
	53
	54	=over 4
	55
	56	=item B<install>
	57
	58	install(\%from_to);
	59	install(\%from_to, $verbose, $dont_execute);
	60
	61	Copies each directory tree of %from_to to its corresponding value
	62	preserving timestamps and permissions.
	63
	64	There are two keys with a special meaning in the hash: "read" and
	65	"write". These contain packlist files. After the copying is done,
	66	install() will write the list of target files to $from_to{write}. If
	67	$from_to{read} is given the contents of this file will be merged into
	68	the written file. The read and the written file may be identical, but
	69	on AFS it is quite likely that people are installing to a different
	70	directory than the one where the files later appear.
	71
	72	If $verbose is true, will print out each file removed. Default is
	73	false.
	74
	75	If $dont_execute is true it will only print what it was going to do
	76	without actually doing it. Default is false.
	77
	78	=cut
08ad6bd5	79
4b6d56d3	80	sub install {
479d2113	81	my($from_to,$verbose,$nonono,$inc_uninstall) = @_;
4b6d56d3	82	$verbose \|\|= 0;
4b6d56d3	83	$nonono \|\|= 0;
08ad6bd5	84
08ad6bd5	85	use Cwd qw(cwd);
354f3b56	86	use ExtUtils::Packlist;
08ad6bd5	87	use File::Basename qw(dirname);
	88	use File::Copy qw(copy);
	89	use File::Find qw(find);
	90	use File::Path qw(mkpath);
fb73857a	91	use File::Compare qw(compare);
08ad6bd5	92
479d2113	93	my(%from_to) = %$from_to;
354f3b56	94	my(%pack, $dir, $warn_permissions);
354f3b56	95	my($packlist) = ExtUtils::Packlist->new();
3e3baf6d	96	# -w doesn't work reliably on FAT dirs
3e3baf6d	97	$warn_permissions++ if $^O eq 'MSWin32';
354f3b56	98	local(*DIR);
4b6d56d3	99	for (qw/read write/) {
479d2113	100	$pack{$_}=$from_to{$_};
479d2113	101	delete $from_to{$_};
4b6d56d3	102	}
08ad6bd5	103	my($source_dir_or_file);
479d2113	104	foreach $source_dir_or_file (sort keys %from_to) {
4b6d56d3	105	#Check if there are files, and if yes, look if the corresponding
4b6d56d3	106	#target directory is writable for us
08ad6bd5	107	opendir DIR, $source_dir_or_file or next;
f1387719	108	for (readdir DIR) {
479d2113	109	next if $_ eq $Curdir \|\| $_ eq $Updir \|\| $_ eq ".exists";
479d2113	110	my $targetdir = install_rooted_dir($from_to{$source_dir_or_file});
ab00ffcd	111	if ($nonono) {
	112	if (!-w $targetdir) {
	113	print "mkpath($targetdir)\n" if $verbose>1;
	114	}
4b6d56d3	115	last;
4b6d56d3	116	} else {
ab00ffcd	117	if (-w $targetdir \|\|
	118	mkpath($targetdir)) {
	119	last;
	120	} else {
	121	warn "Warning: You do not have permissions to " .
	122	"install into $from_to{$source_dir_or_file}"
	123	unless $warn_permissions++;
	124	}
4b6d56d3	125	}
	126	}
	127	closedir DIR;
	128	}
a9d83807	129	my $tmpfile = install_rooted_file($pack{"read"});
a9d83807	130	$packlist->read($tmpfile) if (-f $tmpfile);
4b6d56d3	131	my $cwd = cwd();
4b6d56d3	132
479d2113	133	MOD_INSTALL: foreach my $source (sort keys %from_to) {
4b6d56d3	134	#copy the tree to the target directory without altering
	135	#timestamp and permission and remember for the .packlist
	136	#file. The packlist file contains the absolute paths of the
	137	#install locations. AFS users may call this a bug. We'll have
	138	#to reconsider how to add the means to satisfy AFS users also.
456e5c25	139
	140	#October 1997: we want to install .pm files into archlib if
	141	#there are any files in arch. So we depend on having ./blib/arch
	142	#hardcoded here.
a9d83807	143
479d2113	144	my $targetroot = install_rooted_dir($from_to{$source});
a9d83807	145
479d2113	146	my $blib_lib = File::Spec->catdir('blib', 'lib');
	147	my $blib_arch = File::Spec->catdir('blib', 'arch');
	148	if ($source eq $blib_lib and
	149	exists $from_to{$blib_arch} and
	150	directory_not_empty($blib_arch)) {
	151	$targetroot = install_rooted_dir($from_to{$blib_arch});
	152	print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
456e5c25	153	}
479d2113	154
479d2113	155	chdir $source or next;
4b6d56d3	156	find(sub {
479d2113	157	my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
4b6d56d3	158	return unless -f _;
4b6d56d3	159	return if $_ eq ".exists";
3ac85e8f	160	my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
3ac85e8f	161	my $targetfile = File::Spec->catfile($targetdir, $_);
479d2113	162	my $sourcedir = File::Spec->catdir($source, $File::Find::dir);
	163	my $sourcefile = File::Spec->catfile($sourcedir, $_);
	164
	165	my $save_cwd = cwd;
	166	chdir $cwd; # in case the target is relative
	167	# 5.5.3's File::Find missing no_chdir option.
4b6d56d3	168
f1387719	169	my $diff = 0;
4b6d56d3	170	if ( -f $targetfile && -s _ == $size) {
4b6d56d3	171	# We have a good chance, we can skip this one
479d2113	172	$diff = compare($sourcefile, $targetfile);
4b6d56d3	173	} else {
479d2113	174	print "$sourcefile differs\n" if $verbose>1;
4b6d56d3	175	$diff++;
	176	}
	177
	178	if ($diff){
08ad6bd5	179	if (-f $targetfile){
f1387719	180	forceunlink($targetfile) unless $nonono;
08ad6bd5	181	} else {
	182	mkpath($targetdir,0,0755) unless $nonono;
	183	print "mkpath($targetdir,0,0755)\n" if $verbose>1;
	184	}
479d2113	185	copy($sourcefile, $targetfile) unless $nonono;
f1387719	186	print "Installing $targetfile\n";
08ad6bd5	187	utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
4b6d56d3	188	print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
f1387719	189	$mode = 0444 \| ( $mode & 0111 ? 0111 : 0 );
4b6d56d3	190	chmod $mode, $targetfile;
	191	print "chmod($mode, $targetfile)\n" if $verbose>1;
	192	} else {
f1387719	193	print "Skipping $targetfile (unchanged)\n" if $verbose;
f1387719	194	}
479d2113	195
	196	if (defined $inc_uninstall) {
	197	inc_uninstall($sourcefile,$File::Find::dir,$verbose,
	198	$inc_uninstall ? 0 : 1);
4b6d56d3	199	}
479d2113	200
8c05f1d0	201	# Record the full pathname.
007a26ab	202	$packlist->{$targetfile}++;
4b6d56d3	203
479d2113	204	# File::Find can get confused if you chdir in here.
	205	chdir $save_cwd;
	206
	207	# File::Find seems to always be Unixy except on MacPerl :(
	208	}, $Is_MacPerl ? $Curdir : '.' );
08ad6bd5	209	chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
4b6d56d3	210	}
4b6d56d3	211	if ($pack{'write'}) {
a9d83807	212	$dir = install_rooted_dir(dirname($pack{'write'}));
ab00ffcd	213	mkpath($dir,0,0755) unless $nonono;
4b6d56d3	214	print "Writing $pack{'write'}\n";
ab00ffcd	215	$packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
4b6d56d3	216	}
	217	}
	218
479d2113	219	sub install_rooted_file {
	220	if (defined $INSTALL_ROOT) {
	221	File::Spec->catfile($INSTALL_ROOT, $_[0]);
	222	} else {
	223	$_[0];
	224	}
	225	}
	226
	227
	228	sub install_rooted_dir {
	229	if (defined $INSTALL_ROOT) {
	230	File::Spec->catdir($INSTALL_ROOT, $_[0]);
	231	} else {
	232	$_[0];
	233	}
	234	}
	235
	236
	237	sub forceunlink {
	238	chmod 0666, $_[0];
	239	unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
	240	}
	241
	242
456e5c25	243	sub directory_not_empty ($) {
	244	my($dir) = @_;
	245	my $files = 0;
	246	find(sub {
	247	return if $_ eq ".exists";
	248	if (-f) {
	249	$File::Find::prune++;
	250	$files = 1;
	251	}
	252	}, $dir);
	253	return $files;
	254	}
	255
479d2113	256
	257	=item B<install_default> I<DISCOURAGED>
	258
	259	install_default();
	260	install_default($fullext);
	261
	262	Calls install() with arguments to copy a module from blib/ to the
	263	default site installation location.
	264
	265	$fullext is the name of the module converted to a directory
	266	(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it
	267	will attempt to read it from @ARGV.
	268
	269	This is primarily useful for install scripts.
	270
	271	B<NOTE> This function is not really useful because of the hard-coded
	272	install location with no way to control site vs core vs vendor
	273	directories and the strange way in which the module name is given.
	274	Consider its use discouraged.
	275
	276	=cut
	277
c3648e42	278	sub install_default {
	279	@_ < 2 or die "install_default should be called with 0 or 1 argument";
	280	my $FULLEXT = @_ ? shift : $ARGV[0];
	281	defined $FULLEXT or die "Do not know to where to write install log";
5de3f0da	282	my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
	283	my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
	284	my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
	285	my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
	286	my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
	287	my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
c3648e42	288	install({
	289	read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
	290	write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
456e5c25	291	$INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
	292	$Config{installsitearch} :
	293	$Config{installsitelib},
c3648e42	294	$INST_ARCHLIB => $Config{installsitearch},
	295	$INST_BIN => $Config{installbin} ,
	296	$INST_SCRIPT => $Config{installscript},
	297	$INST_MAN1DIR => $Config{installman1dir},
	298	$INST_MAN3DIR => $Config{installman3dir},
	299	},1,0,0);
	300	}
	301
479d2113	302
	303	=item B<uninstall>
	304
	305	uninstall($packlist_file);
	306	uninstall($packlist_file, $verbose, $dont_execute);
	307
	308	Removes the files listed in a $packlist_file.
	309
	310	If $verbose is true, will print out each file removed. Default is
	311	false.
	312
	313	If $dont_execute is true it will only print what it was going to do
	314	without actually doing it. Default is false.
	315
	316	=cut
	317
4b6d56d3	318	sub uninstall {
354f3b56	319	use ExtUtils::Packlist;
4b6d56d3	320	my($fil,$verbose,$nonono) = @_;
479d2113	321	$verbose \|\|= 0;
	322	$nonono \|\|= 0;
	323
4b6d56d3	324	die "no packlist file found: $fil" unless -f $fil;
f1387719	325	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	326	# require $my_req; # Hairy, but for the first
354f3b56	327	my ($packlist) = ExtUtils::Packlist->new($fil);
354f3b56	328	foreach (sort(keys(%$packlist))) {
4b6d56d3	329	chomp;
4b6d56d3	330	print "unlink $_\n" if $verbose;
f1387719	331	forceunlink($_) unless $nonono;
4b6d56d3	332	}
4b6d56d3	333	print "unlink $fil\n" if $verbose;
f1387719	334	forceunlink($fil) unless $nonono;
	335	}
	336
	337	sub inc_uninstall {
	338	my($file,$libdir,$verbose,$nonono) = @_;
	339	my($dir);
f1387719	340	my %seen_dir = ();
456e5c25	341	foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
	342	privlibexp
	343	sitearchexp
	344	sitelibexp)}) {
479d2113	345	next if $dir eq $Curdir;
f1387719	346	next if $seen_dir{$dir}++;
3ac85e8f	347	my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
f1387719	348	next unless -f $targetfile;
	349
	350	# The reason why we compare file's contents is, that we cannot
	351	# know, which is the file we just installed (AFS). So we leave
	352	# an identical file in place
	353	my $diff = 0;
	354	if ( -f $targetfile && -s _ == -s $file) {
	355	# We have a good chance, we can skip this one
fb73857a	356	$diff = compare($file,$targetfile);
f1387719	357	} else {
	358	print "#$file and $targetfile differ\n" if $verbose>1;
	359	$diff++;
	360	}
	361
	362	next unless $diff;
	363	if ($nonono) {
	364	if ($verbose) {
	365	$Inc_uninstall_warn_handler \|\|= new ExtUtils::Install::Warn;
4f44ac69	366	$libdir =~ s\|^\./\|\|s ; # That's just cosmetics, no need to port. It looks prettier.
479d2113	367	$Inc_uninstall_warn_handler->add(
	368	File::Spec->catfile($libdir, $file),
	369	$targetfile
	370	);
f1387719	371	}
	372	# if not verbose, we just say nothing
	373	} else {
	374	print "Unlinking $targetfile (shadowing?)\n";
	375	forceunlink($targetfile);
	376	}
	377	}
08ad6bd5	378	}
08ad6bd5	379
131aa089	380	sub run_filter {
131aa089	381	my ($cmd, $src, $dest) = @_;
57b1a898	382	open(CMD, "\|$cmd >$dest") \|\| die "Cannot fork: $!";
57b1a898	383	open(SRC, $src) \|\| die "Cannot open $src: $!";
131aa089	384	my $buf;
131aa089	385	my $sz = 1024;
57b1a898	386	while (my $len = sysread(SRC, $buf, $sz)) {
57b1a898	387	syswrite(CMD, $buf, $len);
131aa089	388	}
57b1a898	389	close SRC;
57b1a898	390	close CMD or die "Filter command '$cmd' failed for $src";
131aa089	391	}
131aa089	392
479d2113	393
	394	=item B<pm_to_blib>
	395
	396	pm_to_blib(\%from_to, $autosplit_dir);
	397	pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
	398
	399	Copies each key of %from_to to its corresponding value efficiently.
	400	Filenames with the extension .pm are autosplit into the $autosplit_dir.
	401
	402	$filter_cmd is an optional shell command to run each .pm file through
	403	prior to splitting and copying. Input is the contents of the module,
	404	output the new module contents.
	405
	406	You can have an environment variable PERL_INSTALL_ROOT set which will
	407	be prepended as a directory to each installed file (and directory).
	408
	409	=cut
	410
08ad6bd5	411	sub pm_to_blib {
131aa089	412	my($fromto,$autodir,$pm_filter) = @_;
08ad6bd5	413
	414	use File::Basename qw(dirname);
	415	use File::Copy qw(copy);
	416	use File::Path qw(mkpath);
fb73857a	417	use File::Compare qw(compare);
08ad6bd5	418	use AutoSplit;
f1387719	419	# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
f1387719	420	# require $my_req; # Hairy, but for the first
08ad6bd5	421
68dc0745	422	if (!ref($fromto) && -r $fromto)
	423	{
	424	# Win32 has severe command line length limitations, but
	425	# can generate temporary files on-the-fly
	426	# so we pass name of file here - eval it to get hash
	427	open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
	428	my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
	429	eval $str;
	430	close(FROMTO);
	431	}
	432
08ad6bd5	433	mkpath($autodir,0,0755);
479d2113	434	while(my($from, $to) = each %$fromto) {
dedf98bc	435	if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
	436	print "Skip $to (unchanged)\n";
	437	next;
	438	}
131aa089	439
	440	# When a pm_filter is defined, we need to pre-process the source first
	441	# to determine whether it has changed or not. Therefore, only perform
	442	# the comparison check when there's no filter to be ran.
	443	# -- RAM, 03/01/2001
	444
479d2113	445	my $need_filtering = defined $pm_filter && length $pm_filter &&
479d2113	446	$from =~ /\.pm$/;
131aa089	447
479d2113	448	if (!$need_filtering && 0 == compare($from,$to)) {
479d2113	449	print "Skip $to (unchanged)\n";
08ad6bd5	450	next;
08ad6bd5	451	}
479d2113	452	if (-f $to){
479d2113	453	forceunlink($to);
131aa089	454	} else {
479d2113	455	mkpath(dirname($to),0,0755);
131aa089	456	}
131aa089	457	if ($need_filtering) {
479d2113	458	run_filter($pm_filter, $from, $to);
479d2113	459	print "$pm_filter <$from >$to\n";
08ad6bd5	460	} else {
479d2113	461	copy($from,$to);
479d2113	462	print "cp $from $to\n";
08ad6bd5	463	}
479d2113	464	my($mode,$atime,$mtime) = (stat $from)[2,8,9];
	465	utime($atime,$mtime+$Is_VMS,$to);
	466	chmod(0444 \| ( $mode & 0111 ? 0111 : 0 ),$to);
	467	next unless $from =~ /\.pm$/;
	468	_autosplit($to,$autodir);
08ad6bd5	469	}
4b6d56d3	470	}
4b6d56d3	471
479d2113	472
	473	=begin _private
	474
	475	=item _autosplit
	476
	477	From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
	478	the file being split. This causes problems on systems with mandatory
	479	locking (ie. Windows). So we wrap it and close the filehandle.
	480
	481	=end _private
	482
	483	=cut
	484
	485	sub _autosplit {
	486	my $retval = autosplit(@_);
	487	close AutoSplit::IN if defined AutoSplit::IN{IO};
	488
	489	return $retval;
	490	}
	491
	492
f1387719	493	package ExtUtils::Install::Warn;
	494
	495	sub new { bless {}, shift }
	496
	497	sub add {
	498	my($self,$file,$targetfile) = @_;
	499	push @{$self->{$file}}, $targetfile;
	500	}
	501
	502	sub DESTROY {
479d2113	503	unless(defined $INSTALL_ROOT) {
	504	my $self = shift;
	505	my($file,$i,$plural);
	506	foreach $file (sort keys %$self) {
	507	$plural = @{$self->{$file}} > 1 ? "s" : "";
	508	print "## Differing version$plural of $file found. You might like to\n";
	509	for (0..$#{$self->{$file}}) {
	510	print "rm ", $self->{$file}[$_], "\n";
	511	$i++;
	512	}
	513	}
	514	$plural = $i>1 ? "all those files" : "this file";
	515	print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
	516	}
f1387719	517	}
f1387719	518
479d2113	519	=back
4b6d56d3	520
4b6d56d3	521
479d2113	522	=head1 ENVIRONMENT
4b6d56d3	523
479d2113	524	=over 4
4b6d56d3	525
479d2113	526	=item B<PERL_INSTALL_ROOT>
4b6d56d3	527
479d2113	528	Will be prepended to each install path.
4b6d56d3	529
479d2113	530	=back
4b6d56d3	531
479d2113	532	=head1 AUTHOR
4b6d56d3	533
479d2113	534	Original author lost in the mists of time. Probably the same as Makemaker.
08ad6bd5	535
479d2113	536	Currently maintained by Michael G Schwern <F<schwern@pobox.com>>
4b6d56d3	537
479d2113	538	Send patches and ideas to <F<makemaker@perl.org>>.
4b6d56d3	539
479d2113	540	Send bug reports via http://rt.cpan.org/. Please send your
479d2113	541	generated Makefile along with your report.
4b6d56d3	542
479d2113	543	For more up-to-date information, see http://www.makemaker.org.
	544
	545
	546	=head1 LICENSE
	547
	548	This program is free software; you can redistribute it and/or
	549	modify it under the same terms as Perl itself.
	550
	551	See F<http://www.perl.com/perl/misc/Artistic.html>
4b6d56d3	552
ae1d6394	553
08ad6bd5	554	=cut
479d2113	555
479d2113	556	1;