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