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