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