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