lib/ExtUtils/Install.pm

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