This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Apply NetBSD patch-ac.
[perl5.git] / lib / ExtUtils / Install.pm
1 package ExtUtils::Install;
2
3 use 5.006_001;
4 our(@ISA, @EXPORT, $VERSION);
5 $VERSION = substr q$Revision: 1.29 $, 10;
6 # $Date: 1998/01/25 07:08:24 $
7
8 use Exporter;
9 use Carp ();
10 use Config qw(%Config);
11 @ISA = ('Exporter');
12 @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
13 $Is_VMS = $^O eq 'VMS';
14
15 my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
16 my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
17 my $Inc_uninstall_warn_handler;
18
19 # install relative to here
20
21 my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
22
23 use File::Spec;
24
25 sub install_rooted_file {
26     if (defined $INSTALL_ROOT) {
27         File::Spec->catfile($INSTALL_ROOT, $_[0]);
28     } else {
29         $_[0];
30     }
31 }
32
33 sub install_rooted_dir {
34     if (defined $INSTALL_ROOT) {
35         File::Spec->catdir($INSTALL_ROOT, $_[0]);
36     } else {
37         $_[0];
38     }
39 }
40
41 #our(@EXPORT, @ISA, $Is_VMS);
42 #use strict;
43
44 sub forceunlink {
45     chmod 0666, $_[0];
46     unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
47 }
48
49 sub install {
50     my($hash,$verbose,$nonono,$inc_uninstall) = @_;
51     $verbose ||= 0;
52     $nonono  ||= 0;
53
54     use Cwd qw(cwd);
55     use ExtUtils::Packlist;
56     use File::Basename qw(dirname);
57     use File::Copy qw(copy);
58     use File::Find qw(find);
59     use File::Path qw(mkpath);
60     use File::Compare qw(compare);
61     use File::Spec;
62
63     my(%hash) = %$hash;
64     my(%pack, $dir, $warn_permissions);
65     my($packlist) = ExtUtils::Packlist->new();
66     # -w doesn't work reliably on FAT dirs
67     $warn_permissions++ if $^O eq 'MSWin32';
68     local(*DIR);
69     for (qw/read write/) {
70         $pack{$_}=$hash{$_};
71         delete $hash{$_};
72     }
73     my($source_dir_or_file);
74     foreach $source_dir_or_file (sort keys %hash) {
75         #Check if there are files, and if yes, look if the corresponding
76         #target directory is writable for us
77         opendir DIR, $source_dir_or_file or next;
78         for (readdir DIR) {
79             next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
80                 my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
81             if (-w $targetdir ||
82                 mkpath($targetdir)) {
83                 last;
84             } else {
85                 warn "Warning: You do not have permissions to " .
86                     "install into $hash{$source_dir_or_file}"
87                     unless $warn_permissions++;
88             }
89         }
90         closedir DIR;
91     }
92     my $tmpfile = install_rooted_file($pack{"read"});
93     $packlist->read($tmpfile) if (-f $tmpfile);
94     my $cwd = cwd();
95
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.
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.
107
108         my $targetroot = install_rooted_dir($hash{$source});
109
110         if ($source eq "blib/lib" and
111             exists $hash{"blib/arch"} and
112             directory_not_empty("blib/arch")) {
113             $targetroot = install_rooted_dir($hash{"blib/arch"});
114             print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
115         }
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";
122             my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
123             my $targetfile = File::Spec->catfile($targetdir, $_);
124
125             my $diff = 0;
126             if ( -f $targetfile && -s _ == $size) {
127                 # We have a good chance, we can skip this one
128                 $diff = compare($_,$targetfile);
129             } else {
130                 print "$_ differs\n" if $verbose>1;
131                 $diff++;
132             }
133
134             if ($diff){
135                 if (-f $targetfile){
136                     forceunlink($targetfile) unless $nonono;
137                 } else {
138                     mkpath($targetdir,0,0755) unless $nonono;
139                     print "mkpath($targetdir,0,0755)\n" if $verbose>1;
140                 }
141                 copy($_,$targetfile) unless $nonono;
142                 print "Installing $targetfile\n";
143                 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
144                 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
145                 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
146                 chmod $mode, $targetfile;
147                 print "chmod($mode, $targetfile)\n" if $verbose>1;
148             } else {
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
157             }
158             # Record the full pathname.
159             $packlist->{$targetfile}++;
160
161         }, ".");
162         chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
163     }
164     if ($pack{'write'}) {
165         $dir = install_rooted_dir(dirname($pack{'write'}));
166         mkpath($dir,0,0755);
167         print "Writing $pack{'write'}\n";
168         $packlist->write(install_rooted_file($pack{'write'}));
169     }
170 }
171
172 sub directory_not_empty ($) {
173   my($dir) = @_;
174   my $files = 0;
175   find(sub {
176            return if $_ eq ".exists";
177            if (-f) {
178              $File::Find::prune++;
179              $files = 1;
180            }
181        }, $dir);
182   return $files;
183 }
184
185 sub install_default {
186   @_ < 2 or die "install_default should be called with 0 or 1 argument";
187   my $FULLEXT = @_ ? shift : $ARGV[0];
188   defined $FULLEXT or die "Do not know to where to write install log";
189   my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
190   my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
191   my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
192   my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
193   my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
194   my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
195   install({
196            read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
197            write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
198            $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
199                          $Config{installsitearch} :
200                          $Config{installsitelib},
201            $INST_ARCHLIB => $Config{installsitearch},
202            $INST_BIN => $Config{installbin} ,
203            $INST_SCRIPT => $Config{installscript},
204            $INST_MAN1DIR => $Config{installman1dir},
205            $INST_MAN3DIR => $Config{installman3dir},
206           },1,0,0);
207 }
208
209 sub uninstall {
210     use ExtUtils::Packlist;
211     my($fil,$verbose,$nonono) = @_;
212     die "no packlist file found: $fil" unless -f $fil;
213     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
214     # require $my_req; # Hairy, but for the first
215     my ($packlist) = ExtUtils::Packlist->new($fil);
216     foreach (sort(keys(%$packlist))) {
217         chomp;
218         print "unlink $_\n" if $verbose;
219         forceunlink($_) unless $nonono;
220     }
221     print "unlink $fil\n" if $verbose;
222     forceunlink($fil) unless $nonono;
223 }
224
225 sub inc_uninstall {
226     my($file,$libdir,$verbose,$nonono) = @_;
227     my($dir);
228     my %seen_dir = ();
229     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
230                                                   privlibexp
231                                                   sitearchexp
232                                                   sitelibexp)}) {
233         next if $dir eq ".";
234         next if $seen_dir{$dir}++;
235         my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
236         next unless -f $targetfile;
237
238         # The reason why we compare file's contents is, that we cannot
239         # know, which is the file we just installed (AFS). So we leave
240         # an identical file in place
241         my $diff = 0;
242         if ( -f $targetfile && -s _ == -s $file) {
243             # We have a good chance, we can skip this one
244             $diff = compare($file,$targetfile);
245         } else {
246             print "#$file and $targetfile differ\n" if $verbose>1;
247             $diff++;
248         }
249
250         next unless $diff;
251         if ($nonono) {
252             if ($verbose) {
253                 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
254                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
255                 $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
256             }
257             # if not verbose, we just say nothing
258         } else {
259             print "Unlinking $targetfile (shadowing?)\n";
260             forceunlink($targetfile);
261         }
262     }
263 }
264
265 sub run_filter {
266     my ($cmd, $src, $dest) = @_;
267     open(my $CMD, "|$cmd >$dest") || die "Cannot fork: $!";
268     open(my $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
278 sub pm_to_blib {
279     my($fromto,$autodir,$pm_filter) = @_;
280
281     use File::Basename qw(dirname);
282     use File::Copy qw(copy);
283     use File::Path qw(mkpath);
284     use File::Compare qw(compare);
285     use AutoSplit;
286     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
287     # require $my_req; # Hairy, but for the first
288
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
300     mkpath($autodir,0,0755);
301     foreach (keys %$fromto) {
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";
314             next;
315         }
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";
324         } else {
325             copy($_,$dest);
326             print "cp $_ $dest\n";
327         }
328         my($mode,$atime,$mtime) = (stat)[2,8,9];
329         utime($atime,$mtime+$Is_VMS,$dest);
330         chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
331         next unless /\.pm$/;
332         autosplit($dest,$autodir);
333     }
334 }
335
336 package ExtUtils::Install::Warn;
337
338 sub new { bless {}, shift }
339
340 sub add {
341     my($self,$file,$targetfile) = @_;
342     push @{$self->{$file}}, $targetfile;
343 }
344
345 sub DESTROY {
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";
359         }
360 }
361
362 1;
363
364 __END__
365
366 =head1 NAME
367
368 ExtUtils::Install - install files from here to there
369
370 =head1 SYNOPSIS
371
372 B<use ExtUtils::Install;>
373
374 B<install($hashref,$verbose,$nonono);>
375
376 B<uninstall($packlistfile,$verbose,$nonono);>
377
378 B<pm_to_blib($hashref);>
379
380 =head1 DESCRIPTION
381
382 Both install() and uninstall() are specific to the way
383 ExtUtils::MakeMaker handles the installation and deinstallation of
384 perl modules. They are not designed as general purpose tools.
385
386 install() takes three arguments. A reference to a hash, a verbose
387 switch and a don't-really-do-it switch. The hash ref contains a
388 mapping of directories: each key/value pair is a combination of
389 directories to be copied. Key is a directory to copy from, value is a
390 directory to copy to. The whole tree below the "from" directory will
391 be copied preserving timestamps and permissions.
392
393 There 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
395 target files to the file named by C<$hashref-E<gt>{write}>. If there is
396 another file named by C<$hashref-E<gt>{read}>, the contents of this file will
397 be merged into the written file. The read and the written file may be
398 identical, but on AFS it is quite likely that people are installing to a
399 different directory than the one where the files later appear.
400
401 install_default() takes one or less arguments.  If no arguments are 
402 specified, it takes $ARGV[0] as if it was specified as an argument.  
403 The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.  
404 This function calls install() with the same arguments as the defaults 
405 the MakeMaker would use.
406
407 The argument-less form is convenient for install scripts like
408
409   perl -MExtUtils::Install -e install_default Tk/Canvas
410
411 Assuming this command is executed in a directory with a populated F<blib> 
412 directory, it will proceed as if the F<blib> was build by MakeMaker on 
413 this machine.  This is useful for binary distributions.
414
415 uninstall() takes as first argument a file containing filenames to be
416 unlinked. The second argument is a verbose switch, the third is a
417 no-don't-really-do-it-now switch.
418
419 pm_to_blib() takes a hashref as the first argument and copies all keys
420 of the hash to the corresponding values efficiently. Filenames with
421 the extension pm are autosplit. Second argument is the autosplit
422 directory.  If third argument is not empty, it is taken as a filter command
423 to be ran on each .pm file, the output of the command being what is finally
424 copied, and the source for auto-splitting.
425
426 You can have an environment variable PERL_INSTALL_ROOT set which will
427 be prepended as a directory to each installed file (and directory).
428
429 =cut