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