lib/ExtUtils/Install.pm

   1 package ExtUtils::Install;
   2
   3 use 5.00503;
   4 use vars qw(@ISA @EXPORT $VERSION);
   5 $VERSION = 1.31;
   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         next if -f $to && -M $to < -M $from;
 429
 430         # When a pm_filter is defined, we need to pre-process the source first
 431         # to determine whether it has changed or not.  Therefore, only perform
 432         # the comparison check when there's no filter to be ran.
 433         #    -- RAM, 03/01/2001
 434
 435         my $need_filtering = defined $pm_filter && length $pm_filter &&
 436                              $from =~ /\.pm$/;
 437
 438         if (!$need_filtering && 0 == compare($from,$to)) {
 439             print "Skip $to (unchanged)\n";
 440             next;
 441         }
 442         if (-f $to){
 443             forceunlink($to);
 444         } else {
 445             mkpath(dirname($to),0,0755);
 446         }
 447         if ($need_filtering) {
 448             run_filter($pm_filter, $from, $to);
 449             print "$pm_filter <$from >$to\n";
 450         } else {
 451             copy($from,$to);
 452             print "cp $from $to\n";
 453         }
 454         my($mode,$atime,$mtime) = (stat $from)[2,8,9];
 455         utime($atime,$mtime+$Is_VMS,$to);
 456         chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
 457         next unless $from =~ /\.pm$/;
 458         _autosplit($to,$autodir);
 459     }
 460 }
 461
 462
 463 =begin _private
 464
 465 =item _autosplit
 466
 467 From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
 468 the file being split.  This causes problems on systems with mandatory
 469 locking (ie. Windows).  So we wrap it and close the filehandle.
 470
 471 =end _private
 472
 473 =cut
 474
 475 sub _autosplit {
 476     my $retval = autosplit(@_);
 477     close *AutoSplit::IN if defined *AutoSplit::IN{IO};
 478
 479     return $retval;
 480 }
 481
 482
 483 package ExtUtils::Install::Warn;
 484
 485 sub new { bless {}, shift }
 486
 487 sub add {
 488     my($self,$file,$targetfile) = @_;
 489     push @{$self->{$file}}, $targetfile;
 490 }
 491
 492 sub DESTROY {
 493     unless(defined $INSTALL_ROOT) {
 494         my $self = shift;
 495         my($file,$i,$plural);
 496         foreach $file (sort keys %$self) {
 497             $plural = @{$self->{$file}} > 1 ? "s" : "";
 498             print "## Differing version$plural of $file found. You might like to\n";
 499             for (0..$#{$self->{$file}}) {
 500                 print "rm ", $self->{$file}[$_], "\n";
 501                 $i++;
 502             }
 503         }
 504         $plural = $i>1 ? "all those files" : "this file";
 505         print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
 506     }
 507 }
 508
 509 =back
 510
 511
 512 =head1 ENVIRONMENT
 513
 514 =over 4
 515
 516 =item B<PERL_INSTALL_ROOT>
 517
 518 Will be prepended to each install path.
 519
 520 =back
 521
 522 =head1 AUTHOR
 523
 524 Original author lost in the mists of time.  Probably the same as Makemaker.
 525
 526 Currently maintained by Michael G Schwern <F<schwern@pobox.com>>
 527
 528 Send patches and ideas to <F<makemaker@perl.org>>.
 529
 530 Send bug reports via http://rt.cpan.org/.  Please send your
 531 generated Makefile along with your report.
 532
 533 For more up-to-date information, see http://www.makemaker.org.
 534
 535
 536 =head1 LICENSE
 537
 538 This program is free software; you can redistribute it and/or
 539 modify it under the same terms as Perl itself.
 540
 541 See F<http://www.perl.com/perl/misc/Artistic.html>
 542
 543
 544 =cut
 545
 546 1;