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