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