Memoize tests
[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / Install.pm
CommitLineData
4b6d56d3 1package ExtUtils::Install;
2
3b825e41 3use 5.006_001;
17f410f9 4our(@ISA, @EXPORT, $VERSION);
88d01e8d 5$VERSION = substr q$Revision: 1.29 $, 10;
456e5c25 6# $Date: 1998/01/25 07:08:24 $
f1387719 7
08ad6bd5 8use Exporter;
08ad6bd5 9use Carp ();
c3648e42 10use Config qw(%Config);
4b6d56d3 11@ISA = ('Exporter');
c3648e42 12@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
08ad6bd5 13$Is_VMS = $^O eq 'VMS';
14
39e571d4 15my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
d6abf24b 16my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
f1387719 17my $Inc_uninstall_warn_handler;
18
a9d83807 19# install relative to here
20
21my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
22
23use File::Spec;
24
25sub install_rooted_file {
26 if (defined $INSTALL_ROOT) {
27 MY->catfile($INSTALL_ROOT, $_[0]);
28 } else {
29 $_[0];
30 }
31}
32
33sub install_rooted_dir {
34 if (defined $INSTALL_ROOT) {
35 MY->catdir($INSTALL_ROOT, $_[0]);
36 } else {
37 $_[0];
38 }
39}
40
17f410f9 41#our(@EXPORT, @ISA, $Is_VMS);
4b6d56d3 42#use strict;
43
f1387719 44sub forceunlink {
45 chmod 0666, $_[0];
46 unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
47}
08ad6bd5 48
4b6d56d3 49sub install {
f1387719 50 my($hash,$verbose,$nonono,$inc_uninstall) = @_;
4b6d56d3 51 $verbose ||= 0;
52 $nonono ||= 0;
08ad6bd5 53
54 use Cwd qw(cwd);
55 use ExtUtils::MakeMaker; # to implement a MY class
354f3b56 56 use ExtUtils::Packlist;
08ad6bd5 57 use File::Basename qw(dirname);
58 use File::Copy qw(copy);
59 use File::Find qw(find);
60 use File::Path qw(mkpath);
fb73857a 61 use File::Compare qw(compare);
08ad6bd5 62
4b6d56d3 63 my(%hash) = %$hash;
354f3b56 64 my(%pack, $dir, $warn_permissions);
65 my($packlist) = ExtUtils::Packlist->new();
3e3baf6d 66 # -w doesn't work reliably on FAT dirs
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);
74 foreach $source_dir_or_file (sort keys %hash) {
4b6d56d3 75 #Check if there are files, and if yes, look if the corresponding
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;
84 } else {
456e5c25 85 warn "Warning: You do not have permissions to " .
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"});
93 $packlist->read($tmpfile) if (-f $tmpfile);
4b6d56d3 94 my $cwd = cwd();
4b6d56d3 95
4b6d56d3 96 my($source);
97 MOD_INSTALL: foreach $source (sort keys %hash) {
98 #copy the tree to the target directory without altering
99 #timestamp and permission and remember for the .packlist
100 #file. The packlist file contains the absolute paths of the
101 #install locations. AFS users may call this a bug. We'll have
102 #to reconsider how to add the means to satisfy AFS users also.
456e5c25 103
104 #October 1997: we want to install .pm files into archlib if
105 #there are any files in arch. So we depend on having ./blib/arch
106 #hardcoded here.
a9d83807 107
108 my $targetroot = install_rooted_dir($hash{$source});
109
e8aa0dbc 110 if ($source eq "blib/lib" and
111 exists $hash{"blib/arch"} and
112 directory_not_empty("blib/arch")) {
a9d83807 113 $targetroot = install_rooted_dir($hash{"blib/arch"});
dcc96bbd 114 print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
456e5c25 115 }
4b6d56d3 116 chdir($source) or next;
117 find(sub {
118 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
119 $atime,$mtime,$ctime,$blksize,$blocks) = stat;
120 return unless -f _;
121 return if $_ eq ".exists";
a9d83807 122 my $targetdir = MY->catdir($targetroot, $File::Find::dir);
a9d83807 123 my $targetfile = MY->catfile($targetdir, $_);
4b6d56d3 124
f1387719 125 my $diff = 0;
4b6d56d3 126 if ( -f $targetfile && -s _ == $size) {
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
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);
166 print "Writing $pack{'write'}\n";
a9d83807 167 $packlist->write(install_rooted_file($pack{'write'}));
4b6d56d3 168 }
169}
170
456e5c25 171sub 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 184sub install_default {
185 @_ < 2 or die "install_default should be called with 0 or 1 argument";
186 my $FULLEXT = @_ ? shift : $ARGV[0];
187 defined $FULLEXT or die "Do not know to where to write install log";
188 my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
189 my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
190 my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
191 my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
192 my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
193 my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
194 install({
195 read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
196 write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
456e5c25 197 $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
198 $Config{installsitearch} :
199 $Config{installsitelib},
c3648e42 200 $INST_ARCHLIB => $Config{installsitearch},
201 $INST_BIN => $Config{installbin} ,
202 $INST_SCRIPT => $Config{installscript},
203 $INST_MAN1DIR => $Config{installman1dir},
204 $INST_MAN3DIR => $Config{installman3dir},
205 },1,0,0);
206}
207
4b6d56d3 208sub uninstall {
354f3b56 209 use ExtUtils::Packlist;
4b6d56d3 210 my($fil,$verbose,$nonono) = @_;
211 die "no packlist file found: $fil" unless -f $fil;
f1387719 212 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
213 # require $my_req; # Hairy, but for the first
354f3b56 214 my ($packlist) = ExtUtils::Packlist->new($fil);
215 foreach (sort(keys(%$packlist))) {
4b6d56d3 216 chomp;
217 print "unlink $_\n" if $verbose;
f1387719 218 forceunlink($_) unless $nonono;
4b6d56d3 219 }
220 print "unlink $fil\n" if $verbose;
f1387719 221 forceunlink($fil) unless $nonono;
222}
223
224sub 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 ".";
233 next if $seen_dir{$dir}++;
456e5c25 234 my($targetfile) = MY->catfile($dir,$libdir,$file);
f1387719 235 next unless -f $targetfile;
236
237 # The reason why we compare file's contents is, that we cannot
238 # know, which is the file we just installed (AFS). So we leave
239 # an identical file in place
240 my $diff = 0;
241 if ( -f $targetfile && -s _ == -s $file) {
242 # We have a good chance, we can skip this one
fb73857a 243 $diff = compare($file,$targetfile);
f1387719 244 } else {
245 print "#$file and $targetfile differ\n" if $verbose>1;
246 $diff++;
247 }
248
249 next unless $diff;
250 if ($nonono) {
251 if ($verbose) {
252 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
4f44ac69 253 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
f1387719 254 $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
255 }
256 # if not verbose, we just say nothing
257 } else {
258 print "Unlinking $targetfile (shadowing?)\n";
259 forceunlink($targetfile);
260 }
261 }
08ad6bd5 262}
263
131aa089 264sub run_filter {
265 my ($cmd, $src, $dest) = @_;
c366adb4 266 open(my $CMD, "|$cmd >$dest") || die "Cannot fork: $!";
267 open(my $SRC, $src) || die "Cannot open $src: $!";
131aa089 268 my $buf;
269 my $sz = 1024;
c366adb4 270 while (my $len = sysread($SRC, $buf, $sz)) {
271 syswrite($CMD, $buf, $len);
131aa089 272 }
c366adb4 273 close $SRC;
274 close $CMD or die "Filter command '$cmd' failed for $src";
131aa089 275}
276
08ad6bd5 277sub 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));
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);
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;
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);
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}
334
f1387719 335package ExtUtils::Install::Warn;
336
337sub new { bless {}, shift }
338
339sub add {
340 my($self,$file,$targetfile) = @_;
341 push @{$self->{$file}}, $targetfile;
342}
343
344sub 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}
360
4b6d56d3 3611;
362
363__END__
364
365=head1 NAME
366
367ExtUtils::Install - install files from here to there
368
369=head1 SYNOPSIS
370
371B<use ExtUtils::Install;>
372
373B<install($hashref,$verbose,$nonono);>
374
375B<uninstall($packlistfile,$verbose,$nonono);>
376
08ad6bd5 377B<pm_to_blib($hashref);>
378
4b6d56d3 379=head1 DESCRIPTION
380
08ad6bd5 381Both install() and uninstall() are specific to the way
4b6d56d3 382ExtUtils::MakeMaker handles the installation and deinstallation of
383perl modules. They are not designed as general purpose tools.
384
385install() takes three arguments. A reference to a hash, a verbose
386switch and a don't-really-do-it switch. The hash ref contains a
387mapping of directories: each key/value pair is a combination of
388directories to be copied. Key is a directory to copy from, value is a
389directory to copy to. The whole tree below the "from" directory will
390be copied preserving timestamps and permissions.
391
392There 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 394target files to the file named by C<$hashref-E<gt>{write}>. If there is
395another file named by C<$hashref-E<gt>{read}>, the contents of this file will
4b6d56d3 396be merged into the written file. The read and the written file may be
a7665c5e 397identical, but on AFS it is quite likely that people are installing to a
4b6d56d3 398different directory than the one where the files later appear.
399
c3648e42 400install_default() takes one or less arguments. If no arguments are
401specified, it takes $ARGV[0] as if it was specified as an argument.
402The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
403This function calls install() with the same arguments as the defaults
404the MakeMaker would use.
405
de592821 406The argument-less form is convenient for install scripts like
c3648e42 407
408 perl -MExtUtils::Install -e install_default Tk/Canvas
409
a7665c5e 410Assuming this command is executed in a directory with a populated F<blib>
c3648e42 411directory, it will proceed as if the F<blib> was build by MakeMaker on
412this machine. This is useful for binary distributions.
413
4b6d56d3 414uninstall() takes as first argument a file containing filenames to be
415unlinked. The second argument is a verbose switch, the third is a
416no-don't-really-do-it-now switch.
417
08ad6bd5 418pm_to_blib() takes a hashref as the first argument and copies all keys
419of the hash to the corresponding values efficiently. Filenames with
420the extension pm are autosplit. Second argument is the autosplit
131aa089 421directory. If third argument is not empty, it is taken as a filter command
422to be ran on each .pm file, the output of the command being what is finally
423copied, and the source for auto-splitting.
4b6d56d3 424
ae1d6394 425You can have an environment variable PERL_INSTALL_ROOT set which will
426be prepended as a directory to each installed file (and directory).
427
08ad6bd5 428=cut