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