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