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