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