This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip writable tests in ExtUtils-Install when root
[perl5.git] / dist / ExtUtils-Install / lib / ExtUtils / Install.pm
1 package ExtUtils::Install;
2 use strict;
3
4 use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
5
6 use AutoSplit;
7 use Carp ();
8 use Config qw(%Config);
9 use Cwd qw(cwd);
10 use Exporter;
11 use ExtUtils::Packlist;
12 use File::Basename qw(dirname);
13 use File::Compare qw(compare);
14 use File::Copy;
15 use File::Find qw(find);
16 use File::Path;
17 use File::Spec;
18
19
20 @ISA = ('Exporter');
21 @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
22
23 =pod
24
25 =head1 NAME
26
27 ExtUtils::Install - install files from here to there
28
29 =head1 SYNOPSIS
30
31   use ExtUtils::Install;
32
33   install({ 'blib/lib' => 'some/install/dir' } );
34
35   uninstall($packlist);
36
37   pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
38
39 =head1 VERSION
40
41 1.66
42
43 =cut
44
45 $VERSION = '1.66';  # <-- do not forget to update the POD section just above this line!
46 $VERSION = eval $VERSION;
47
48 =pod
49
50 =head1 DESCRIPTION
51
52 Handles the installing and uninstalling of perl modules, scripts, man
53 pages, etc...
54
55 Both install() and uninstall() are specific to the way
56 ExtUtils::MakeMaker handles the installation and deinstallation of
57 perl modules. They are not designed as general purpose tools.
58
59 On some operating systems such as Win32 installation may not be possible
60 until after a reboot has occurred. This can have varying consequences:
61 removing an old DLL does not impact programs using the new one, but if
62 a new DLL cannot be installed properly until reboot then anything
63 depending on it must wait. The package variable
64
65   $ExtUtils::Install::MUST_REBOOT
66
67 is used to store this status.
68
69 If this variable is true then such an operation has occurred and
70 anything depending on this module cannot proceed until a reboot
71 has occurred.
72
73 If this value is defined but false then such an operation has
74 ocurred, but should not impact later operations.
75
76 =over
77
78 =begin _private
79
80 =item _chmod($$;$)
81
82 Wrapper to chmod() for debugging and error trapping.
83
84 =item _warnonce(@)
85
86 Warns about something only once.
87
88 =item _choke(@)
89
90 Dies with a special message.
91
92 =back
93
94 =end _private
95
96 =cut
97
98 my $Is_VMS     = $^O eq 'VMS';
99 my $Is_MacPerl = $^O eq 'MacOS';
100 my $Is_Win32   = $^O eq 'MSWin32';
101 my $Is_cygwin  = $^O eq 'cygwin';
102 my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);
103
104 # *note* CanMoveAtBoot is only incidentally the same condition as below
105 # this needs not hold true in the future.
106 my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
107     ? (eval {require Win32API::File; 1} || 0)
108     : 0;
109
110
111 my $Inc_uninstall_warn_handler;
112
113 # install relative to here
114
115 my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
116
117 my $Curdir = File::Spec->curdir;
118 my $Updir  = File::Spec->updir;
119
120 sub _estr(@) {
121     return join "\n",'!' x 72,@_,'!' x 72,'';
122 }
123
124 {my %warned;
125 sub _warnonce(@) {
126     my $first=shift;
127     my $msg=_estr "WARNING: $first",@_;
128     warn $msg unless $warned{$msg}++;
129 }}
130
131 sub _choke(@) {
132     my $first=shift;
133     my $msg=_estr "ERROR: $first",@_;
134     Carp::croak($msg);
135 }
136
137
138 sub _chmod($$;$) {
139     my ( $mode, $item, $verbose )=@_;
140     $verbose ||= 0;
141     if (chmod $mode, $item) {
142         printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
143     } else {
144         my $err="$!";
145         _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
146                   $mode, $item, $err
147             if -e $item;
148     }
149 }
150
151 =begin _private
152
153 =over
154
155 =item _move_file_at_boot( $file, $target, $moan  )
156
157 OS-Specific, Win32/Cygwin
158
159 Schedules a file to be moved/renamed/deleted at next boot.
160 $file should be a filespec of an existing file
161 $target should be a ref to an array if the file is to be deleted
162 otherwise it should be a filespec for a rename. If the file is existing
163 it will be replaced.
164
165 Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred
166 and sets it to 1 to indicate that a move operation has been requested.
167
168 returns 1 on success, on failure if $moan is false errors are fatal.
169 If $moan is true then returns 0 on error and warns instead of dies.
170
171 =end _private
172
173 =cut
174
175
176
177 sub _move_file_at_boot { #XXX OS-SPECIFIC
178     my ( $file, $target, $moan  )= @_;
179     Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
180          unless $CanMoveAtBoot;
181
182     my $descr= ref $target
183                 ? "'$file' for deletion"
184                 : "'$file' for installation as '$target'";
185
186     if ( ! $Has_Win32API_File ) {
187
188         my @msg=(
189             "Cannot schedule $descr at reboot.",
190             "Try installing Win32API::File to allow operations on locked files",
191             "to be scheduled during reboot. Or try to perform the operation by",
192             "hand yourself. (You may need to close other perl processes first)"
193         );
194         if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
195         return 0;
196     }
197     my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
198     $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
199         unless ref $target;
200
201     _chmod( 0666, $file );
202     _chmod( 0666, $target ) unless ref $target;
203
204     if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
205         $MUST_REBOOT ||= ref $target ? 0 : 1;
206         return 1;
207     } else {
208         my @msg=(
209             "MoveFileEx $descr at reboot failed: $^E",
210             "You may try to perform the operation by hand yourself. ",
211             "(You may need to close other perl processes first).",
212         );
213         if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
214     }
215     return 0;
216 }
217
218
219 =begin _private
220
221
222 =item _unlink_or_rename( $file, $tryhard, $installing )
223
224 OS-Specific, Win32/Cygwin
225
226 Tries to get a file out of the way by unlinking it or renaming it. On
227 some OS'es (Win32 based) DLL files can end up locked such that they can
228 be renamed but not deleted. Likewise sometimes a file can be locked such
229 that it cant even be renamed or changed except at reboot. To handle
230 these cases this routine finds a tempfile name that it can either rename
231 the file out of the way or use as a proxy for the install so that the
232 rename can happen later (at reboot).
233
234   $file : the file to remove.
235   $tryhard : should advanced tricks be used for deletion
236   $installing : we are not merely deleting but we want to overwrite
237
238 When $tryhard is not true if the unlink fails its fatal. When $tryhard
239 is true then the file is attempted to be renamed. The renamed file is
240 then scheduled for deletion. If the rename fails then $installing
241 governs what happens. If it is false the failure is fatal. If it is true
242 then an attempt is made to schedule installation at boot using a
243 temporary file to hold the new file. If this fails then a fatal error is
244 thrown, if it succeeds it returns the temporary file name (which will be
245 a derivative of the original in the same directory) so that the caller can
246 use it to install under. In all other cases of success returns $file.
247 On failure throws a fatal error.
248
249 =end _private
250
251 =cut
252
253
254
255 sub _unlink_or_rename { #XXX OS-SPECIFIC
256     my ( $file, $tryhard, $installing )= @_;
257
258     # this chmod was originally unconditional. However, its not needed on
259     # POSIXy systems since permission to unlink a file is specified by the
260     # directory rather than the file; and in fact it screwed up hard- and
261     # symlinked files. Keep it for other platforms in case its still
262     # needed there.
263     if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) {
264         _chmod( 0666, $file );
265     }
266     my $unlink_count = 0;
267     while (unlink $file) { $unlink_count++; }
268     return $file if $unlink_count > 0;
269     my $error="$!";
270
271     _choke("Cannot unlink '$file': $!")
272           unless $CanMoveAtBoot && $tryhard;
273
274     my $tmp= "AAA";
275     ++$tmp while -e "$file.$tmp";
276     $tmp= "$file.$tmp";
277
278     warn "WARNING: Unable to unlink '$file': $error\n",
279          "Going to try to rename it to '$tmp'.\n";
280
281     if ( rename $file, $tmp ) {
282         warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n";
283         # when $installing we can set $moan to true.
284         # IOW, if we cant delete the renamed file at reboot its
285         # not the end of the world. The other cases are more serious
286         # and need to be fatal.
287         _move_file_at_boot( $tmp, [], $installing );
288         return $file;
289     } elsif ( $installing ) {
290         _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
291              " installation as '$file' at reboot.\n");
292         _move_file_at_boot( $tmp, $file );
293         return $tmp;
294     } else {
295         _choke("Rename failed:$!", "Cannot proceed.");
296     }
297
298 }
299
300
301 =pod
302
303 =back
304
305 =head2 Functions
306
307 =begin _private
308
309 =over
310
311 =item _get_install_skip
312
313 Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
314
315 =cut
316
317
318
319 sub _get_install_skip {
320     my ( $skip, $verbose )= @_;
321     if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
322         print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
323             if $verbose>2;
324         return [];
325     }
326     if ( ! defined $skip ) {
327         print "Looking for install skip list\n"
328             if $verbose>2;
329         for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
330             next unless $file;
331             print "\tChecking for $file\n"
332                 if $verbose>2;
333             if (-e $file) {
334                 $skip= $file;
335                 last;
336             }
337         }
338     }
339     if ($skip && !ref $skip) {
340         print "Reading skip patterns from '$skip'.\n"
341             if $verbose;
342         if (open my $fh,$skip ) {
343             my @patterns;
344             while (<$fh>) {
345                 chomp;
346                 next if /^\s*(?:#|$)/;
347                 print "\tSkip pattern: $_\n" if $verbose>3;
348                 push @patterns, $_;
349             }
350             $skip= \@patterns;
351         } else {
352             warn "Can't read skip file:'$skip':$!\n";
353             $skip=[];
354         }
355     } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
356         print "Using array for skip list\n"
357             if $verbose>2;
358     } elsif ($verbose) {
359         print "No skip list found.\n"
360             if $verbose>1;
361         $skip= [];
362     }
363     warn "Got @{[0+@$skip]} skip patterns.\n"
364         if $verbose>3;
365     return $skip
366 }
367
368 =pod
369
370 =item _have_write_access
371
372 Abstract a -w check that tries to use POSIX::access() if possible.
373
374 =cut
375
376 {
377     my  $has_posix;
378     sub _have_write_access {
379         my $dir=shift;
380         unless (defined $has_posix) {
381             $has_posix= (!$Is_cygwin && !$Is_Win32
382              && eval 'local $^W; require POSIX; 1') || 0;
383         }
384         if ($has_posix) {
385             return POSIX::access($dir, POSIX::W_OK());
386         } else {
387             return -w $dir;
388         }
389     }
390 }
391
392 =pod
393
394 =item _can_write_dir(C<$dir>)
395
396 Checks whether a given directory is writable, taking account
397 the possibility that the directory might not exist and would have to
398 be created first.
399
400 Returns a list, containing: C<($writable, $determined_by, @create)>
401
402 C<$writable> says whether the directory is (hypothetically) writable
403
404 C<$determined_by> is the directory the status was determined from. It will be
405 either the C<$dir>, or one of its parents.
406
407 C<@create> is a list of directories that would probably have to be created
408 to make the requested directory. It may not actually be correct on
409 relative paths with C<..> in them. But for our purposes it should work ok
410
411 =cut
412
413
414 sub _can_write_dir {
415     my $dir=shift;
416     return
417         unless defined $dir and length $dir;
418
419     my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
420     my @dirs = File::Spec->splitdir($dirs);
421     unshift @dirs, File::Spec->curdir
422         unless File::Spec->file_name_is_absolute($dir);
423
424     my $path='';
425     my @make;
426     while (@dirs) {
427         if ($Is_VMS) {
428             $dir = File::Spec->catdir($vol,@dirs);
429         }
430         else {
431             $dir = File::Spec->catdir(@dirs);
432             $dir = File::Spec->catpath($vol,$dir,'')
433                     if defined $vol and length $vol;
434         }
435         next if ( $dir eq $path );
436         if ( ! -e $dir ) {
437             unshift @make,$dir;
438             next;
439         }
440         if ( _have_write_access($dir) ) {
441             return 1,$dir,@make
442         } else {
443             return 0,$dir,@make
444         }
445     } continue {
446         pop @dirs;
447     }
448     return 0;
449 }
450
451 =pod
452
453 =item _mkpath($dir,$show,$mode,$verbose,$dry_run)
454
455 Wrapper around File::Path::mkpath() to handle errors.
456
457 If $verbose is true and >1 then additional diagnostics will be produced, also
458 this will force $show to true.
459
460 If $dry_run is true then the directory will not be created but a check will be
461 made to see whether it would be possible to write to the directory, or that
462 it would be possible to create the directory.
463
464 If $dry_run is not true dies if the directory can not be created or is not
465 writable.
466
467 =cut
468
469 sub _mkpath {
470     my ($dir,$show,$mode,$verbose,$dry_run)=@_;
471     if ( $verbose && $verbose > 1 && ! -d $dir) {
472         $show= 1;
473         printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
474     }
475     if (!$dry_run) {
476         if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
477             _choke("Can't create '$dir'","$@");
478         }
479
480     }
481     my ($can,$root,@make)=_can_write_dir($dir);
482     if (!$can) {
483         my @msg=(
484             "Can't create '$dir'",
485             $root ? "Do not have write permissions on '$root'"
486                   : "Unknown Error"
487         );
488         if ($dry_run) {
489             _warnonce @msg;
490         } else {
491             _choke @msg;
492         }
493     } elsif ($show and $dry_run) {
494         print "$_\n" for @make;
495     }
496
497 }
498
499 =pod
500
501 =item _copy($from,$to,$verbose,$dry_run)
502
503 Wrapper around File::Copy::copy to handle errors.
504
505 If $verbose is true and >1 then additional diagnostics will be emitted.
506
507 If $dry_run is true then the copy will not actually occur.
508
509 Dies if the copy fails.
510
511 =cut
512
513
514 sub _copy {
515     my ( $from, $to, $verbose, $dry_run)=@_;
516     if ($verbose && $verbose>1) {
517         printf "copy(%s,%s)\n", $from, $to;
518     }
519     if (!$dry_run) {
520         File::Copy::copy($from,$to)
521             or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
522     }
523 }
524
525 =pod
526
527 =item _chdir($from)
528
529 Wrapper around chdir to catch errors.
530
531 If not called in void context returns the cwd from before the chdir.
532
533 dies on error.
534
535 =cut
536
537 sub _chdir {
538     my ($dir)= @_;
539     my $ret;
540     if (defined wantarray) {
541         $ret= cwd;
542     }
543     chdir $dir
544         or _choke("Couldn't chdir to '$dir': $!");
545     return $ret;
546 }
547
548 =pod
549
550 =back
551
552 =end _private
553
554 =over
555
556 =item B<install>
557
558     # deprecated forms
559     install(\%from_to);
560     install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
561                 $skip, $always_copy, \%result);
562
563     # recommended form as of 1.47
564     install([
565         from_to => \%from_to,
566         verbose => 1,
567         dry_run => 0,
568         uninstall_shadows => 1,
569         skip => undef,
570         always_copy => 1,
571         result => \%install_results,
572     ]);
573
574
575 Copies each directory tree of %from_to to its corresponding value
576 preserving timestamps and permissions.
577
578 There are two keys with a special meaning in the hash: "read" and
579 "write".  These contain packlist files.  After the copying is done,
580 install() will write the list of target files to $from_to{write}. If
581 $from_to{read} is given the contents of this file will be merged into
582 the written file. The read and the written file may be identical, but
583 on AFS it is quite likely that people are installing to a different
584 directory than the one where the files later appear.
585
586 If $verbose is true, will print out each file removed.  Default is
587 false.  This is "make install VERBINST=1". $verbose values going
588 up to 5 show increasingly more diagnostics output.
589
590 If $dry_run is true it will only print what it was going to do
591 without actually doing it.  Default is false.
592
593 If $uninstall_shadows is true any differing versions throughout @INC
594 will be uninstalled.  This is "make install UNINST=1"
595
596 As of 1.37_02 install() supports the use of a list of patterns to filter out
597 files that shouldn't be installed. If $skip is omitted or undefined then
598 install will try to read the list from INSTALL.SKIP in the CWD. This file is
599 a list of regular expressions and is just like the MANIFEST.SKIP file used
600 by L<ExtUtils::Manifest>.
601
602 A default site INSTALL.SKIP may be provided by setting then environment
603 variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
604 distribution specific INSTALL.SKIP. If the environment variable
605 EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
606 performed.
607
608 If $skip is undefined then the skip file will be autodetected and used if it
609 is found. If $skip is a reference to an array then it is assumed the array
610 contains the list of patterns, if $skip is a true non reference it is
611 assumed to be the filename holding the list of patterns, any other value of
612 $skip is taken to mean that no install filtering should occur.
613
614 B<Changes As of Version 1.47>
615
616 As of version 1.47 the following additions were made to the install interface.
617 Note that the new argument style and use of the %result hash is recommended.
618
619 The $always_copy parameter which when true causes files to be updated
620 regardless as to whether they have changed, if it is defined but false then
621 copies are made only if the files have changed, if it is undefined then the
622 value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.
623
624 The %result hash will be populated with the various keys/subhashes reflecting
625 the install. Currently these keys and their structure are:
626
627     install             => { $target    => $source },
628     install_fail        => { $target    => $source },
629     install_unchanged   => { $target    => $source },
630
631     install_filtered    => { $source    => $pattern },
632
633     uninstall           => { $uninstalled => $source },
634     uninstall_fail      => { $uninstalled => $source },
635
636 where C<$source> is the filespec of the file being installed. C<$target> is where
637 it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC>
638 or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that
639 caused a source file to be skipped. In future more keys will be added, such as to
640 show created directories, however this requires changes in other modules and must
641 therefore wait.
642
643 These keys will be populated before any exceptions are thrown should there be an
644 error.
645
646 Note that all updates of the %result are additive, the hash will not be
647 cleared before use, thus allowing status results of many installs to be easily
648 aggregated.
649
650 B<NEW ARGUMENT STYLE>
651
652 If there is only one argument and it is a reference to an array then
653 the array is assumed to contain a list of key-value pairs specifying
654 the options. In this case the option "from_to" is mandatory. This style
655 means that you do not have to supply a cryptic list of arguments and can
656 use a self documenting argument list that is easier to understand.
657
658 This is now the recommended interface to install().
659
660 B<RETURN>
661
662 If all actions were successful install will return a hashref of the results
663 as described above for the $result parameter. If any action is a failure
664 then install will die, therefore it is recommended to pass in the $result
665 parameter instead of using the return value. If the result parameter is
666 provided then the returned hashref will be the passed in hashref.
667
668 =cut
669
670 sub install { #XXX OS-SPECIFIC
671     my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_;
672     if (@_==1 and eval { 1+@$from_to }) {
673         my %opts        = @$from_to;
674         $from_to        = $opts{from_to}
675                             or Carp::confess("from_to is a mandatory parameter");
676         $verbose        = $opts{verbose};
677         $dry_run        = $opts{dry_run};
678         $uninstall_shadows  = $opts{uninstall_shadows};
679         $skip           = $opts{skip};
680         $always_copy    = $opts{always_copy};
681         $result         = $opts{result};
682     }
683
684     $result ||= {};
685     $verbose ||= 0;
686     $dry_run  ||= 0;
687
688     $skip= _get_install_skip($skip,$verbose);
689     $always_copy =  $ENV{EU_INSTALL_ALWAYS_COPY}
690                  || $ENV{EU_ALWAYS_COPY}
691                  || 0
692         unless defined $always_copy;
693
694     my(%from_to) = %$from_to;
695     my(%pack, $dir, %warned);
696     my($packlist) = ExtUtils::Packlist->new();
697
698     local(*DIR);
699     for (qw/read write/) {
700         $pack{$_}=$from_to{$_};
701         delete $from_to{$_};
702     }
703     my $tmpfile = install_rooted_file($pack{"read"});
704     $packlist->read($tmpfile) if (-f $tmpfile);
705     my $cwd = cwd();
706     my @found_files;
707     my %check_dirs;
708
709     MOD_INSTALL: foreach my $source (sort keys %from_to) {
710         #copy the tree to the target directory without altering
711         #timestamp and permission and remember for the .packlist
712         #file. The packlist file contains the absolute paths of the
713         #install locations. AFS users may call this a bug. We'll have
714         #to reconsider how to add the means to satisfy AFS users also.
715
716         #October 1997: we want to install .pm files into archlib if
717         #there are any files in arch. So we depend on having ./blib/arch
718         #hardcoded here.
719
720         my $targetroot = install_rooted_dir($from_to{$source});
721
722         my $blib_lib  = File::Spec->catdir('blib', 'lib');
723         my $blib_arch = File::Spec->catdir('blib', 'arch');
724         if ($source eq $blib_lib and
725             exists $from_to{$blib_arch} and
726             directory_not_empty($blib_arch)
727         ){
728             $targetroot = install_rooted_dir($from_to{$blib_arch});
729             print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
730         }
731
732         next unless -d $source;
733         _chdir($source);
734         # 5.5.3's File::Find missing no_chdir option
735         # XXX OS-SPECIFIC
736         # File::Find seems to always be Unixy except on MacPerl :(
737         my $current_directory= $Is_MacPerl ? $Curdir : '.';
738         find(sub {
739             my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
740
741             return if !-f _;
742             my $origfile = $_;
743
744             return if $origfile eq ".exists";
745             my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
746             my $targetfile = File::Spec->catfile($targetdir, $origfile);
747             my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
748             my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
749
750             for my $pat (@$skip) {
751                 if ( $sourcefile=~/$pat/ ) {
752                     print "Skipping $targetfile (filtered)\n"
753                         if $verbose>1;
754                     $result->{install_filtered}{$sourcefile} = $pat;
755                     return;
756                 }
757             }
758             # we have to do this for back compat with old File::Finds
759             # and because the target is relative
760             my $save_cwd = _chdir($cwd);
761             my $diff = 0;
762             # XXX: I wonder how useful this logic is actually -- demerphq
763             if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
764                 $diff++;
765             } else {
766                 # we might not need to copy this file
767                 $diff = compare($sourcefile, $targetfile);
768             }
769             $check_dirs{$targetdir}++
770                 unless -w $targetfile;
771
772             push @found_files,
773                 [ $diff, $File::Find::dir, $origfile,
774                   $mode, $size, $atime, $mtime,
775                   $targetdir, $targetfile, $sourcedir, $sourcefile,
776
777                 ];
778             #restore the original directory we were in when File::Find
779             #called us so that it doesn't get horribly confused.
780             _chdir($save_cwd);
781         }, $current_directory );
782         _chdir($cwd);
783     }
784     foreach my $targetdir (sort keys %check_dirs) {
785         _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
786     }
787     foreach my $found (@found_files) {
788         my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
789             $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
790
791         my $realtarget= $targetfile;
792         if ($diff) {
793             eval {
794                 if (-f $targetfile) {
795                     print "_unlink_or_rename($targetfile)\n" if $verbose>1;
796                     $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
797                         unless $dry_run;
798                 } elsif ( ! -d $targetdir ) {
799                     _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
800                 }
801                 print "Installing $targetfile\n";
802
803                 _copy( $sourcefile, $targetfile, $verbose, $dry_run, );
804
805
806                 #XXX OS-SPECIFIC
807                 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
808                 utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;
809
810
811                 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
812                 $mode = $mode | 0222
813                     if $realtarget ne $targetfile;
814                 _chmod( $mode, $targetfile, $verbose );
815                 $result->{install}{$targetfile} = $sourcefile;
816                 1
817             } or do {
818                 $result->{install_fail}{$targetfile} = $sourcefile;
819                 die $@;
820             };
821         } else {
822             $result->{install_unchanged}{$targetfile} = $sourcefile;
823             print "Skipping $targetfile (unchanged)\n" if $verbose;
824         }
825
826         if ( $uninstall_shadows ) {
827             inc_uninstall($sourcefile,$ffd, $verbose,
828                           $dry_run,
829                           $realtarget ne $targetfile ? $realtarget : "",
830                           $result);
831         }
832
833         # Record the full pathname.
834         $packlist->{$targetfile}++;
835     }
836
837     if ($pack{'write'}) {
838         $dir = install_rooted_dir(dirname($pack{'write'}));
839         _mkpath( $dir, 0, 0755, $verbose, $dry_run );
840         print "Writing $pack{'write'}\n" if $verbose;
841         $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
842     }
843
844     _do_cleanup($verbose);
845     return $result;
846 }
847
848 =begin _private
849
850 =item _do_cleanup
851
852 Standardize finish event for after another instruction has occurred.
853 Handles converting $MUST_REBOOT to a die for instance.
854
855 =end _private
856
857 =cut
858
859 sub _do_cleanup {
860     my ($verbose) = @_;
861     if ($MUST_REBOOT) {
862         die _estr "Operation not completed! ",
863             "You must reboot to complete the installation.",
864             "Sorry.";
865     } elsif (defined $MUST_REBOOT & $verbose) {
866         warn _estr "Installation will be completed at the next reboot.\n",
867              "However it is not necessary to reboot immediately.\n";
868     }
869 }
870
871 =begin _undocumented
872
873 =item install_rooted_file( $file )
874
875 Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
876 is defined.
877
878 =item install_rooted_dir( $dir )
879
880 Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
881 is defined.
882
883 =end _undocumented
884
885 =cut
886
887
888 sub install_rooted_file {
889     if (defined $INSTALL_ROOT) {
890         File::Spec->catfile($INSTALL_ROOT, $_[0]);
891     } else {
892         $_[0];
893     }
894 }
895
896
897 sub install_rooted_dir {
898     if (defined $INSTALL_ROOT) {
899         File::Spec->catdir($INSTALL_ROOT, $_[0]);
900     } else {
901         $_[0];
902     }
903 }
904
905 =begin _undocumented
906
907 =item forceunlink( $file, $tryhard )
908
909 Tries to delete a file. If $tryhard is true then we will use whatever
910 devious tricks we can to delete the file. Currently this only applies to
911 Win32 in that it will try to use Win32API::File to schedule a delete at
912 reboot. A wrapper for _unlink_or_rename().
913
914 =end _undocumented
915
916 =cut
917
918
919 sub forceunlink {
920     my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
921     _unlink_or_rename( $file, $tryhard, not("installing") );
922 }
923
924 =begin _undocumented
925
926 =item directory_not_empty( $dir )
927
928 Returns 1 if there is an .exists file somewhere in a directory tree.
929 Returns 0 if there is not.
930
931 =end _undocumented
932
933 =cut
934
935 sub directory_not_empty ($) {
936   my($dir) = @_;
937   my $files = 0;
938   find(sub {
939            return if $_ eq ".exists";
940            if (-f) {
941              $File::Find::prune++;
942              $files = 1;
943            }
944        }, $dir);
945   return $files;
946 }
947
948 =pod
949
950 =item B<install_default> I<DISCOURAGED>
951
952     install_default();
953     install_default($fullext);
954
955 Calls install() with arguments to copy a module from blib/ to the
956 default site installation location.
957
958 $fullext is the name of the module converted to a directory
959 (ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
960 will attempt to read it from @ARGV.
961
962 This is primarily useful for install scripts.
963
964 B<NOTE> This function is not really useful because of the hard-coded
965 install location with no way to control site vs core vs vendor
966 directories and the strange way in which the module name is given.
967 Consider its use discouraged.
968
969 =cut
970
971 sub install_default {
972   @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
973   my $FULLEXT = @_ ? shift : $ARGV[0];
974   defined $FULLEXT or die "Do not know to where to write install log";
975   my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
976   my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
977   my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
978   my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
979   my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
980   my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
981
982   my @INST_HTML;
983   if($Config{installhtmldir}) {
984       my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html');
985       @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir});
986   }
987
988   install({
989            read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
990            write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
991            $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
992                          $Config{installsitearch} :
993                          $Config{installsitelib},
994            $INST_ARCHLIB => $Config{installsitearch},
995            $INST_BIN => $Config{installbin} ,
996            $INST_SCRIPT => $Config{installscript},
997            $INST_MAN1DIR => $Config{installman1dir},
998            $INST_MAN3DIR => $Config{installman3dir},
999        @INST_HTML,
1000           },1,0,0);
1001 }
1002
1003
1004 =item B<uninstall>
1005
1006     uninstall($packlist_file);
1007     uninstall($packlist_file, $verbose, $dont_execute);
1008
1009 Removes the files listed in a $packlist_file.
1010
1011 If $verbose is true, will print out each file removed.  Default is
1012 false.
1013
1014 If $dont_execute is true it will only print what it was going to do
1015 without actually doing it.  Default is false.
1016
1017 =cut
1018
1019 sub uninstall {
1020     my($fil,$verbose,$dry_run) = @_;
1021     $verbose ||= 0;
1022     $dry_run  ||= 0;
1023
1024     die _estr "ERROR: no packlist file found: '$fil'"
1025         unless -f $fil;
1026     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
1027     # require $my_req; # Hairy, but for the first
1028     my ($packlist) = ExtUtils::Packlist->new($fil);
1029     foreach (sort(keys(%$packlist))) {
1030         chomp;
1031         print "unlink $_\n" if $verbose;
1032         forceunlink($_,'tryhard') unless $dry_run;
1033     }
1034     print "unlink $fil\n" if $verbose;
1035     forceunlink($fil, 'tryhard') unless $dry_run;
1036     _do_cleanup($verbose);
1037 }
1038
1039 =begin _undocumented
1040
1041 =item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
1042
1043 Remove shadowed files. If $ignore is true then it is assumed to hold
1044 a filename to ignore. This is used to prevent spurious warnings from
1045 occurring when doing an install at reboot.
1046
1047 We now only die when failing to remove a file that has precedence over
1048 our own, when our install has precedence we only warn.
1049
1050 $results is assumed to contain a hashref which will have the keys
1051 'uninstall' and 'uninstall_fail' populated with  keys for the files
1052 removed and values of the source files they would shadow.
1053
1054 =end _undocumented
1055
1056 =cut
1057
1058 sub inc_uninstall {
1059     my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
1060     my($dir);
1061     $ignore||="";
1062     my $file = (File::Spec->splitpath($filepath))[2];
1063     my %seen_dir = ();
1064
1065     my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
1066       ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
1067
1068     my @dirs=( @PERL_ENV_LIB,
1069                @INC,
1070                @Config{qw(archlibexp
1071                           privlibexp
1072                           sitearchexp
1073                           sitelibexp)});
1074
1075     #warn join "\n","---",@dirs,"---";
1076     my $seen_ours;
1077     foreach $dir ( @dirs ) {
1078         my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
1079         next if $canonpath eq $Curdir;
1080         next if $seen_dir{$canonpath}++;
1081         my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
1082         next unless -f $targetfile;
1083
1084         # The reason why we compare file's contents is, that we cannot
1085         # know, which is the file we just installed (AFS). So we leave
1086         # an identical file in place
1087         my $diff = 0;
1088         if ( -f $targetfile && -s _ == -s $filepath) {
1089             # We have a good chance, we can skip this one
1090             $diff = compare($filepath,$targetfile);
1091         } else {
1092             $diff++;
1093         }
1094         print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
1095
1096         if (!$diff or $targetfile eq $ignore) {
1097             $seen_ours = 1;
1098             next;
1099         }
1100         if ($dry_run) {
1101             $results->{uninstall}{$targetfile} = $filepath;
1102             if ($verbose) {
1103                 $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
1104                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
1105                 $Inc_uninstall_warn_handler->add(
1106                                      File::Spec->catfile($libdir, $file),
1107                                      $targetfile
1108                                     );
1109             }
1110             # if not verbose, we just say nothing
1111         } else {
1112             print "Unlinking $targetfile (shadowing?)\n" if $verbose;
1113             eval {
1114                 die "Fake die for testing"
1115                     if $ExtUtils::Install::Testing and
1116                        ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
1117                 forceunlink($targetfile,'tryhard');
1118                 $results->{uninstall}{$targetfile} = $filepath;
1119                 1;
1120             } or do {
1121                 $results->{fail_uninstall}{$targetfile} = $filepath;
1122                 if ($seen_ours) {
1123                     warn "Failed to remove probably harmless shadow file '$targetfile'\n";
1124                 } else {
1125                     die "$@\n";
1126                 }
1127             };
1128         }
1129     }
1130 }
1131
1132 =begin _undocumented
1133
1134 =item run_filter($cmd,$src,$dest)
1135
1136 Filter $src using $cmd into $dest.
1137
1138 =end _undocumented
1139
1140 =cut
1141
1142 sub run_filter {
1143     my ($cmd, $src, $dest) = @_;
1144     local(*CMD, *SRC);
1145     open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
1146     open(SRC, $src)           || die "Cannot open $src: $!";
1147     my $buf;
1148     my $sz = 1024;
1149     while (my $len = sysread(SRC, $buf, $sz)) {
1150         syswrite(CMD, $buf, $len);
1151     }
1152     close SRC;
1153     close CMD or die "Filter command '$cmd' failed for $src";
1154 }
1155
1156 =pod
1157
1158 =item B<pm_to_blib>
1159
1160     pm_to_blib(\%from_to, $autosplit_dir);
1161     pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
1162
1163 Copies each key of %from_to to its corresponding value efficiently.
1164 Filenames with the extension .pm are autosplit into the $autosplit_dir.
1165 Any destination directories are created.
1166
1167 $filter_cmd is an optional shell command to run each .pm file through
1168 prior to splitting and copying.  Input is the contents of the module,
1169 output the new module contents.
1170
1171 You can have an environment variable PERL_INSTALL_ROOT set which will
1172 be prepended as a directory to each installed file (and directory).
1173
1174 =cut
1175
1176 sub pm_to_blib {
1177     my($fromto,$autodir,$pm_filter) = @_;
1178
1179     _mkpath($autodir,0,0755);
1180     while(my($from, $to) = each %$fromto) {
1181         if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
1182             print "Skip $to (unchanged)\n";
1183             next;
1184         }
1185
1186         # When a pm_filter is defined, we need to pre-process the source first
1187         # to determine whether it has changed or not.  Therefore, only perform
1188         # the comparison check when there's no filter to be ran.
1189         #    -- RAM, 03/01/2001
1190
1191         my $need_filtering = defined $pm_filter && length $pm_filter &&
1192                              $from =~ /\.pm$/;
1193
1194         if (!$need_filtering && 0 == compare($from,$to)) {
1195             print "Skip $to (unchanged)\n";
1196             next;
1197         }
1198         if (-f $to){
1199             # we wont try hard here. its too likely to mess things up.
1200             forceunlink($to);
1201         } else {
1202             _mkpath(dirname($to),0,0755);
1203         }
1204         if ($need_filtering) {
1205             run_filter($pm_filter, $from, $to);
1206             print "$pm_filter <$from >$to\n";
1207         } else {
1208             _copy( $from, $to );
1209             print "cp $from $to\n";
1210         }
1211         my($mode,$atime,$mtime) = (stat $from)[2,8,9];
1212         utime($atime,$mtime+$Is_VMS,$to);
1213         _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
1214         next unless $from =~ /\.pm$/;
1215         _autosplit($to,$autodir);
1216     }
1217 }
1218
1219
1220 =begin _private
1221
1222 =item _autosplit
1223
1224 From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
1225 the file being split.  This causes problems on systems with mandatory
1226 locking (ie. Windows).  So we wrap it and close the filehandle.
1227
1228 =end _private
1229
1230 =cut
1231
1232 sub _autosplit { #XXX OS-SPECIFIC
1233     my $retval = autosplit(@_);
1234     close *AutoSplit::IN if defined *AutoSplit::IN{IO};
1235
1236     return $retval;
1237 }
1238
1239
1240 package ExtUtils::Install::Warn;
1241
1242 sub new { bless {}, shift }
1243
1244 sub add {
1245     my($self,$file,$targetfile) = @_;
1246     push @{$self->{$file}}, $targetfile;
1247 }
1248
1249 sub DESTROY {
1250     unless(defined $INSTALL_ROOT) {
1251         my $self = shift;
1252         my($file,$i,$plural);
1253         foreach $file (sort keys %$self) {
1254             $plural = @{$self->{$file}} > 1 ? "s" : "";
1255             print "## Differing version$plural of $file found. You might like to\n";
1256             for (0..$#{$self->{$file}}) {
1257                 print "rm ", $self->{$file}[$_], "\n";
1258                 $i++;
1259             }
1260         }
1261         $plural = $i>1 ? "all those files" : "this file";
1262         my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
1263                  ? ( $Config::Config{make} || 'make' ).' install'
1264                      . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
1265                  : './Build install uninst=1';
1266         print "## Running '$inst' will unlink $plural for you.\n";
1267     }
1268 }
1269
1270 =begin _private
1271
1272 =item _invokant
1273
1274 Does a heuristic on the stack to see who called us for more intelligent
1275 error messages. Currently assumes we will be called only by Module::Build
1276 or by ExtUtils::MakeMaker.
1277
1278 =end _private
1279
1280 =cut
1281
1282 sub _invokant {
1283     my @stack;
1284     my $frame = 0;
1285     while (my $file = (caller($frame++))[1]) {
1286         push @stack, (File::Spec->splitpath($file))[2];
1287     }
1288
1289     my $builder;
1290     my $top = pop @stack;
1291     if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
1292         $builder = 'Module::Build';
1293     } else {
1294         $builder = 'ExtUtils::MakeMaker';
1295     }
1296     return $builder;
1297 }
1298
1299 =pod
1300
1301 =back
1302
1303 =head1 ENVIRONMENT
1304
1305 =over 4
1306
1307 =item B<PERL_INSTALL_ROOT>
1308
1309 Will be prepended to each install path.
1310
1311 =item B<EU_INSTALL_IGNORE_SKIP>
1312
1313 Will prevent the automatic use of INSTALL.SKIP as the install skip file.
1314
1315 =item B<EU_INSTALL_SITE_SKIPFILE>
1316
1317 If there is no INSTALL.SKIP file in the make directory then this value
1318 can be used to provide a default.
1319
1320 =item B<EU_INSTALL_ALWAYS_COPY>
1321
1322 If this environment variable is true then normal install processes will
1323 always overwrite older identical files during the install process.
1324
1325 Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
1326 is not defined until at least the 1.50 release. Please ensure you use the
1327 correct EU_INSTALL_ALWAYS_COPY.
1328
1329 =back
1330
1331 =head1 AUTHOR
1332
1333 Original author lost in the mists of time.  Probably the same as Makemaker.
1334
1335 Production release currently maintained by demerphq C<yves at cpan.org>,
1336 extensive changes by Michael G. Schwern.
1337
1338 Send bug reports via http://rt.cpan.org/.  Please send your
1339 generated Makefile along with your report.
1340
1341 =head1 LICENSE
1342
1343 This program is free software; you can redistribute it and/or
1344 modify it under the same terms as Perl itself.
1345
1346 See L<http://www.perl.com/perl/misc/Artistic.html>
1347
1348
1349 =cut
1350
1351 1;