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