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