lib/ExtUtils/Install.pm

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