This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Two thirds of
[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
17f410f9 19#our(@EXPORT, @ISA, $Is_VMS);
4b6d56d3
PP
20#use strict;
21
f1387719
PP
22sub forceunlink {
23 chmod 0666, $_[0];
24 unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
25}
08ad6bd5 26
4b6d56d3 27sub install {
f1387719 28 my($hash,$verbose,$nonono,$inc_uninstall) = @_;
4b6d56d3
PP
29 $verbose ||= 0;
30 $nonono ||= 0;
08ad6bd5
PP
31
32 use Cwd qw(cwd);
33 use ExtUtils::MakeMaker; # to implement a MY class
354f3b56 34 use ExtUtils::Packlist;
08ad6bd5
PP
35 use File::Basename qw(dirname);
36 use File::Copy qw(copy);
37 use File::Find qw(find);
38 use File::Path qw(mkpath);
fb73857a 39 use File::Compare qw(compare);
08ad6bd5 40
4b6d56d3 41 my(%hash) = %$hash;
354f3b56
AB
42 my(%pack, $dir, $warn_permissions);
43 my($packlist) = ExtUtils::Packlist->new();
3e3baf6d
TB
44 # -w doesn't work reliably on FAT dirs
45 $warn_permissions++ if $^O eq 'MSWin32';
354f3b56 46 local(*DIR);
4b6d56d3
PP
47 for (qw/read write/) {
48 $pack{$_}=$hash{$_};
49 delete $hash{$_};
50 }
08ad6bd5
PP
51 my($source_dir_or_file);
52 foreach $source_dir_or_file (sort keys %hash) {
4b6d56d3
PP
53 #Check if there are files, and if yes, look if the corresponding
54 #target directory is writable for us
08ad6bd5 55 opendir DIR, $source_dir_or_file or next;
f1387719 56 for (readdir DIR) {
4b6d56d3 57 next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
456e5c25
A
58 if (-w $hash{$source_dir_or_file} ||
59 mkpath($hash{$source_dir_or_file})) {
4b6d56d3
PP
60 last;
61 } else {
456e5c25
A
62 warn "Warning: You do not have permissions to " .
63 "install into $hash{$source_dir_or_file}"
cee7b94a 64 unless $warn_permissions++;
4b6d56d3
PP
65 }
66 }
67 closedir DIR;
68 }
354f3b56 69 $packlist->read($pack{"read"}) if (-f $pack{"read"});
4b6d56d3 70 my $cwd = cwd();
4b6d56d3 71
4b6d56d3
PP
72 my($source);
73 MOD_INSTALL: foreach $source (sort keys %hash) {
74 #copy the tree to the target directory without altering
75 #timestamp and permission and remember for the .packlist
76 #file. The packlist file contains the absolute paths of the
77 #install locations. AFS users may call this a bug. We'll have
78 #to reconsider how to add the means to satisfy AFS users also.
456e5c25
A
79
80 #October 1997: we want to install .pm files into archlib if
81 #there are any files in arch. So we depend on having ./blib/arch
82 #hardcoded here.
83 my $targetroot = $hash{$source};
e8aa0dbc
AB
84 if ($source eq "blib/lib" and
85 exists $hash{"blib/arch"} and
86 directory_not_empty("blib/arch")) {
87 $targetroot = $hash{"blib/arch"};
dcc96bbd 88 print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
456e5c25 89 }
4b6d56d3
PP
90 chdir($source) or next;
91 find(sub {
92 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
93 $atime,$mtime,$ctime,$blksize,$blocks) = stat;
94 return unless -f _;
95 return if $_ eq ".exists";
456e5c25
A
96 my $targetdir = MY->catdir($targetroot,$File::Find::dir);
97 my $targetfile = MY->catfile($targetdir,$_);
4b6d56d3 98
f1387719 99 my $diff = 0;
4b6d56d3
PP
100 if ( -f $targetfile && -s _ == $size) {
101 # We have a good chance, we can skip this one
fb73857a 102 $diff = compare($_,$targetfile);
4b6d56d3
PP
103 } else {
104 print "$_ differs\n" if $verbose>1;
105 $diff++;
106 }
107
108 if ($diff){
08ad6bd5 109 if (-f $targetfile){
f1387719 110 forceunlink($targetfile) unless $nonono;
08ad6bd5
PP
111 } else {
112 mkpath($targetdir,0,0755) unless $nonono;
113 print "mkpath($targetdir,0,0755)\n" if $verbose>1;
114 }
4b6d56d3 115 copy($_,$targetfile) unless $nonono;
f1387719 116 print "Installing $targetfile\n";
08ad6bd5 117 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
4b6d56d3 118 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
f1387719 119 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
4b6d56d3
PP
120 chmod $mode, $targetfile;
121 print "chmod($mode, $targetfile)\n" if $verbose>1;
122 } else {
f1387719
PP
123 print "Skipping $targetfile (unchanged)\n" if $verbose;
124 }
125
126 if (! defined $inc_uninstall) { # it's called
127 } elsif ($inc_uninstall == 0){
128 inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
129 } else {
130 inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
4b6d56d3 131 }
354f3b56 132 $packlist->{$targetfile}++;
4b6d56d3
PP
133
134 }, ".");
08ad6bd5 135 chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
4b6d56d3 136 }
4b6d56d3
PP
137 if ($pack{'write'}) {
138 $dir = dirname($pack{'write'});
139 mkpath($dir,0,0755);
140 print "Writing $pack{'write'}\n";
354f3b56 141 $packlist->write($pack{'write'});
4b6d56d3
PP
142 }
143}
144
456e5c25
A
145sub directory_not_empty ($) {
146 my($dir) = @_;
147 my $files = 0;
148 find(sub {
149 return if $_ eq ".exists";
150 if (-f) {
151 $File::Find::prune++;
152 $files = 1;
153 }
154 }, $dir);
155 return $files;
156}
157
c3648e42
IZ
158sub install_default {
159 @_ < 2 or die "install_default should be called with 0 or 1 argument";
160 my $FULLEXT = @_ ? shift : $ARGV[0];
161 defined $FULLEXT or die "Do not know to where to write install log";
162 my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
163 my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
164 my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
165 my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
166 my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
167 my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
168 install({
169 read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
170 write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
456e5c25
A
171 $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
172 $Config{installsitearch} :
173 $Config{installsitelib},
c3648e42
IZ
174 $INST_ARCHLIB => $Config{installsitearch},
175 $INST_BIN => $Config{installbin} ,
176 $INST_SCRIPT => $Config{installscript},
177 $INST_MAN1DIR => $Config{installman1dir},
178 $INST_MAN3DIR => $Config{installman3dir},
179 },1,0,0);
180}
181
4b6d56d3 182sub uninstall {
354f3b56 183 use ExtUtils::Packlist;
4b6d56d3
PP
184 my($fil,$verbose,$nonono) = @_;
185 die "no packlist file found: $fil" unless -f $fil;
f1387719
PP
186 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
187 # require $my_req; # Hairy, but for the first
354f3b56
AB
188 my ($packlist) = ExtUtils::Packlist->new($fil);
189 foreach (sort(keys(%$packlist))) {
4b6d56d3
PP
190 chomp;
191 print "unlink $_\n" if $verbose;
f1387719 192 forceunlink($_) unless $nonono;
4b6d56d3
PP
193 }
194 print "unlink $fil\n" if $verbose;
f1387719
PP
195 forceunlink($fil) unless $nonono;
196}
197
198sub inc_uninstall {
199 my($file,$libdir,$verbose,$nonono) = @_;
200 my($dir);
f1387719 201 my %seen_dir = ();
456e5c25
A
202 foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
203 privlibexp
204 sitearchexp
205 sitelibexp)}) {
f1387719
PP
206 next if $dir eq ".";
207 next if $seen_dir{$dir}++;
456e5c25 208 my($targetfile) = MY->catfile($dir,$libdir,$file);
f1387719
PP
209 next unless -f $targetfile;
210
211 # The reason why we compare file's contents is, that we cannot
212 # know, which is the file we just installed (AFS). So we leave
213 # an identical file in place
214 my $diff = 0;
215 if ( -f $targetfile && -s _ == -s $file) {
216 # We have a good chance, we can skip this one
fb73857a 217 $diff = compare($file,$targetfile);
f1387719
PP
218 } else {
219 print "#$file and $targetfile differ\n" if $verbose>1;
220 $diff++;
221 }
222
223 next unless $diff;
224 if ($nonono) {
225 if ($verbose) {
226 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
4f44ac69 227 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
f1387719
PP
228 $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
229 }
230 # if not verbose, we just say nothing
231 } else {
232 print "Unlinking $targetfile (shadowing?)\n";
233 forceunlink($targetfile);
234 }
235 }
08ad6bd5
PP
236}
237
238sub pm_to_blib {
239 my($fromto,$autodir) = @_;
240
241 use File::Basename qw(dirname);
242 use File::Copy qw(copy);
243 use File::Path qw(mkpath);
fb73857a 244 use File::Compare qw(compare);
08ad6bd5 245 use AutoSplit;
f1387719
PP
246 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
247 # require $my_req; # Hairy, but for the first
08ad6bd5 248
68dc0745
PP
249 if (!ref($fromto) && -r $fromto)
250 {
251 # Win32 has severe command line length limitations, but
252 # can generate temporary files on-the-fly
253 # so we pass name of file here - eval it to get hash
254 open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
255 my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
256 eval $str;
257 close(FROMTO);
258 }
259
08ad6bd5
PP
260 mkpath($autodir,0,0755);
261 foreach (keys %$fromto) {
262 next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
fb73857a 263 unless (compare($_,$fromto->{$_})){
08ad6bd5
PP
264 print "Skip $fromto->{$_} (unchanged)\n";
265 next;
266 }
267 if (-f $fromto->{$_}){
f1387719 268 forceunlink($fromto->{$_});
08ad6bd5
PP
269 } else {
270 mkpath(dirname($fromto->{$_}),0,0755);
271 }
272 copy($_,$fromto->{$_});
cee7b94a
PP
273 my($mode,$atime,$mtime) = (stat)[2,8,9];
274 utime($atime,$mtime+$Is_VMS,$fromto->{$_});
275 chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
08ad6bd5 276 print "cp $_ $fromto->{$_}\n";
4f44ac69 277 next unless /\.pm\z/;
08ad6bd5
PP
278 autosplit($fromto->{$_},$autodir);
279 }
4b6d56d3
PP
280}
281
f1387719
PP
282package ExtUtils::Install::Warn;
283
284sub new { bless {}, shift }
285
286sub add {
287 my($self,$file,$targetfile) = @_;
288 push @{$self->{$file}}, $targetfile;
289}
290
291sub DESTROY {
292 my $self = shift;
293 my($file,$i,$plural);
294 foreach $file (sort keys %$self) {
295 $plural = @{$self->{$file}} > 1 ? "s" : "";
296 print "## Differing version$plural of $file found. You might like to\n";
297 for (0..$#{$self->{$file}}) {
298 print "rm ", $self->{$file}[$_], "\n";
299 $i++;
300 }
301 }
302 $plural = $i>1 ? "all those files" : "this file";
303 print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
304}
305
4b6d56d3
PP
3061;
307
308__END__
309
310=head1 NAME
311
312ExtUtils::Install - install files from here to there
313
314=head1 SYNOPSIS
315
316B<use ExtUtils::Install;>
317
318B<install($hashref,$verbose,$nonono);>
319
320B<uninstall($packlistfile,$verbose,$nonono);>
321
08ad6bd5
PP
322B<pm_to_blib($hashref);>
323
4b6d56d3
PP
324=head1 DESCRIPTION
325
08ad6bd5 326Both install() and uninstall() are specific to the way
4b6d56d3
PP
327ExtUtils::MakeMaker handles the installation and deinstallation of
328perl modules. They are not designed as general purpose tools.
329
330install() takes three arguments. A reference to a hash, a verbose
331switch and a don't-really-do-it switch. The hash ref contains a
332mapping of directories: each key/value pair is a combination of
333directories to be copied. Key is a directory to copy from, value is a
334directory to copy to. The whole tree below the "from" directory will
335be copied preserving timestamps and permissions.
336
337There are two keys with a special meaning in the hash: "read" and
338"write". After the copying is done, install will write the list of
1fef88e7
JM
339target files to the file named by C<$hashref-E<gt>{write}>. If there is
340another file named by C<$hashref-E<gt>{read}>, the contents of this file will
4b6d56d3 341be merged into the written file. The read and the written file may be
a7665c5e 342identical, but on AFS it is quite likely that people are installing to a
4b6d56d3
PP
343different directory than the one where the files later appear.
344
c3648e42
IZ
345install_default() takes one or less arguments. If no arguments are
346specified, it takes $ARGV[0] as if it was specified as an argument.
347The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
348This function calls install() with the same arguments as the defaults
349the MakeMaker would use.
350
de592821 351The argument-less form is convenient for install scripts like
c3648e42
IZ
352
353 perl -MExtUtils::Install -e install_default Tk/Canvas
354
a7665c5e 355Assuming this command is executed in a directory with a populated F<blib>
c3648e42
IZ
356directory, it will proceed as if the F<blib> was build by MakeMaker on
357this machine. This is useful for binary distributions.
358
4b6d56d3
PP
359uninstall() takes as first argument a file containing filenames to be
360unlinked. The second argument is a verbose switch, the third is a
361no-don't-really-do-it-now switch.
362
08ad6bd5
PP
363pm_to_blib() takes a hashref as the first argument and copies all keys
364of the hash to the corresponding values efficiently. Filenames with
365the extension pm are autosplit. Second argument is the autosplit
366directory.
4b6d56d3 367
08ad6bd5 368=cut