This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Changes.
[perl5.git] / lib / ExtUtils / Install.pm
CommitLineData
4b6d56d3
PP
1package ExtUtils::Install;
2
17f410f9
GS
3use 5.005_64;
4our(@ISA, @EXPORT, $VERSION);
456e5c25
A
5$VERSION = substr q$Revision: 1.28 $, 10;
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
PP
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
PP
17my $Inc_uninstall_warn_handler;
18
a9d83807
BC
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
PP
42#use strict;
43
f1387719
PP
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
PP
51 $verbose ||= 0;
52 $nonono ||= 0;
08ad6bd5
PP
53
54 use Cwd qw(cwd);
55 use ExtUtils::MakeMaker; # to implement a MY class
354f3b56 56 use ExtUtils::Packlist;
08ad6bd5
PP
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
AB
64 my(%pack, $dir, $warn_permissions);
65 my($packlist) = ExtUtils::Packlist->new();
3e3baf6d
TB
66 # -w doesn't work reliably on FAT dirs
67 $warn_permissions++ if $^O eq 'MSWin32';
354f3b56 68 local(*DIR);
4b6d56d3
PP
69 for (qw/read write/) {
70 $pack{$_}=$hash{$_};
71 delete $hash{$_};
72 }
08ad6bd5
PP
73 my($source_dir_or_file);
74 foreach $source_dir_or_file (sort keys %hash) {
4b6d56d3
PP
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
BC
80 my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
81 if (-w $targetdir ||
82 mkpath($targetdir)) {
4b6d56d3
PP
83 last;
84 } else {
456e5c25
A
85 warn "Warning: You do not have permissions to " .
86 "install into $hash{$source_dir_or_file}"
cee7b94a 87 unless $warn_permissions++;
4b6d56d3
PP
88 }
89 }
90 closedir DIR;
91 }
a9d83807
BC
92 my $tmpfile = install_rooted_file($pack{"read"});
93 $packlist->read($tmpfile) if (-f $tmpfile);
4b6d56d3 94 my $cwd = cwd();
4b6d56d3 95
4b6d56d3
PP
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
A
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
BC
107
108 my $targetroot = install_rooted_dir($hash{$source});
109
e8aa0dbc
AB
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
PP
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
PP
126 if ( -f $targetfile && -s _ == $size) {
127 # We have a good chance, we can skip this one
fb73857a 128 $diff = compare($_,$targetfile);
4b6d56d3
PP
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
PP
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
PP
146 chmod $mode, $targetfile;
147 print "chmod($mode, $targetfile)\n" if $verbose>1;
148 } else {
f1387719
PP
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
PP
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
PP
165 mkpath($dir,0,0755);
166 print "Writing $pack{'write'}\n";
a9d83807 167 $packlist->write(install_rooted_file($pack{'write'}));
4b6d56d3
PP
168 }
169}
170
456e5c25
A
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
IZ
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
A
197 $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
198 $Config{installsitearch} :
199 $Config{installsitelib},
c3648e42
IZ
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
PP
210 my($fil,$verbose,$nonono) = @_;
211 die "no packlist file found: $fil" unless -f $fil;
f1387719
PP
212 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
213 # require $my_req; # Hairy, but for the first
354f3b56
AB
214 my ($packlist) = ExtUtils::Packlist->new($fil);
215 foreach (sort(keys(%$packlist))) {
4b6d56d3
PP
216 chomp;
217 print "unlink $_\n" if $verbose;
f1387719 218 forceunlink($_) unless $nonono;
4b6d56d3
PP
219 }
220 print "unlink $fil\n" if $verbose;
f1387719
PP
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
A
228 foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
229 privlibexp
230 sitearchexp
231 sitelibexp)}) {
f1387719
PP
232 next if $dir eq ".";
233 next if $seen_dir{$dir}++;
456e5c25 234 my($targetfile) = MY->catfile($dir,$libdir,$file);
f1387719
PP
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
PP
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
PP
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
PP
262}
263
131aa089
RM
264sub run_filter {
265 my ($cmd, $src, $dest) = @_;
266 local *SRC, *CMD;
267 open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
268 open(SRC, $src) || die "Cannot open $src: $!";
269 my $buf;
270 my $sz = 1024;
271 while (my $len = sysread(SRC, $buf, $sz)) {
272 syswrite(CMD, $buf, $len);
273 }
274 close SRC;
275 close CMD or die "Filter command '$cmd' failed for $src";
276}
277
08ad6bd5 278sub pm_to_blib {
131aa089 279 my($fromto,$autodir,$pm_filter) = @_;
08ad6bd5
PP
280
281 use File::Basename qw(dirname);
282 use File::Copy qw(copy);
283 use File::Path qw(mkpath);
fb73857a 284 use File::Compare qw(compare);
08ad6bd5 285 use AutoSplit;
f1387719
PP
286 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
287 # require $my_req; # Hairy, but for the first
08ad6bd5 288
68dc0745
PP
289 if (!ref($fromto) && -r $fromto)
290 {
291 # Win32 has severe command line length limitations, but
292 # can generate temporary files on-the-fly
293 # so we pass name of file here - eval it to get hash
294 open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
295 my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
296 eval $str;
297 close(FROMTO);
298 }
299
08ad6bd5
PP
300 mkpath($autodir,0,0755);
301 foreach (keys %$fromto) {
131aa089
RM
302 my $dest = $fromto->{$_};
303 next if -f $dest && -M $dest < -M $_;
304
305 # When a pm_filter is defined, we need to pre-process the source first
306 # to determine whether it has changed or not. Therefore, only perform
307 # the comparison check when there's no filter to be ran.
308 # -- RAM, 03/01/2001
309
310 my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;
311
312 if (!$need_filtering && 0 == compare($_,$dest)) {
313 print "Skip $dest (unchanged)\n";
08ad6bd5
PP
314 next;
315 }
131aa089
RM
316 if (-f $dest){
317 forceunlink($dest);
318 } else {
319 mkpath(dirname($dest),0,0755);
320 }
321 if ($need_filtering) {
322 run_filter($pm_filter, $_, $dest);
323 print "$pm_filter <$_ >$dest\n";
08ad6bd5 324 } else {
131aa089
RM
325 copy($_,$dest);
326 print "cp $_ $dest\n";
08ad6bd5 327 }
cee7b94a 328 my($mode,$atime,$mtime) = (stat)[2,8,9];
131aa089
RM
329 utime($atime,$mtime+$Is_VMS,$dest);
330 chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
331 next unless /\.pm$/;
332 autosplit($dest,$autodir);
08ad6bd5 333 }
4b6d56d3
PP
334}
335
f1387719
PP
336package ExtUtils::Install::Warn;
337
338sub new { bless {}, shift }
339
340sub add {
341 my($self,$file,$targetfile) = @_;
342 push @{$self->{$file}}, $targetfile;
343}
344
345sub DESTROY {
a9d83807
BC
346 unless(defined $INSTALL_ROOT) {
347 my $self = shift;
348 my($file,$i,$plural);
349 foreach $file (sort keys %$self) {
350 $plural = @{$self->{$file}} > 1 ? "s" : "";
351 print "## Differing version$plural of $file found. You might like to\n";
352 for (0..$#{$self->{$file}}) {
353 print "rm ", $self->{$file}[$_], "\n";
354 $i++;
355 }
356 }
357 $plural = $i>1 ? "all those files" : "this file";
358 print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
f1387719 359 }
f1387719
PP
360}
361
4b6d56d3
PP
3621;
363
364__END__
365
366=head1 NAME
367
368ExtUtils::Install - install files from here to there
369
370=head1 SYNOPSIS
371
372B<use ExtUtils::Install;>
373
374B<install($hashref,$verbose,$nonono);>
375
376B<uninstall($packlistfile,$verbose,$nonono);>
377
08ad6bd5
PP
378B<pm_to_blib($hashref);>
379
4b6d56d3
PP
380=head1 DESCRIPTION
381
08ad6bd5 382Both install() and uninstall() are specific to the way
4b6d56d3
PP
383ExtUtils::MakeMaker handles the installation and deinstallation of
384perl modules. They are not designed as general purpose tools.
385
386install() takes three arguments. A reference to a hash, a verbose
387switch and a don't-really-do-it switch. The hash ref contains a
388mapping of directories: each key/value pair is a combination of
389directories to be copied. Key is a directory to copy from, value is a
390directory to copy to. The whole tree below the "from" directory will
391be copied preserving timestamps and permissions.
392
393There are two keys with a special meaning in the hash: "read" and
394"write". After the copying is done, install will write the list of
1fef88e7
JM
395target files to the file named by C<$hashref-E<gt>{write}>. If there is
396another file named by C<$hashref-E<gt>{read}>, the contents of this file will
4b6d56d3 397be merged into the written file. The read and the written file may be
a7665c5e 398identical, but on AFS it is quite likely that people are installing to a
4b6d56d3
PP
399different directory than the one where the files later appear.
400
c3648e42
IZ
401install_default() takes one or less arguments. If no arguments are
402specified, it takes $ARGV[0] as if it was specified as an argument.
403The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
404This function calls install() with the same arguments as the defaults
405the MakeMaker would use.
406
de592821 407The argument-less form is convenient for install scripts like
c3648e42
IZ
408
409 perl -MExtUtils::Install -e install_default Tk/Canvas
410
a7665c5e 411Assuming this command is executed in a directory with a populated F<blib>
c3648e42
IZ
412directory, it will proceed as if the F<blib> was build by MakeMaker on
413this machine. This is useful for binary distributions.
414
4b6d56d3
PP
415uninstall() takes as first argument a file containing filenames to be
416unlinked. The second argument is a verbose switch, the third is a
417no-don't-really-do-it-now switch.
418
08ad6bd5
PP
419pm_to_blib() takes a hashref as the first argument and copies all keys
420of the hash to the corresponding values efficiently. Filenames with
421the extension pm are autosplit. Second argument is the autosplit
131aa089
RM
422directory. If third argument is not empty, it is taken as a filter command
423to be ran on each .pm file, the output of the command being what is finally
424copied, and the source for auto-splitting.
4b6d56d3 425
ae1d6394
JH
426You can have an environment variable PERL_INSTALL_ROOT set which will
427be prepended as a directory to each installed file (and directory).
428
08ad6bd5 429=cut