This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Old RCS $Date$ tag
[perl5.git] / lib / ExtUtils / Install.pm
CommitLineData
4b6d56d3
PP
1package ExtUtils::Install;
2
3b825e41 3use 5.006_001;
17f410f9 4our(@ISA, @EXPORT, $VERSION);
9c5e0596 5$VERSION = 1.29
f1387719 6
08ad6bd5 7use Exporter;
08ad6bd5 8use Carp ();
c3648e42 9use Config qw(%Config);
4b6d56d3 10@ISA = ('Exporter');
c3648e42 11@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
08ad6bd5
PP
12$Is_VMS = $^O eq 'VMS';
13
39e571d4 14my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
d6abf24b 15my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
f1387719
PP
16my $Inc_uninstall_warn_handler;
17
a9d83807
BC
18# install relative to here
19
20my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
21
22use File::Spec;
23
24sub install_rooted_file {
25 if (defined $INSTALL_ROOT) {
3ac85e8f 26 File::Spec->catfile($INSTALL_ROOT, $_[0]);
a9d83807
BC
27 } else {
28 $_[0];
29 }
30}
31
32sub install_rooted_dir {
33 if (defined $INSTALL_ROOT) {
3ac85e8f 34 File::Spec->catdir($INSTALL_ROOT, $_[0]);
a9d83807
BC
35 } else {
36 $_[0];
37 }
38}
39
17f410f9 40#our(@EXPORT, @ISA, $Is_VMS);
4b6d56d3
PP
41#use strict;
42
f1387719
PP
43sub forceunlink {
44 chmod 0666, $_[0];
45 unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
46}
08ad6bd5 47
4b6d56d3 48sub install {
f1387719 49 my($hash,$verbose,$nonono,$inc_uninstall) = @_;
4b6d56d3
PP
50 $verbose ||= 0;
51 $nonono ||= 0;
08ad6bd5
PP
52
53 use Cwd qw(cwd);
354f3b56 54 use ExtUtils::Packlist;
08ad6bd5
PP
55 use File::Basename qw(dirname);
56 use File::Copy qw(copy);
57 use File::Find qw(find);
58 use File::Path qw(mkpath);
fb73857a 59 use File::Compare qw(compare);
3ac85e8f 60 use File::Spec;
08ad6bd5 61
4b6d56d3 62 my(%hash) = %$hash;
354f3b56
AB
63 my(%pack, $dir, $warn_permissions);
64 my($packlist) = ExtUtils::Packlist->new();
3e3baf6d
TB
65 # -w doesn't work reliably on FAT dirs
66 $warn_permissions++ if $^O eq 'MSWin32';
354f3b56 67 local(*DIR);
4b6d56d3
PP
68 for (qw/read write/) {
69 $pack{$_}=$hash{$_};
70 delete $hash{$_};
71 }
08ad6bd5
PP
72 my($source_dir_or_file);
73 foreach $source_dir_or_file (sort keys %hash) {
4b6d56d3
PP
74 #Check if there are files, and if yes, look if the corresponding
75 #target directory is writable for us
08ad6bd5 76 opendir DIR, $source_dir_or_file or next;
f1387719 77 for (readdir DIR) {
4b6d56d3 78 next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
a9d83807
BC
79 my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
80 if (-w $targetdir ||
81 mkpath($targetdir)) {
4b6d56d3
PP
82 last;
83 } else {
456e5c25
A
84 warn "Warning: You do not have permissions to " .
85 "install into $hash{$source_dir_or_file}"
cee7b94a 86 unless $warn_permissions++;
4b6d56d3
PP
87 }
88 }
89 closedir DIR;
90 }
a9d83807
BC
91 my $tmpfile = install_rooted_file($pack{"read"});
92 $packlist->read($tmpfile) if (-f $tmpfile);
4b6d56d3 93 my $cwd = cwd();
4b6d56d3 94
4b6d56d3
PP
95 my($source);
96 MOD_INSTALL: foreach $source (sort keys %hash) {
97 #copy the tree to the target directory without altering
98 #timestamp and permission and remember for the .packlist
99 #file. The packlist file contains the absolute paths of the
100 #install locations. AFS users may call this a bug. We'll have
101 #to reconsider how to add the means to satisfy AFS users also.
456e5c25
A
102
103 #October 1997: we want to install .pm files into archlib if
104 #there are any files in arch. So we depend on having ./blib/arch
105 #hardcoded here.
a9d83807
BC
106
107 my $targetroot = install_rooted_dir($hash{$source});
108
e8aa0dbc
AB
109 if ($source eq "blib/lib" and
110 exists $hash{"blib/arch"} and
111 directory_not_empty("blib/arch")) {
a9d83807 112 $targetroot = install_rooted_dir($hash{"blib/arch"});
dcc96bbd 113 print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
456e5c25 114 }
4b6d56d3
PP
115 chdir($source) or next;
116 find(sub {
117 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
118 $atime,$mtime,$ctime,$blksize,$blocks) = stat;
119 return unless -f _;
120 return if $_ eq ".exists";
3ac85e8f
DR
121 my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
122 my $targetfile = File::Spec->catfile($targetdir, $_);
4b6d56d3 123
f1387719 124 my $diff = 0;
4b6d56d3
PP
125 if ( -f $targetfile && -s _ == $size) {
126 # We have a good chance, we can skip this one
fb73857a 127 $diff = compare($_,$targetfile);
4b6d56d3
PP
128 } else {
129 print "$_ differs\n" if $verbose>1;
130 $diff++;
131 }
132
133 if ($diff){
08ad6bd5 134 if (-f $targetfile){
f1387719 135 forceunlink($targetfile) unless $nonono;
08ad6bd5
PP
136 } else {
137 mkpath($targetdir,0,0755) unless $nonono;
138 print "mkpath($targetdir,0,0755)\n" if $verbose>1;
139 }
4b6d56d3 140 copy($_,$targetfile) unless $nonono;
f1387719 141 print "Installing $targetfile\n";
08ad6bd5 142 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
4b6d56d3 143 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
f1387719 144 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
4b6d56d3
PP
145 chmod $mode, $targetfile;
146 print "chmod($mode, $targetfile)\n" if $verbose>1;
147 } else {
f1387719
PP
148 print "Skipping $targetfile (unchanged)\n" if $verbose;
149 }
150
151 if (! defined $inc_uninstall) { # it's called
152 } elsif ($inc_uninstall == 0){
153 inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
154 } else {
155 inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
4b6d56d3 156 }
8c05f1d0 157 # Record the full pathname.
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";
5de3f0da
DR
188 my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
189 my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
190 my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
191 my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
192 my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
193 my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
c3648e42
IZ
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}++;
3ac85e8f 234 my($targetfile) = File::Spec->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) = @_;
c366adb4
JH
266 open(my $CMD, "|$cmd >$dest") || die "Cannot fork: $!";
267 open(my $SRC, $src) || die "Cannot open $src: $!";
131aa089
RM
268 my $buf;
269 my $sz = 1024;
c366adb4
JH
270 while (my $len = sysread($SRC, $buf, $sz)) {
271 syswrite($CMD, $buf, $len);
131aa089 272 }
c366adb4
JH
273 close $SRC;
274 close $CMD or die "Filter command '$cmd' failed for $src";
131aa089
RM
275}
276
08ad6bd5 277sub pm_to_blib {
131aa089 278 my($fromto,$autodir,$pm_filter) = @_;
08ad6bd5
PP
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
PP
285 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
286 # require $my_req; # Hairy, but for the first
08ad6bd5 287
68dc0745
PP
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
PP
299 mkpath($autodir,0,0755);
300 foreach (keys %$fromto) {
131aa089
RM
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
PP
313 next;
314 }
131aa089
RM
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
RM
324 copy($_,$dest);
325 print "cp $_ $dest\n";
08ad6bd5 326 }
cee7b94a 327 my($mode,$atime,$mtime) = (stat)[2,8,9];
131aa089
RM
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
PP
333}
334
f1387719
PP
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
BC
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
PP
359}
360
4b6d56d3
PP
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
PP
377B<pm_to_blib($hashref);>
378
4b6d56d3
PP
379=head1 DESCRIPTION
380
08ad6bd5 381Both install() and uninstall() are specific to the way
4b6d56d3
PP
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
JM
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
PP
398different directory than the one where the files later appear.
399
c3648e42
IZ
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
IZ
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
IZ
411directory, it will proceed as if the F<blib> was build by MakeMaker on
412this machine. This is useful for binary distributions.
413
4b6d56d3
PP
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
PP
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
RM
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
JH
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