lib/ExtUtils/Install.pm

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