[Summary view] [Print] [Text view]

   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;