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