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