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