dist/ExtUtils-Install/lib/ExtUtils/Install.pm

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