lib/ExtUtils/Install.pm

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