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