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 $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, $uninstall_shadows);

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.  This is "make install VERBINST=1"

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

If $uninstall_shadows is true any differing versions throughout @INC
will be uninstalled.  This is "make install UNINST=1"

=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});
            mkpath($targetdir) unless $nonono;
            if (!$nonono && !-w $targetdir) {
                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 _;

            my $origfile = $_;
            return if $origfile eq ".exists";
            my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
            my $targetfile = File::Spec->catfile($targetdir, $origfile);
            my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
            my $sourcefile = File::Spec->catfile($sourcedir, $origfile);

            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($filepath,$libdir,$verbose,$nonono) = @_;
    my($dir);
    my $file = (File::Spec->splitpath($filepath))[2];
    my %seen_dir = ();

    my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} 
      ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';

    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 $filepath) {
            # We have a good chance, we can skip this one
            $diff = compare($filepath,$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) = @_;
    local(*CMD, *SRC);
    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;
Revision:	1.1
Committed:	Thu Jun 30 14:27:10 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package ExtUtils::Install;
2
3			use 5.00503;
4			use vars qw(@ISA @EXPORT $VERSION);
5			$VERSION = 1.32;
6
7			use Exporter;
8			use Carp ();
9			use Config qw(%Config);
10			@ISA = ('Exporter');
11			@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
12			$Is_VMS = $^O eq 'VMS';
13			$Is_MacPerl = $^O eq 'MacOS';
14
15			my $Inc_uninstall_warn_handler;
16
17			# install relative to here
18
19			my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
20
21			use File::Spec;
22			my $Curdir = File::Spec->curdir;
23			my $Updir = File::Spec->updir;
24
25
26			=head1 NAME
27
28			ExtUtils::Install - install files from here to there
29
30			=head1 SYNOPSIS
31
32			use ExtUtils::Install;
33
34			install({ 'blib/lib' => 'some/install/dir' } );
35
36			uninstall($packlist);
37
38			pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
39
40
41			=head1 DESCRIPTION
42
43			Handles the installing and uninstalling of perl modules, scripts, man
44			pages, etc...
45
46			Both install() and uninstall() are specific to the way
47			ExtUtils::MakeMaker handles the installation and deinstallation of
48			perl modules. They are not designed as general purpose tools.
49
50			=head2 Functions
51
52			=over 4
53
54			=item B<install>
55
56			install(\%from_to);
57			install(\%from_to, $verbose, $dont_execute, $uninstall_shadows);
58
59			Copies each directory tree of %from_to to its corresponding value
60			preserving timestamps and permissions.
61
62			There are two keys with a special meaning in the hash: "read" and
63			"write". These contain packlist files. After the copying is done,
64			install() will write the list of target files to $from_to{write}. If
65			$from_to{read} is given the contents of this file will be merged into
66			the written file. The read and the written file may be identical, but
67			on AFS it is quite likely that people are installing to a different
68			directory than the one where the files later appear.
69
70			If $verbose is true, will print out each file removed. Default is
71			false. This is "make install VERBINST=1"
72
73			If $dont_execute is true it will only print what it was going to do
74			without actually doing it. Default is false.
75
76			If $uninstall_shadows is true any differing versions throughout @INC
77			will be uninstalled. This is "make install UNINST=1"
78
79			=cut
80
81			sub install {
82			my($from_to,$verbose,$nonono,$inc_uninstall) = @_;
83			$verbose \|\|= 0;
84			$nonono \|\|= 0;
85
86			use Cwd qw(cwd);
87			use ExtUtils::Packlist;
88			use File::Basename qw(dirname);
89			use File::Copy qw(copy);
90			use File::Find qw(find);
91			use File::Path qw(mkpath);
92			use File::Compare qw(compare);
93
94			my(%from_to) = %$from_to;
95			my(%pack, $dir, $warn_permissions);
96			my($packlist) = ExtUtils::Packlist->new();
97			# -w doesn't work reliably on FAT dirs
98			$warn_permissions++ if $^O eq 'MSWin32';
99			local(*DIR);
100			for (qw/read write/) {
101			$pack{$_}=$from_to{$_};
102			delete $from_to{$_};
103			}
104			my($source_dir_or_file);
105			foreach $source_dir_or_file (sort keys %from_to) {
106			#Check if there are files, and if yes, look if the corresponding
107			#target directory is writable for us
108			opendir DIR, $source_dir_or_file or next;
109			for (readdir DIR) {
110			next if $_ eq $Curdir \|\| $_ eq $Updir \|\| $_ eq ".exists";
111			my $targetdir = install_rooted_dir($from_to{$source_dir_or_file});
112			mkpath($targetdir) unless $nonono;
113			if (!$nonono && !-w $targetdir) {
114			warn "Warning: You do not have permissions to " .
115			"install into $from_to{$source_dir_or_file}"
116			unless $warn_permissions++;
117			}
118			}
119			closedir DIR;
120			}
121			my $tmpfile = install_rooted_file($pack{"read"});
122			$packlist->read($tmpfile) if (-f $tmpfile);
123			my $cwd = cwd();
124
125			MOD_INSTALL: foreach my $source (sort keys %from_to) {
126			#copy the tree to the target directory without altering
127			#timestamp and permission and remember for the .packlist
128			#file. The packlist file contains the absolute paths of the
129			#install locations. AFS users may call this a bug. We'll have
130			#to reconsider how to add the means to satisfy AFS users also.
131
132			#October 1997: we want to install .pm files into archlib if
133			#there are any files in arch. So we depend on having ./blib/arch
134			#hardcoded here.
135
136			my $targetroot = install_rooted_dir($from_to{$source});
137
138			my $blib_lib = File::Spec->catdir('blib', 'lib');
139			my $blib_arch = File::Spec->catdir('blib', 'arch');
140			if ($source eq $blib_lib and
141			exists $from_to{$blib_arch} and
142			directory_not_empty($blib_arch)) {
143			$targetroot = install_rooted_dir($from_to{$blib_arch});
144			print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
145			}
146
147			chdir $source or next;
148			find(sub {
149			my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
150			return unless -f _;
151
152			my $origfile = $_;
153			return if $origfile eq ".exists";
154			my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
155			my $targetfile = File::Spec->catfile($targetdir, $origfile);
156			my $sourcedir = File::Spec->catdir($source, $File::Find::dir);
157			my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
158
159			my $save_cwd = cwd;
160			chdir $cwd; # in case the target is relative
161			# 5.5.3's File::Find missing no_chdir option.
162
163			my $diff = 0;
164			if ( -f $targetfile && -s _ == $size) {
165			# We have a good chance, we can skip this one
166			$diff = compare($sourcefile, $targetfile);
167			} else {
168			print "$sourcefile differs\n" if $verbose>1;
169			$diff++;
170			}
171
172			if ($diff){
173			if (-f $targetfile){
174			forceunlink($targetfile) unless $nonono;
175			} else {
176			mkpath($targetdir,0,0755) unless $nonono;
177			print "mkpath($targetdir,0,0755)\n" if $verbose>1;
178			}
179			copy($sourcefile, $targetfile) unless $nonono;
180			print "Installing $targetfile\n";
181			utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
182			print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
183			$mode = 0444 \| ( $mode & 0111 ? 0111 : 0 );
184			chmod $mode, $targetfile;
185			print "chmod($mode, $targetfile)\n" if $verbose>1;
186			} else {
187			print "Skipping $targetfile (unchanged)\n" if $verbose;
188			}
189
190			if (defined $inc_uninstall) {
191			inc_uninstall($sourcefile,$File::Find::dir,$verbose,
192			$inc_uninstall ? 0 : 1);
193			}
194
195			# Record the full pathname.
196			$packlist->{$targetfile}++;
197
198			# File::Find can get confused if you chdir in here.
199			chdir $save_cwd;
200
201			# File::Find seems to always be Unixy except on MacPerl :(
202			}, $Is_MacPerl ? $Curdir : '.' );
203			chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
204			}
205			if ($pack{'write'}) {
206			$dir = install_rooted_dir(dirname($pack{'write'}));
207			mkpath($dir,0,0755) unless $nonono;
208			print "Writing $pack{'write'}\n";
209			$packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
210			}
211			}
212
213			sub install_rooted_file {
214			if (defined $INSTALL_ROOT) {
215			File::Spec->catfile($INSTALL_ROOT, $_[0]);
216			} else {
217			$_[0];
218			}
219			}
220
221
222			sub install_rooted_dir {
223			if (defined $INSTALL_ROOT) {
224			File::Spec->catdir($INSTALL_ROOT, $_[0]);
225			} else {
226			$_[0];
227			}
228			}
229
230
231			sub forceunlink {
232			chmod 0666, $_[0];
233			unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
234			}
235
236
237			sub directory_not_empty ($) {
238			my($dir) = @_;
239			my $files = 0;
240			find(sub {
241			return if $_ eq ".exists";
242			if (-f) {
243			$File::Find::prune++;
244			$files = 1;
245			}
246			}, $dir);
247			return $files;
248			}
249
250
251			=item B<install_default> I<DISCOURAGED>
252
253			install_default();
254			install_default($fullext);
255
256			Calls install() with arguments to copy a module from blib/ to the
257			default site installation location.
258
259			$fullext is the name of the module converted to a directory
260			(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it
261			will attempt to read it from @ARGV.
262
263			This is primarily useful for install scripts.
264
265			B<NOTE> This function is not really useful because of the hard-coded
266			install location with no way to control site vs core vs vendor
267			directories and the strange way in which the module name is given.
268			Consider its use discouraged.
269
270			=cut
271
272			sub install_default {
273			@_ < 2 or die "install_default should be called with 0 or 1 argument";
274			my $FULLEXT = @_ ? shift : $ARGV[0];
275			defined $FULLEXT or die "Do not know to where to write install log";
276			my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
277			my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
278			my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
279			my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
280			my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
281			my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
282			install({
283			read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
284			write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
285			$INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
286			$Config{installsitearch} :
287			$Config{installsitelib},
288			$INST_ARCHLIB => $Config{installsitearch},
289			$INST_BIN => $Config{installbin} ,
290			$INST_SCRIPT => $Config{installscript},
291			$INST_MAN1DIR => $Config{installman1dir},
292			$INST_MAN3DIR => $Config{installman3dir},
293			},1,0,0);
294			}
295
296
297			=item B<uninstall>
298
299			uninstall($packlist_file);
300			uninstall($packlist_file, $verbose, $dont_execute);
301
302			Removes the files listed in a $packlist_file.
303
304			If $verbose is true, will print out each file removed. Default is
305			false.
306
307			If $dont_execute is true it will only print what it was going to do
308			without actually doing it. Default is false.
309
310			=cut
311
312			sub uninstall {
313			use ExtUtils::Packlist;
314			my($fil,$verbose,$nonono) = @_;
315			$verbose \|\|= 0;
316			$nonono \|\|= 0;
317
318			die "no packlist file found: $fil" unless -f $fil;
319			# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
320			# require $my_req; # Hairy, but for the first
321			my ($packlist) = ExtUtils::Packlist->new($fil);
322			foreach (sort(keys(%$packlist))) {
323			chomp;
324			print "unlink $_\n" if $verbose;
325			forceunlink($_) unless $nonono;
326			}
327			print "unlink $fil\n" if $verbose;
328			forceunlink($fil) unless $nonono;
329			}
330
331			sub inc_uninstall {
332			my($filepath,$libdir,$verbose,$nonono) = @_;
333			my($dir);
334			my $file = (File::Spec->splitpath($filepath))[2];
335			my %seen_dir = ();
336
337			my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
338			? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} \|\| '';
339
340			foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
341			privlibexp
342			sitearchexp
343			sitelibexp)}) {
344			next if $dir eq $Curdir;
345			next if $seen_dir{$dir}++;
346			my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
347			next unless -f $targetfile;
348
349			# The reason why we compare file's contents is, that we cannot
350			# know, which is the file we just installed (AFS). So we leave
351			# an identical file in place
352			my $diff = 0;
353			if ( -f $targetfile && -s _ == -s $filepath) {
354			# We have a good chance, we can skip this one
355			$diff = compare($filepath,$targetfile);
356			} else {
357			print "#$file and $targetfile differ\n" if $verbose>1;
358			$diff++;
359			}
360
361			next unless $diff;
362			if ($nonono) {
363			if ($verbose) {
364			$Inc_uninstall_warn_handler \|\|= new ExtUtils::Install::Warn;
365			$libdir =~ s\|^\./\|\|s ; # That's just cosmetics, no need to port. It looks prettier.
366			$Inc_uninstall_warn_handler->add(
367			File::Spec->catfile($libdir, $file),
368			$targetfile
369			);
370			}
371			# if not verbose, we just say nothing
372			} else {
373			print "Unlinking $targetfile (shadowing?)\n";
374			forceunlink($targetfile);
375			}
376			}
377			}
378
379			sub run_filter {
380			my ($cmd, $src, $dest) = @_;
381			local(CMD, SRC);
382			open(CMD, "\|$cmd >$dest") \|\| die "Cannot fork: $!";
383			open(SRC, $src) \|\| die "Cannot open $src: $!";
384			my $buf;
385			my $sz = 1024;
386			while (my $len = sysread(SRC, $buf, $sz)) {
387			syswrite(CMD, $buf, $len);
388			}
389			close SRC;
390			close CMD or die "Filter command '$cmd' failed for $src";
391			}
392
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
411			sub pm_to_blib {
412			my($fromto,$autodir,$pm_filter) = @_;
413
414			use File::Basename qw(dirname);
415			use File::Copy qw(copy);
416			use File::Path qw(mkpath);
417			use File::Compare qw(compare);
418			use AutoSplit;
419			# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
420			# require $my_req; # Hairy, but for the first
421
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
433			mkpath($autodir,0,0755);
434			while(my($from, $to) = each %$fromto) {
435			if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
436			print "Skip $to (unchanged)\n";
437			next;
438			}
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
445			my $need_filtering = defined $pm_filter && length $pm_filter &&
446			$from =~ /\.pm$/;
447
448			if (!$need_filtering && 0 == compare($from,$to)) {
449			print "Skip $to (unchanged)\n";
450			next;
451			}
452			if (-f $to){
453			forceunlink($to);
454			} else {
455			mkpath(dirname($to),0,0755);
456			}
457			if ($need_filtering) {
458			run_filter($pm_filter, $from, $to);
459			print "$pm_filter <$from >$to\n";
460			} else {
461			copy($from,$to);
462			print "cp $from $to\n";
463			}
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);
469			}
470			}
471
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
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 {
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			}
517			}
518
519			=back
520
521
522			=head1 ENVIRONMENT
523
524			=over 4
525
526			=item B<PERL_INSTALL_ROOT>
527
528			Will be prepended to each install path.
529
530			=back
531
532			=head1 AUTHOR
533
534			Original author lost in the mists of time. Probably the same as Makemaker.
535
536			Currently maintained by Michael G Schwern <F<schwern@pobox.com>>
537
538			Send patches and ideas to <F<makemaker@perl.org>>.
539
540			Send bug reports via http://rt.cpan.org/. Please send your
541			generated Makefile along with your report.
542
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>
552
553
554			=cut
555
556			1;