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