lib/ExtUtils/Install.pm

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