lib/ExtUtils/Install.pm

   1 package ExtUtils::Install;
   2
   3 use 5.005_64;
   4 our(@ISA, @EXPORT, $VERSION);
   5 $VERSION = substr q$Revision: 1.28 $, 10;
   6 # $Date: 1998/01/25 07:08:24 $
   7
   8 use Exporter;
   9 use Carp ();
  10 use Config qw(%Config);
  11 @ISA = ('Exporter');
  12 @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
  13 $Is_VMS = $^O eq 'VMS';
  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
  25 sub install_rooted_file {
  26     if (defined $INSTALL_ROOT) {
  27         MY->catfile($INSTALL_ROOT, $_[0]);
  28     } else {
  29         $_[0];
  30     }
  31 }
  32
  33 sub install_rooted_dir {
  34     if (defined $INSTALL_ROOT) {
  35         MY->catdir($INSTALL_ROOT, $_[0]);
  36     } else {
  37         $_[0];
  38     }
  39 }
  40
  41 #our(@EXPORT, @ISA, $Is_VMS);
  42 #use strict;
  43
  44 sub forceunlink {
  45     chmod 0666, $_[0];
  46     unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
  47 }
  48
  49 sub install {
  50     my($hash,$verbose,$nonono,$inc_uninstall) = @_;
  51     $verbose ||= 0;
  52     $nonono  ||= 0;
  53
  54     use Cwd qw(cwd);
  55     use ExtUtils::MakeMaker; # to implement a MY class
  56     use ExtUtils::Packlist;
  57     use File::Basename qw(dirname);
  58     use File::Copy qw(copy);
  59     use File::Find qw(find);
  60     use File::Path qw(mkpath);
  61     use File::Compare qw(compare);
  62
  63     my(%hash) = %$hash;
  64     my(%pack, $dir, $warn_permissions);
  65     my($packlist) = ExtUtils::Packlist->new();
  66     # -w doesn't work reliably on FAT dirs
  67     $warn_permissions++ if $^O eq 'MSWin32';
  68     local(*DIR);
  69     for (qw/read write/) {
  70         $pack{$_}=$hash{$_};
  71         delete $hash{$_};
  72     }
  73     my($source_dir_or_file);
  74     foreach $source_dir_or_file (sort keys %hash) {
  75         #Check if there are files, and if yes, look if the corresponding
  76         #target directory is writable for us
  77         opendir DIR, $source_dir_or_file or next;
  78         for (readdir DIR) {
  79             next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
  80                 my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
  81             if (-w $targetdir ||
  82                 mkpath($targetdir)) {
  83                 last;
  84             } else {
  85                 warn "Warning: You do not have permissions to " .
  86                     "install into $hash{$source_dir_or_file}"
  87                     unless $warn_permissions++;
  88             }
  89         }
  90         closedir DIR;
  91     }
  92     my $tmpfile = install_rooted_file($pack{"read"});
  93     $packlist->read($tmpfile) if (-f $tmpfile);
  94     my $cwd = cwd();
  95
  96     my($source);
  97     MOD_INSTALL: foreach $source (sort keys %hash) {
  98         #copy the tree to the target directory without altering
  99         #timestamp and permission and remember for the .packlist
 100         #file. The packlist file contains the absolute paths of the
 101         #install locations. AFS users may call this a bug. We'll have
 102         #to reconsider how to add the means to satisfy AFS users also.
 103
 104         #October 1997: we want to install .pm files into archlib if
 105         #there are any files in arch. So we depend on having ./blib/arch
 106         #hardcoded here.
 107
 108         my $targetroot = install_rooted_dir($hash{$source});
 109
 110         if ($source eq "blib/lib" and
 111             exists $hash{"blib/arch"} and
 112             directory_not_empty("blib/arch")) {
 113             $targetroot = install_rooted_dir($hash{"blib/arch"});
 114             print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
 115         }
 116         chdir($source) or next;
 117         find(sub {
 118             my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 119                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
 120             return unless -f _;
 121             return if $_ eq ".exists";
 122             my $targetdir  = MY->catdir($targetroot, $File::Find::dir);
 123             my $origfile   = $_;
 124             my $targetfile = MY->catfile($targetdir, $_);
 125
 126             my $diff = 0;
 127             if ( -f $targetfile && -s _ == $size) {
 128                 # We have a good chance, we can skip this one
 129                 $diff = compare($_,$targetfile);
 130             } else {
 131                 print "$_ differs\n" if $verbose>1;
 132                 $diff++;
 133             }
 134
 135             if ($diff){
 136                 if (-f $targetfile){
 137                     forceunlink($targetfile) unless $nonono;
 138                 } else {
 139                     mkpath($targetdir,0,0755) unless $nonono;
 140                     print "mkpath($targetdir,0,0755)\n" if $verbose>1;
 141                 }
 142                 copy($_,$targetfile) unless $nonono;
 143                 print "Installing $targetfile\n";
 144                 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
 145                 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
 146                 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
 147                 chmod $mode, $targetfile;
 148                 print "chmod($mode, $targetfile)\n" if $verbose>1;
 149             } else {
 150                 print "Skipping $targetfile (unchanged)\n" if $verbose;
 151             }
 152
 153             if (! defined $inc_uninstall) { # it's called
 154             } elsif ($inc_uninstall == 0){
 155                 inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
 156             } else {
 157                 inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
 158             }
 159             $packlist->{$origfile}++;
 160
 161         }, ".");
 162         chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
 163     }
 164     if ($pack{'write'}) {
 165         $dir = install_rooted_dir(dirname($pack{'write'}));
 166         mkpath($dir,0,0755);
 167         print "Writing $pack{'write'}\n";
 168         $packlist->write(install_rooted_file($pack{'write'}));
 169     }
 170 }
 171
 172 sub directory_not_empty ($) {
 173   my($dir) = @_;
 174   my $files = 0;
 175   find(sub {
 176            return if $_ eq ".exists";
 177            if (-f) {
 178              $File::Find::prune++;
 179              $files = 1;
 180            }
 181        }, $dir);
 182   return $files;
 183 }
 184
 185 sub install_default {
 186   @_ < 2 or die "install_default should be called with 0 or 1 argument";
 187   my $FULLEXT = @_ ? shift : $ARGV[0];
 188   defined $FULLEXT or die "Do not know to where to write install log";
 189   my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
 190   my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
 191   my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
 192   my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
 193   my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
 194   my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
 195   install({
 196            read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
 197            write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
 198            $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
 199                          $Config{installsitearch} :
 200                          $Config{installsitelib},
 201            $INST_ARCHLIB => $Config{installsitearch},
 202            $INST_BIN => $Config{installbin} ,
 203            $INST_SCRIPT => $Config{installscript},
 204            $INST_MAN1DIR => $Config{installman1dir},
 205            $INST_MAN3DIR => $Config{installman3dir},
 206           },1,0,0);
 207 }
 208
 209 sub uninstall {
 210     use ExtUtils::Packlist;
 211     my($fil,$verbose,$nonono) = @_;
 212     die "no packlist file found: $fil" unless -f $fil;
 213     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
 214     # require $my_req; # Hairy, but for the first
 215     my ($packlist) = ExtUtils::Packlist->new($fil);
 216     foreach (sort(keys(%$packlist))) {
 217         chomp;
 218         print "unlink $_\n" if $verbose;
 219         forceunlink($_) unless $nonono;
 220     }
 221     print "unlink $fil\n" if $verbose;
 222     forceunlink($fil) unless $nonono;
 223 }
 224
 225 sub inc_uninstall {
 226     my($file,$libdir,$verbose,$nonono) = @_;
 227     my($dir);
 228     my %seen_dir = ();
 229     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
 230                                                   privlibexp
 231                                                   sitearchexp
 232                                                   sitelibexp)}) {
 233         next if $dir eq ".";
 234         next if $seen_dir{$dir}++;
 235         my($targetfile) = MY->catfile($dir,$libdir,$file);
 236         next unless -f $targetfile;
 237
 238         # The reason why we compare file's contents is, that we cannot
 239         # know, which is the file we just installed (AFS). So we leave
 240         # an identical file in place
 241         my $diff = 0;
 242         if ( -f $targetfile && -s _ == -s $file) {
 243             # We have a good chance, we can skip this one
 244             $diff = compare($file,$targetfile);
 245         } else {
 246             print "#$file and $targetfile differ\n" if $verbose>1;
 247             $diff++;
 248         }
 249
 250         next unless $diff;
 251         if ($nonono) {
 252             if ($verbose) {
 253                 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
 254                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
 255                 $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
 256             }
 257             # if not verbose, we just say nothing
 258         } else {
 259             print "Unlinking $targetfile (shadowing?)\n";
 260             forceunlink($targetfile);
 261         }
 262     }
 263 }
 264
 265 sub run_filter {
 266     my ($cmd, $src, $dest) = @_;
 267     local *SRC, *CMD;
 268     open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
 269     open(SRC, $src)           || die "Cannot open $src: $!";
 270     my $buf;
 271     my $sz = 1024;
 272     while (my $len = sysread(SRC, $buf, $sz)) {
 273         syswrite(CMD, $buf, $len);
 274     }
 275     close SRC;
 276     close CMD or die "Filter command '$cmd' failed for $src";
 277 }
 278
 279 sub pm_to_blib {
 280     my($fromto,$autodir,$pm_filter) = @_;
 281
 282     use File::Basename qw(dirname);
 283     use File::Copy qw(copy);
 284     use File::Path qw(mkpath);
 285     use File::Compare qw(compare);
 286     use AutoSplit;
 287     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
 288     # require $my_req; # Hairy, but for the first
 289
 290     if (!ref($fromto) && -r $fromto)
 291      {
 292       # Win32 has severe command line length limitations, but
 293       # can generate temporary files on-the-fly
 294       # so we pass name of file here - eval it to get hash
 295       open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
 296       my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
 297       eval $str;
 298       close(FROMTO);
 299      }
 300
 301     mkpath($autodir,0,0755);
 302     foreach (keys %$fromto) {
 303         my $dest = $fromto->{$_};
 304         next if -f $dest && -M $dest < -M $_;
 305
 306         # When a pm_filter is defined, we need to pre-process the source first
 307         # to determine whether it has changed or not.  Therefore, only perform
 308         # the comparison check when there's no filter to be ran.
 309         #    -- RAM, 03/01/2001
 310
 311         my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;
 312
 313         if (!$need_filtering && 0 == compare($_,$dest)) {
 314             print "Skip $dest (unchanged)\n";
 315             next;
 316         }
 317         if (-f $dest){
 318             forceunlink($dest);
 319         } else {
 320             mkpath(dirname($dest),0,0755);
 321         }
 322         if ($need_filtering) {
 323             run_filter($pm_filter, $_, $dest);
 324             print "$pm_filter <$_ >$dest\n";
 325         } else {
 326             copy($_,$dest);
 327             print "cp $_ $dest\n";
 328         }
 329         my($mode,$atime,$mtime) = (stat)[2,8,9];
 330         utime($atime,$mtime+$Is_VMS,$dest);
 331         chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
 332         next unless /\.pm$/;
 333         autosplit($dest,$autodir);
 334     }
 335 }
 336
 337 package ExtUtils::Install::Warn;
 338
 339 sub new { bless {}, shift }
 340
 341 sub add {
 342     my($self,$file,$targetfile) = @_;
 343     push @{$self->{$file}}, $targetfile;
 344 }
 345
 346 sub DESTROY {
 347         unless(defined $INSTALL_ROOT) {
 348                 my $self = shift;
 349                 my($file,$i,$plural);
 350                 foreach $file (sort keys %$self) {
 351                 $plural = @{$self->{$file}} > 1 ? "s" : "";
 352                 print "## Differing version$plural of $file found. You might like to\n";
 353                 for (0..$#{$self->{$file}}) {
 354                         print "rm ", $self->{$file}[$_], "\n";
 355                         $i++;
 356                 }
 357                 }
 358                 $plural = $i>1 ? "all those files" : "this file";
 359                 print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
 360         }
 361 }
 362
 363 1;
 364
 365 __END__
 366
 367 =head1 NAME
 368
 369 ExtUtils::Install - install files from here to there
 370
 371 =head1 SYNOPSIS
 372
 373 B<use ExtUtils::Install;>
 374
 375 B<install($hashref,$verbose,$nonono);>
 376
 377 B<uninstall($packlistfile,$verbose,$nonono);>
 378
 379 B<pm_to_blib($hashref);>
 380
 381 =head1 DESCRIPTION
 382
 383 Both install() and uninstall() are specific to the way
 384 ExtUtils::MakeMaker handles the installation and deinstallation of
 385 perl modules. They are not designed as general purpose tools.
 386
 387 install() takes three arguments. A reference to a hash, a verbose
 388 switch and a don't-really-do-it switch. The hash ref contains a
 389 mapping of directories: each key/value pair is a combination of
 390 directories to be copied. Key is a directory to copy from, value is a
 391 directory to copy to. The whole tree below the "from" directory will
 392 be copied preserving timestamps and permissions.
 393
 394 There are two keys with a special meaning in the hash: "read" and
 395 "write". After the copying is done, install will write the list of
 396 target files to the file named by C<$hashref-E<gt>{write}>. If there is
 397 another file named by C<$hashref-E<gt>{read}>, the contents of this file will
 398 be merged into the written file. The read and the written file may be
 399 identical, but on AFS it is quite likely that people are installing to a
 400 different directory than the one where the files later appear.
 401
 402 install_default() takes one or less arguments.  If no arguments are
 403 specified, it takes $ARGV[0] as if it was specified as an argument.
 404 The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
 405 This function calls install() with the same arguments as the defaults
 406 the MakeMaker would use.
 407
 408 The argument-less form is convenient for install scripts like
 409
 410   perl -MExtUtils::Install -e install_default Tk/Canvas
 411
 412 Assuming this command is executed in a directory with a populated F<blib>
 413 directory, it will proceed as if the F<blib> was build by MakeMaker on
 414 this machine.  This is useful for binary distributions.
 415
 416 uninstall() takes as first argument a file containing filenames to be
 417 unlinked. The second argument is a verbose switch, the third is a
 418 no-don't-really-do-it-now switch.
 419
 420 pm_to_blib() takes a hashref as the first argument and copies all keys
 421 of the hash to the corresponding values efficiently. Filenames with
 422 the extension pm are autosplit. Second argument is the autosplit
 423 directory.  If third argument is not empty, it is taken as a filter command
 424 to be ran on each .pm file, the output of the command being what is finally
 425 copied, and the source for auto-splitting.
 426
 427 You can have an environment variable PERL_INSTALL_ROOT set which will
 428 be prepended as a directory to each installed file (and directory).
 429
 430 =cut