84a616ca618be92e3e98fcfbc4d18dd77dfb4707
[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.45';
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(File::Spec->rel2abs($dir),1);
435     my @dirs = File::Spec->splitdir($dirs);
436     my $path='';
437     my @make;
438     while (@dirs) {
439         $dir = File::Spec->catdir(@dirs);
440         $dir = File::Spec->catpath($vol,$dir,'') 
441                 if defined $vol and length $vol;
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 =item _mkpath($dir,$show,$mode,$verbose,$fake)
459
460 Wrapper around File::Path::mkpath() to handle errors.
461
462 If $verbose is true and >1 then additional diagnostics will be produced, also
463 this will force $show to true.
464
465 If $fake is true then the directory will not be created but a check will be
466 made to see whether it would be possible to write to the directory, or that
467 it would be possible to create the directory.
468
469 If $fake is not true dies if the directory can not be created or is not
470 writable.
471
472 =cut
473
474 sub _mkpath {
475     my ($dir,$show,$mode,$verbose,$fake)=@_;
476     if ( $verbose && $verbose > 1 && ! -d $dir) {
477         $show= 1;
478         printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
479     }
480     if (!$fake) {
481         if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
482             _choke("Can't create '$dir'","$@");
483         }
484
485     }
486     my ($can,$root,@make)=_can_write_dir($dir);
487     if (!$can) {
488         my @msg=(
489             "Can't create '$dir'",
490             $root ? "Do not have write permissions on '$root'"
491                   : "Unknown Error"
492         );
493         if ($fake) {
494             _warnonce @msg;
495         } else {
496             _choke @msg;
497         }
498     } elsif ($show and $fake) {
499         print "$_\n" for @make;
500     }
501 }
502
503 =item _copy($from,$to,$verbose,$fake)
504
505 Wrapper around File::Copy::copy to handle errors.
506
507 If $verbose is true and >1 then additional dignostics will be emitted.
508
509 If $fake is true then the copy will not actually occur.
510
511 Dies if the copy fails.
512
513 =cut
514
515
516 sub _copy {
517     my ( $from, $to, $verbose, $nonono)=@_;
518     if ($verbose && $verbose>1) {
519         printf "copy(%s,%s)\n", $from, $to;
520     }
521     if (!$nonono) {
522         File::Copy::copy($from,$to)
523             or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
524     }
525 }
526
527 =item _chdir($from)
528
529 Wrapper around chdir to catch errors.
530
531 If not called in void context returns the cwd from before the chdir.
532
533 dies on error.
534
535 =cut
536
537 sub _chdir {
538     my ($dir)= @_;
539     my $ret;
540     if (defined wantarray) {
541         $ret= cwd;
542     }
543     chdir $dir
544         or _choke("Couldn't chdir to '$dir': $!");
545     return $ret;
546 }
547
548 =end _private
549
550 =cut
551
552 sub install { #XXX OS-SPECIFIC
553     my($from_to,$verbose,$nonono,$inc_uninstall,$skip) = @_;
554     $verbose ||= 0;
555     $nonono  ||= 0;
556
557     $skip= _get_install_skip($skip,$verbose);
558
559     my(%from_to) = %$from_to;
560     my(%pack, $dir, %warned);
561     my($packlist) = ExtUtils::Packlist->new();
562
563     local(*DIR);
564     for (qw/read write/) {
565         $pack{$_}=$from_to{$_};
566         delete $from_to{$_};
567     }
568     my $tmpfile = install_rooted_file($pack{"read"});
569     $packlist->read($tmpfile) if (-f $tmpfile);
570     my $cwd = cwd();
571     my @found_files;
572     my %check_dirs;
573     
574     MOD_INSTALL: foreach my $source (sort keys %from_to) {
575         #copy the tree to the target directory without altering
576         #timestamp and permission and remember for the .packlist
577         #file. The packlist file contains the absolute paths of the
578         #install locations. AFS users may call this a bug. We'll have
579         #to reconsider how to add the means to satisfy AFS users also.
580
581         #October 1997: we want to install .pm files into archlib if
582         #there are any files in arch. So we depend on having ./blib/arch
583         #hardcoded here.
584
585         my $targetroot = install_rooted_dir($from_to{$source});
586
587         my $blib_lib  = File::Spec->catdir('blib', 'lib');
588         my $blib_arch = File::Spec->catdir('blib', 'arch');
589         if ($source eq $blib_lib and
590             exists $from_to{$blib_arch} and
591             directory_not_empty($blib_arch)
592         ){
593             $targetroot = install_rooted_dir($from_to{$blib_arch});
594             print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
595         }
596
597         next unless -d $source;
598         _chdir($source);
599         # 5.5.3's File::Find missing no_chdir option
600         # XXX OS-SPECIFIC
601         # File::Find seems to always be Unixy except on MacPerl :(
602         my $current_directory= $Is_MacPerl ? $Curdir : '.';
603         find(sub {
604             my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
605
606             return if !-f _;
607             my $origfile = $_;
608
609             return if $origfile eq ".exists";
610             my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
611             my $targetfile = File::Spec->catfile($targetdir, $origfile);
612             my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
613             my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
614
615             for my $pat (@$skip) {
616                 if ( $sourcefile=~/$pat/ ) {
617                     print "Skipping $targetfile (filtered)\n"
618                         if $verbose>1;
619                     return;
620                 }
621             }
622             # we have to do this for back compat with old File::Finds
623             # and because the target is relative
624             my $save_cwd = _chdir($cwd); 
625             my $diff = 0;
626             if ( -f $targetfile && -s _ == $size) {
627                 # We have a good chance, we can skip this one
628                 $diff = compare($sourcefile, $targetfile);
629             } else {
630                 $diff++;
631             }
632             $check_dirs{$targetdir}++ 
633                 unless -w $targetfile;
634             
635             push @found_files,
636                 [ $diff, $File::Find::dir, $origfile,
637                   $mode, $size, $atime, $mtime,
638                   $targetdir, $targetfile, $sourcedir, $sourcefile,
639                   
640                 ];  
641             #restore the original directory we were in when File::Find
642             #called us so that it doesnt get horribly confused.
643             _chdir($save_cwd);                
644         }, $current_directory ); 
645         _chdir($cwd);
646     }   
647     
648     foreach my $targetdir (sort keys %check_dirs) {
649         _mkpath( $targetdir, 0, 0755, $verbose, $nonono );
650     }
651     foreach my $found (@found_files) {
652         my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
653             $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
654         
655         my $realtarget= $targetfile;
656         if ($diff) {
657             if (-f $targetfile) {
658                 print "_unlink_or_rename($targetfile)\n" if $verbose>1;
659                 $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
660                     unless $nonono;
661             } elsif ( ! -d $targetdir ) {
662                 _mkpath( $targetdir, 0, 0755, $verbose, $nonono );
663             }
664             print "Installing $targetfile\n";
665             _copy( $sourcefile, $targetfile, $verbose, $nonono, );
666             #XXX OS-SPECIFIC
667             print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
668             utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
669
670
671             $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
672             $mode = $mode | 0222
673                 if $realtarget ne $targetfile;
674             _chmod( $mode, $targetfile, $verbose );
675         } else {
676             print "Skipping $targetfile (unchanged)\n" if $verbose;
677         }
678
679         if ( $inc_uninstall ) {
680             inc_uninstall($sourcefile,$ffd, $verbose,
681                           $nonono,
682                           $realtarget ne $targetfile ? $realtarget : "");
683         }
684
685         # Record the full pathname.
686         $packlist->{$targetfile}++;
687     }
688
689     if ($pack{'write'}) {
690         $dir = install_rooted_dir(dirname($pack{'write'}));
691         _mkpath( $dir, 0, 0755, $verbose, $nonono );
692         print "Writing $pack{'write'}\n";
693         $packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
694     }
695
696     _do_cleanup($verbose);
697 }
698
699 =begin _private
700
701 =item _do_cleanup
702
703 Standardize finish event for after another instruction has occured.
704 Handles converting $MUST_REBOOT to a die for instance.
705
706 =end _private
707
708 =cut
709
710 sub _do_cleanup {
711     my ($verbose) = @_;
712     if ($MUST_REBOOT) {
713         die _estr "Operation not completed! ",
714             "You must reboot to complete the installation.",
715             "Sorry.";
716     } elsif (defined $MUST_REBOOT & $verbose) {
717         warn _estr "Installation will be completed at the next reboot.\n",
718              "However it is not necessary to reboot immediately.\n";
719     }
720 }
721
722 =begin _undocumented
723
724 =item install_rooted_file( $file )
725
726 Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
727 is defined.
728
729 =item install_rooted_dir( $dir )
730
731 Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
732 is defined.
733
734 =end _undocumented
735
736 =cut
737
738
739 sub install_rooted_file {
740     if (defined $INSTALL_ROOT) {
741         File::Spec->catfile($INSTALL_ROOT, $_[0]);
742     } else {
743         $_[0];
744     }
745 }
746
747
748 sub install_rooted_dir {
749     if (defined $INSTALL_ROOT) {
750         File::Spec->catdir($INSTALL_ROOT, $_[0]);
751     } else {
752         $_[0];
753     }
754 }
755
756 =begin _undocumented
757
758 =item forceunlink( $file, $tryhard )
759
760 Tries to delete a file. If $tryhard is true then we will use whatever
761 devious tricks we can to delete the file. Currently this only applies to
762 Win32 in that it will try to use Win32API::File to schedule a delete at
763 reboot. A wrapper for _unlink_or_rename().
764
765 =end _undocumented
766
767 =cut
768
769
770 sub forceunlink {
771     my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
772     _unlink_or_rename( $file, $tryhard );
773 }
774
775 =begin _undocumented
776
777 =item directory_not_empty( $dir )
778
779 Returns 1 if there is an .exists file somewhere in a directory tree.
780 Returns 0 if there is not.
781
782 =end _undocumented
783
784 =cut
785
786 sub directory_not_empty ($) {
787   my($dir) = @_;
788   my $files = 0;
789   find(sub {
790            return if $_ eq ".exists";
791            if (-f) {
792              $File::Find::prune++;
793              $files = 1;
794            }
795        }, $dir);
796   return $files;
797 }
798
799
800 =item B<install_default> I<DISCOURAGED>
801
802     install_default();
803     install_default($fullext);
804
805 Calls install() with arguments to copy a module from blib/ to the
806 default site installation location.
807
808 $fullext is the name of the module converted to a directory
809 (ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
810 will attempt to read it from @ARGV.
811
812 This is primarily useful for install scripts.
813
814 B<NOTE> This function is not really useful because of the hard-coded
815 install location with no way to control site vs core vs vendor
816 directories and the strange way in which the module name is given.
817 Consider its use discouraged.
818
819 =cut
820
821 sub install_default {
822   @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
823   my $FULLEXT = @_ ? shift : $ARGV[0];
824   defined $FULLEXT or die "Do not know to where to write install log";
825   my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
826   my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
827   my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
828   my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
829   my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
830   my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
831   install({
832            read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
833            write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
834            $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
835                          $Config{installsitearch} :
836                          $Config{installsitelib},
837            $INST_ARCHLIB => $Config{installsitearch},
838            $INST_BIN => $Config{installbin} ,
839            $INST_SCRIPT => $Config{installscript},
840            $INST_MAN1DIR => $Config{installman1dir},
841            $INST_MAN3DIR => $Config{installman3dir},
842           },1,0,0);
843 }
844
845
846 =item B<uninstall>
847
848     uninstall($packlist_file);
849     uninstall($packlist_file, $verbose, $dont_execute);
850
851 Removes the files listed in a $packlist_file.
852
853 If $verbose is true, will print out each file removed.  Default is
854 false.
855
856 If $dont_execute is true it will only print what it was going to do
857 without actually doing it.  Default is false.
858
859 =cut
860
861 sub uninstall {
862     my($fil,$verbose,$nonono) = @_;
863     $verbose ||= 0;
864     $nonono  ||= 0;
865
866     die _estr "ERROR: no packlist file found: '$fil'"
867         unless -f $fil;
868     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
869     # require $my_req; # Hairy, but for the first
870     my ($packlist) = ExtUtils::Packlist->new($fil);
871     foreach (sort(keys(%$packlist))) {
872         chomp;
873         print "unlink $_\n" if $verbose;
874         forceunlink($_,'tryhard') unless $nonono;
875     }
876     print "unlink $fil\n" if $verbose;
877     forceunlink($fil, 'tryhard') unless $nonono;
878     _do_cleanup($verbose);
879 }
880
881 =begin _undocumented
882
883 =item inc_uninstall($filepath,$libdir,$verbose,$nonono,$ignore)
884
885 Remove shadowed files. If $ignore is true then it is assumed to hold
886 a filename to ignore. This is used to prevent spurious warnings from
887 occuring when doing an install at reboot.
888
889 =end _undocumented
890
891 =cut
892
893 sub inc_uninstall {
894     my($filepath,$libdir,$verbose,$nonono,$ignore) = @_;
895     my($dir);
896     $ignore||="";
897     my $file = (File::Spec->splitpath($filepath))[2];
898     my %seen_dir = ();
899
900     my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
901       ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
902
903     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
904                                                   privlibexp
905                                                   sitearchexp
906                                                   sitelibexp)}) {
907         my $canonpath = File::Spec->canonpath($dir);
908         next if $canonpath eq $Curdir;
909         next if $seen_dir{$canonpath}++;
910         my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
911         next unless -f $targetfile;
912
913         # The reason why we compare file's contents is, that we cannot
914         # know, which is the file we just installed (AFS). So we leave
915         # an identical file in place
916         my $diff = 0;
917         if ( -f $targetfile && -s _ == -s $filepath) {
918             # We have a good chance, we can skip this one
919             $diff = compare($filepath,$targetfile);
920         } else {
921             $diff++;
922         }
923         print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
924
925         next if !$diff or $targetfile eq $ignore;
926         if ($nonono) {
927             if ($verbose) {
928                 $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
929                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
930                 $Inc_uninstall_warn_handler->add(
931                                      File::Spec->catfile($libdir, $file),
932                                      $targetfile
933                                     );
934             }
935             # if not verbose, we just say nothing
936         } else {
937             print "Unlinking $targetfile (shadowing?)\n" if $verbose;
938             forceunlink($targetfile,'tryhard');
939         }
940     }
941 }
942
943 =begin _undocumented
944
945 =item run_filter($cmd,$src,$dest)
946
947 Filter $src using $cmd into $dest.
948
949 =end _undocumented
950
951 =cut
952
953 sub run_filter {
954     my ($cmd, $src, $dest) = @_;
955     local(*CMD, *SRC);
956     open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
957     open(SRC, $src)           || die "Cannot open $src: $!";
958     my $buf;
959     my $sz = 1024;
960     while (my $len = sysread(SRC, $buf, $sz)) {
961         syswrite(CMD, $buf, $len);
962     }
963     close SRC;
964     close CMD or die "Filter command '$cmd' failed for $src";
965 }
966
967
968 =item B<pm_to_blib>
969
970     pm_to_blib(\%from_to, $autosplit_dir);
971     pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
972
973 Copies each key of %from_to to its corresponding value efficiently.
974 Filenames with the extension .pm are autosplit into the $autosplit_dir.
975 Any destination directories are created.
976
977 $filter_cmd is an optional shell command to run each .pm file through
978 prior to splitting and copying.  Input is the contents of the module,
979 output the new module contents.
980
981 You can have an environment variable PERL_INSTALL_ROOT set which will
982 be prepended as a directory to each installed file (and directory).
983
984 =cut
985
986 sub pm_to_blib {
987     my($fromto,$autodir,$pm_filter) = @_;
988
989     _mkpath($autodir,0,0755);
990     while(my($from, $to) = each %$fromto) {
991         if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
992             print "Skip $to (unchanged)\n";
993             next;
994         }
995
996         # When a pm_filter is defined, we need to pre-process the source first
997         # to determine whether it has changed or not.  Therefore, only perform
998         # the comparison check when there's no filter to be ran.
999         #    -- RAM, 03/01/2001
1000
1001         my $need_filtering = defined $pm_filter && length $pm_filter &&
1002                              $from =~ /\.pm$/;
1003
1004         if (!$need_filtering && 0 == compare($from,$to)) {
1005             print "Skip $to (unchanged)\n";
1006             next;
1007         }
1008         if (-f $to){
1009             # we wont try hard here. its too likely to mess things up.
1010             forceunlink($to);
1011         } else {
1012             _mkpath(dirname($to),0,0755);
1013         }
1014         if ($need_filtering) {
1015             run_filter($pm_filter, $from, $to);
1016             print "$pm_filter <$from >$to\n";
1017         } else {
1018             _copy( $from, $to );
1019             print "cp $from $to\n";
1020         }
1021         my($mode,$atime,$mtime) = (stat $from)[2,8,9];
1022         utime($atime,$mtime+$Is_VMS,$to);
1023         _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
1024         next unless $from =~ /\.pm$/;
1025         _autosplit($to,$autodir);
1026     }
1027 }
1028
1029
1030 =begin _private
1031
1032 =item _autosplit
1033
1034 From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
1035 the file being split.  This causes problems on systems with mandatory
1036 locking (ie. Windows).  So we wrap it and close the filehandle.
1037
1038 =end _private
1039
1040 =cut
1041
1042 sub _autosplit { #XXX OS-SPECIFIC
1043     my $retval = autosplit(@_);
1044     close *AutoSplit::IN if defined *AutoSplit::IN{IO};
1045
1046     return $retval;
1047 }
1048
1049
1050 package ExtUtils::Install::Warn;
1051
1052 sub new { bless {}, shift }
1053
1054 sub add {
1055     my($self,$file,$targetfile) = @_;
1056     push @{$self->{$file}}, $targetfile;
1057 }
1058
1059 sub DESTROY {
1060     unless(defined $INSTALL_ROOT) {
1061         my $self = shift;
1062         my($file,$i,$plural);
1063         foreach $file (sort keys %$self) {
1064             $plural = @{$self->{$file}} > 1 ? "s" : "";
1065             print "## Differing version$plural of $file found. You might like to\n";
1066             for (0..$#{$self->{$file}}) {
1067                 print "rm ", $self->{$file}[$_], "\n";
1068                 $i++;
1069             }
1070         }
1071         $plural = $i>1 ? "all those files" : "this file";
1072         my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
1073                  ? ( $Config::Config{make} || 'make' ).' install UNINST=1'
1074                  : './Build install uninst=1';
1075         print "## Running '$inst' will unlink $plural for you.\n";
1076     }
1077 }
1078
1079 =begin _private
1080
1081 =item _invokant
1082
1083 Does a heuristic on the stack to see who called us for more intelligent
1084 error messages. Currently assumes we will be called only by Module::Build
1085 or by ExtUtils::MakeMaker.
1086
1087 =end _private
1088
1089 =cut
1090
1091 sub _invokant {
1092     my @stack;
1093     my $frame = 0;
1094     while (my $file = (caller($frame++))[1]) {
1095         push @stack, (File::Spec->splitpath($file))[2];
1096     }
1097
1098     my $builder;
1099     my $top = pop @stack;
1100     if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
1101         $builder = 'Module::Build';
1102     } else {
1103         $builder = 'ExtUtils::MakeMaker';
1104     }
1105     return $builder;
1106 }
1107
1108
1109 =back
1110
1111 =head1 ENVIRONMENT
1112
1113 =over 4
1114
1115 =item B<PERL_INSTALL_ROOT>
1116
1117 Will be prepended to each install path.
1118
1119 =item B<EU_INSTALL_IGNORE_SKIP>
1120
1121 Will prevent the automatic use of INSTALL.SKIP as the install skip file.
1122
1123 =item B<EU_INSTALL_SITE_SKIPFILE>
1124
1125 If there is no INSTALL.SKIP file in the make directory then this value
1126 can be used to provide a default.
1127
1128 =back
1129
1130 =head1 AUTHOR
1131
1132 Original author lost in the mists of time.  Probably the same as Makemaker.
1133
1134 Production release currently maintained by demerphq C<yves at cpan.org>
1135
1136 Send bug reports via http://rt.cpan.org/.  Please send your
1137 generated Makefile along with your report.
1138
1139 =head1 LICENSE
1140
1141 This program is free software; you can redistribute it and/or
1142 modify it under the same terms as Perl itself.
1143
1144 See L<http://www.perl.com/perl/misc/Artistic.html>
1145
1146
1147 =cut
1148
1149 1;