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