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