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