contrib/perl5/lib/ExtUtils/Install.pm

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