lib/ExtUtils/Install.pm

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