lib/ExtUtils/Install.pm

   1 package ExtUtils::Install;
   2
   3 use 5.00503;
   4 use vars qw(@ISA @EXPORT $VERSION);
   5 $VERSION = '1.33_01';
   6
   7 use Exporter;
   8 use Carp ();
   9 use Config qw(%Config);
  10 @ISA = ('Exporter');
  11 @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
  12 $Is_VMS     = $^O eq 'VMS';
  13 $Is_MacPerl = $^O eq 'MacOS';
  14
  15 my $Inc_uninstall_warn_handler;
  16
  17 # install relative to here
  18
  19 my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
  20
  21 use File::Spec;
  22 my $Curdir = File::Spec->curdir;
  23 my $Updir  = File::Spec->updir;
  24
  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
  41 =head1 DESCRIPTION
  42
  43 Handles the installing and uninstalling of perl modules, scripts, man
  44 pages, etc...
  45
  46 Both install() and uninstall() are specific to the way
  47 ExtUtils::MakeMaker handles the installation and deinstallation of
  48 perl modules. They are not designed as general purpose tools.
  49
  50 =head2 Functions
  51
  52 =over 4
  53
  54 =item B<install>
  55
  56     install(\%from_to);
  57     install(\%from_to, $verbose, $dont_execute, $uninstall_shadows);
  58
  59 Copies each directory tree of %from_to to its corresponding value
  60 preserving timestamps and permissions.
  61
  62 There are two keys with a special meaning in the hash: "read" and
  63 "write".  These contain packlist files.  After the copying is done,
  64 install() will write the list of target files to $from_to{write}. If
  65 $from_to{read} is given the contents of this file will be merged into
  66 the written file. The read and the written file may be identical, but
  67 on AFS it is quite likely that people are installing to a different
  68 directory than the one where the files later appear.
  69
  70 If $verbose is true, will print out each file removed.  Default is
  71 false.  This is "make install VERBINST=1"
  72
  73 If $dont_execute is true it will only print what it was going to do
  74 without actually doing it.  Default is false.
  75
  76 If $uninstall_shadows is true any differing versions throughout @INC
  77 will be uninstalled.  This is "make install UNINST=1"
  78
  79 =cut
  80
  81 sub install {
  82     my($from_to,$verbose,$nonono,$inc_uninstall) = @_;
  83     $verbose ||= 0;
  84     $nonono  ||= 0;
  85
  86     use Cwd qw(cwd);
  87     use ExtUtils::Packlist;
  88     use File::Basename qw(dirname);
  89     use File::Copy qw(copy);
  90     use File::Find qw(find);
  91     use File::Path qw(mkpath);
  92     use File::Compare qw(compare);
  93
  94     my $win32_special=!$nonono &&
  95                       $^O eq 'MSWin32' &&
  96                       eval { require Win32API::File; 1 };
  97     my(%from_to) = %$from_to;
  98     my(%pack, $dir, $warn_permissions);
  99     my($packlist) = ExtUtils::Packlist->new();
 100     # -w doesn't work reliably on FAT dirs
 101     $warn_permissions++ if $^O eq 'MSWin32';
 102     local(*DIR);
 103     for (qw/read write/) {
 104         $pack{$_}=$from_to{$_};
 105         delete $from_to{$_};
 106     }
 107     my($source_dir_or_file);
 108     foreach $source_dir_or_file (sort keys %from_to) {
 109         #Check if there are files, and if yes, look if the corresponding
 110         #target directory is writable for us
 111         opendir DIR, $source_dir_or_file or next;
 112         for (readdir DIR) {
 113             next if $_ eq $Curdir || $_ eq $Updir || $_ eq ".exists";
 114             my $targetdir = install_rooted_dir($from_to{$source_dir_or_file});
 115             mkpath($targetdir) unless $nonono;
 116             if (!$nonono && !-w $targetdir) {
 117                 warn "Warning: You do not have permissions to " .
 118                     "install into $from_to{$source_dir_or_file}"
 119                     unless $warn_permissions++;
 120             }
 121         }
 122         closedir DIR;
 123     }
 124     my $tmpfile = install_rooted_file($pack{"read"});
 125     $packlist->read($tmpfile) if (-f $tmpfile);
 126     my $cwd = cwd();
 127
 128     MOD_INSTALL: foreach my $source (sort keys %from_to) {
 129         #copy the tree to the target directory without altering
 130         #timestamp and permission and remember for the .packlist
 131         #file. The packlist file contains the absolute paths of the
 132         #install locations. AFS users may call this a bug. We'll have
 133         #to reconsider how to add the means to satisfy AFS users also.
 134
 135         #October 1997: we want to install .pm files into archlib if
 136         #there are any files in arch. So we depend on having ./blib/arch
 137         #hardcoded here.
 138
 139         my $targetroot = install_rooted_dir($from_to{$source});
 140
 141         my $blib_lib  = File::Spec->catdir('blib', 'lib');
 142         my $blib_arch = File::Spec->catdir('blib', 'arch');
 143         if ($source eq $blib_lib and
 144             exists $from_to{$blib_arch} and
 145             directory_not_empty($blib_arch)) {
 146             $targetroot = install_rooted_dir($from_to{$blib_arch});
 147             print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
 148         }
 149
 150         chdir $source or next;
 151         find(sub {
 152             my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
 153             return unless -f _;
 154
 155             my $origfile = $_;
 156             return if $origfile eq ".exists";
 157             my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
 158             my $targetfile = File::Spec->catfile($targetdir, $origfile);
 159             my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
 160             my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
 161
 162             my $save_cwd = cwd;
 163             chdir $cwd;  # in case the target is relative
 164                          # 5.5.3's File::Find missing no_chdir option.
 165
 166             my $diff = 0;
 167             if ( -f $targetfile && -s _ == $size) {
 168                 # We have a good chance, we can skip this one
 169                 $diff = compare($sourcefile, $targetfile);
 170             } else {
 171                 print "$sourcefile differs\n" if $verbose>1;
 172                 $diff++;
 173             }
 174
 175             if ($diff) {
 176                 if ($win32_special && -f $targetfile && !unlink $targetfile) {
 177                     print "Can't remove existing '$targetfile': $!\n";
 178                     my $tmp = "AAA";
 179                     ++$tmp while -e "$targetfile.$tmp";
 180                     $tmp= "$targetfile.$tmp";
 181                     if ( rename $targetfile, $tmp ) {
 182                         print "However it has been renamed as '$tmp' which ".
 183                               "will be removed at next reboot.\n";
 184                         Win32API::File::MoveFileEx( $tmp, [],
 185                             Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT() )
 186                             or die "MoveFileEx/Delete '$tmp' failed: $^E\n";
 187                     } else {
 188                         print "Installation cannot be completed until you reboot.\n",
 189                               "Until then using '$tmp' as the install filename.\n";
 190                         Win32API::File::MoveFileEx( $tmp, $targetfile,
 191                             Win32API::File::MOVEFILE_REPLACE_EXISTING() |
 192                             Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT() )
 193                             or die "MoveFileEx/Replace '$tmp' failed: $^E\n";
 194                         $targetfile = $tmp;
 195                     }
 196                 } elsif (-f $targetfile) {
 197                     forceunlink($targetfile) unless $nonono;
 198                 } else {
 199                     mkpath($targetdir,0,0755) unless $nonono;
 200                     print "mkpath($targetdir,0,0755)\n" if $verbose>1;
 201                 }
 202                 copy($sourcefile, $targetfile) unless $nonono;
 203                 print "Installing $targetfile\n";
 204                 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
 205                 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
 206                 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
 207                 chmod $mode, $targetfile;
 208                 print "chmod($mode, $targetfile)\n" if $verbose>1;
 209             } else {
 210                 print "Skipping $targetfile (unchanged)\n" if $verbose;
 211             }
 212
 213             if (defined $inc_uninstall) {
 214                 inc_uninstall($sourcefile,$File::Find::dir,$verbose,
 215                               $inc_uninstall ? 0 : 1);
 216             }
 217
 218             # Record the full pathname.
 219             $packlist->{$targetfile}++;
 220
 221             # File::Find can get confused if you chdir in here.
 222             chdir $save_cwd;
 223
 224         # File::Find seems to always be Unixy except on MacPerl :(
 225         }, $Is_MacPerl ? $Curdir : '.' );
 226         chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
 227     }
 228     if ($pack{'write'}) {
 229         $dir = install_rooted_dir(dirname($pack{'write'}));
 230         mkpath($dir,0,0755) unless $nonono;
 231         print "Writing $pack{'write'}\n";
 232         $packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
 233     }
 234 }
 235
 236 sub install_rooted_file {
 237     if (defined $INSTALL_ROOT) {
 238         File::Spec->catfile($INSTALL_ROOT, $_[0]);
 239     } else {
 240         $_[0];
 241     }
 242 }
 243
 244
 245 sub install_rooted_dir {
 246     if (defined $INSTALL_ROOT) {
 247         File::Spec->catdir($INSTALL_ROOT, $_[0]);
 248     } else {
 249         $_[0];
 250     }
 251 }
 252
 253
 254 sub forceunlink {
 255     chmod 0666, $_[0];
 256     unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
 257 }
 258
 259
 260 sub directory_not_empty ($) {
 261   my($dir) = @_;
 262   my $files = 0;
 263   find(sub {
 264            return if $_ eq ".exists";
 265            if (-f) {
 266              $File::Find::prune++;
 267              $files = 1;
 268            }
 269        }, $dir);
 270   return $files;
 271 }
 272
 273
 274 =item B<install_default> I<DISCOURAGED>
 275
 276     install_default();
 277     install_default($fullext);
 278
 279 Calls install() with arguments to copy a module from blib/ to the
 280 default site installation location.
 281
 282 $fullext is the name of the module converted to a directory
 283 (ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
 284 will attempt to read it from @ARGV.
 285
 286 This is primarily useful for install scripts.
 287
 288 B<NOTE> This function is not really useful because of the hard-coded
 289 install location with no way to control site vs core vs vendor
 290 directories and the strange way in which the module name is given.
 291 Consider its use discouraged.
 292
 293 =cut
 294
 295 sub install_default {
 296   @_ < 2 or die "install_default should be called with 0 or 1 argument";
 297   my $FULLEXT = @_ ? shift : $ARGV[0];
 298   defined $FULLEXT or die "Do not know to where to write install log";
 299   my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
 300   my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
 301   my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
 302   my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
 303   my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
 304   my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
 305   install({
 306            read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
 307            write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
 308            $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
 309                          $Config{installsitearch} :
 310                          $Config{installsitelib},
 311            $INST_ARCHLIB => $Config{installsitearch},
 312            $INST_BIN => $Config{installbin} ,
 313            $INST_SCRIPT => $Config{installscript},
 314            $INST_MAN1DIR => $Config{installman1dir},
 315            $INST_MAN3DIR => $Config{installman3dir},
 316           },1,0,0);
 317 }
 318
 319
 320 =item B<uninstall>
 321
 322     uninstall($packlist_file);
 323     uninstall($packlist_file, $verbose, $dont_execute);
 324
 325 Removes the files listed in a $packlist_file.
 326
 327 If $verbose is true, will print out each file removed.  Default is
 328 false.
 329
 330 If $dont_execute is true it will only print what it was going to do
 331 without actually doing it.  Default is false.
 332
 333 =cut
 334
 335 sub uninstall {
 336     use ExtUtils::Packlist;
 337     my($fil,$verbose,$nonono) = @_;
 338     $verbose ||= 0;
 339     $nonono  ||= 0;
 340
 341     die "no packlist file found: $fil" unless -f $fil;
 342     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
 343     # require $my_req; # Hairy, but for the first
 344     my ($packlist) = ExtUtils::Packlist->new($fil);
 345     foreach (sort(keys(%$packlist))) {
 346         chomp;
 347         print "unlink $_\n" if $verbose;
 348         forceunlink($_) unless $nonono;
 349     }
 350     print "unlink $fil\n" if $verbose;
 351     forceunlink($fil) unless $nonono;
 352 }
 353
 354 sub inc_uninstall {
 355     my($filepath,$libdir,$verbose,$nonono) = @_;
 356     my($dir);
 357     my $file = (File::Spec->splitpath($filepath))[2];
 358     my %seen_dir = ();
 359
 360     my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
 361       ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
 362
 363     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
 364                                                   privlibexp
 365                                                   sitearchexp
 366                                                   sitelibexp)}) {
 367         next if $dir eq $Curdir;
 368         next if $seen_dir{$dir}++;
 369         my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
 370         next unless -f $targetfile;
 371
 372         # The reason why we compare file's contents is, that we cannot
 373         # know, which is the file we just installed (AFS). So we leave
 374         # an identical file in place
 375         my $diff = 0;
 376         if ( -f $targetfile && -s _ == -s $filepath) {
 377             # We have a good chance, we can skip this one
 378             $diff = compare($filepath,$targetfile);
 379         } else {
 380             print "#$file and $targetfile differ\n" if $verbose>1;
 381             $diff++;
 382         }
 383
 384         next unless $diff;
 385         if ($nonono) {
 386             if ($verbose) {
 387                 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
 388                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
 389                 $Inc_uninstall_warn_handler->add(
 390                                      File::Spec->catfile($libdir, $file),
 391                                      $targetfile
 392                                     );
 393             }
 394             # if not verbose, we just say nothing
 395         } else {
 396             print "Unlinking $targetfile (shadowing?)\n";
 397             forceunlink($targetfile);
 398         }
 399     }
 400 }
 401
 402 sub run_filter {
 403     my ($cmd, $src, $dest) = @_;
 404     local(*CMD, *SRC);
 405     open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
 406     open(SRC, $src)           || die "Cannot open $src: $!";
 407     my $buf;
 408     my $sz = 1024;
 409     while (my $len = sysread(SRC, $buf, $sz)) {
 410         syswrite(CMD, $buf, $len);
 411     }
 412     close SRC;
 413     close CMD or die "Filter command '$cmd' failed for $src";
 414 }
 415
 416
 417 =item B<pm_to_blib>
 418
 419     pm_to_blib(\%from_to, $autosplit_dir);
 420     pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
 421
 422 Copies each key of %from_to to its corresponding value efficiently.
 423 Filenames with the extension .pm are autosplit into the $autosplit_dir.
 424 Any destination directories are created.
 425
 426 $filter_cmd is an optional shell command to run each .pm file through
 427 prior to splitting and copying.  Input is the contents of the module,
 428 output the new module contents.
 429
 430 You can have an environment variable PERL_INSTALL_ROOT set which will
 431 be prepended as a directory to each installed file (and directory).
 432
 433 =cut
 434
 435 sub pm_to_blib {
 436     my($fromto,$autodir,$pm_filter) = @_;
 437
 438     use File::Basename qw(dirname);
 439     use File::Copy qw(copy);
 440     use File::Path qw(mkpath);
 441     use File::Compare qw(compare);
 442     use AutoSplit;
 443
 444     mkpath($autodir,0,0755);
 445     while(my($from, $to) = each %$fromto) {
 446         if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
 447             print "Skip $to (unchanged)\n";
 448             next;
 449         }
 450
 451         # When a pm_filter is defined, we need to pre-process the source first
 452         # to determine whether it has changed or not.  Therefore, only perform
 453         # the comparison check when there's no filter to be ran.
 454         #    -- RAM, 03/01/2001
 455
 456         my $need_filtering = defined $pm_filter && length $pm_filter &&
 457                              $from =~ /\.pm$/;
 458
 459         if (!$need_filtering && 0 == compare($from,$to)) {
 460             print "Skip $to (unchanged)\n";
 461             next;
 462         }
 463         if (-f $to){
 464             forceunlink($to);
 465         } else {
 466             mkpath(dirname($to),0,0755);
 467         }
 468         if ($need_filtering) {
 469             run_filter($pm_filter, $from, $to);
 470             print "$pm_filter <$from >$to\n";
 471         } else {
 472             copy($from,$to);
 473             print "cp $from $to\n";
 474         }
 475         my($mode,$atime,$mtime) = (stat $from)[2,8,9];
 476         utime($atime,$mtime+$Is_VMS,$to);
 477         chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
 478         next unless $from =~ /\.pm$/;
 479         _autosplit($to,$autodir);
 480     }
 481 }
 482
 483
 484 =begin _private
 485
 486 =item _autosplit
 487
 488 From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
 489 the file being split.  This causes problems on systems with mandatory
 490 locking (ie. Windows).  So we wrap it and close the filehandle.
 491
 492 =end _private
 493
 494 =cut
 495
 496 sub _autosplit {
 497     my $retval = autosplit(@_);
 498     close *AutoSplit::IN if defined *AutoSplit::IN{IO};
 499
 500     return $retval;
 501 }
 502
 503
 504 package ExtUtils::Install::Warn;
 505
 506 sub new { bless {}, shift }
 507
 508 sub add {
 509     my($self,$file,$targetfile) = @_;
 510     push @{$self->{$file}}, $targetfile;
 511 }
 512
 513 sub DESTROY {
 514     unless(defined $INSTALL_ROOT) {
 515         my $self = shift;
 516         my($file,$i,$plural);
 517         foreach $file (sort keys %$self) {
 518             $plural = @{$self->{$file}} > 1 ? "s" : "";
 519             print "## Differing version$plural of $file found. You might like to\n";
 520             for (0..$#{$self->{$file}}) {
 521                 print "rm ", $self->{$file}[$_], "\n";
 522                 $i++;
 523             }
 524         }
 525         $plural = $i>1 ? "all those files" : "this file";
 526         print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
 527     }
 528 }
 529
 530 =back
 531
 532
 533 =head1 ENVIRONMENT
 534
 535 =over 4
 536
 537 =item B<PERL_INSTALL_ROOT>
 538
 539 Will be prepended to each install path.
 540
 541 =back
 542
 543 =head1 AUTHOR
 544
 545 Original author lost in the mists of time.  Probably the same as Makemaker.
 546
 547 Currently maintained by Michael G Schwern C<schwern@pobox.com>
 548
 549 Send patches and ideas to C<makemaker@perl.org>.
 550
 551 Send bug reports via http://rt.cpan.org/.  Please send your
 552 generated Makefile along with your report.
 553
 554 For more up-to-date information, see L<http://www.makemaker.org>.
 555
 556
 557 =head1 LICENSE
 558
 559 This program is free software; you can redistribute it and/or
 560 modify it under the same terms as Perl itself.
 561
 562 See L<http://www.perl.com/perl/misc/Artistic.html>
 563
 564
 565 =cut
 566
 567 1;