lib/ExtUtils/Install.pm

   1 package ExtUtils::Install;
   2
   3 use 5.005_64;
   4 our(@ISA, @EXPORT, $VERSION);
   5 $VERSION = substr q$Revision: 1.28 $, 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 #our(@EXPORT, @ISA, $Is_VMS);
  20 #use strict;
  21
  22 sub forceunlink {
  23     chmod 0666, $_[0];
  24     unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
  25 }
  26
  27 sub install {
  28     my($hash,$verbose,$nonono,$inc_uninstall) = @_;
  29     $verbose ||= 0;
  30     $nonono  ||= 0;
  31
  32     use Cwd qw(cwd);
  33     use ExtUtils::MakeMaker; # to implement a MY class
  34     use ExtUtils::Packlist;
  35     use File::Basename qw(dirname);
  36     use File::Copy qw(copy);
  37     use File::Find qw(find);
  38     use File::Path qw(mkpath);
  39     use File::Compare qw(compare);
  40
  41     my(%hash) = %$hash;
  42     my(%pack, $dir, $warn_permissions);
  43     my($packlist) = ExtUtils::Packlist->new();
  44     # -w doesn't work reliably on FAT dirs
  45     $warn_permissions++ if $^O eq 'MSWin32';
  46     local(*DIR);
  47     for (qw/read write/) {
  48         $pack{$_}=$hash{$_};
  49         delete $hash{$_};
  50     }
  51     my($source_dir_or_file);
  52     foreach $source_dir_or_file (sort keys %hash) {
  53         #Check if there are files, and if yes, look if the corresponding
  54         #target directory is writable for us
  55         opendir DIR, $source_dir_or_file or next;
  56         for (readdir DIR) {
  57             next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
  58             if (-w $hash{$source_dir_or_file} ||
  59                 mkpath($hash{$source_dir_or_file})) {
  60                 last;
  61             } else {
  62                 warn "Warning: You do not have permissions to " .
  63                     "install into $hash{$source_dir_or_file}"
  64                     unless $warn_permissions++;
  65             }
  66         }
  67         closedir DIR;
  68     }
  69     $packlist->read($pack{"read"}) if (-f $pack{"read"});
  70     my $cwd = cwd();
  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 }
 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     forceunlink($fil) unless $nonono;
 196 }
 197
 198 sub inc_uninstall {
 199     my($file,$libdir,$verbose,$nonono) = @_;
 200     my($dir);
 201     my %seen_dir = ();
 202     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
 203                                                   privlibexp
 204                                                   sitearchexp
 205                                                   sitelibexp)}) {
 206         next if $dir eq ".";
 207         next if $seen_dir{$dir}++;
 208         my($targetfile) = MY->catfile($dir,$libdir,$file);
 209         next unless -f $targetfile;
 210
 211         # The reason why we compare file's contents is, that we cannot
 212         # know, which is the file we just installed (AFS). So we leave
 213         # an identical file in place
 214         my $diff = 0;
 215         if ( -f $targetfile && -s _ == -s $file) {
 216             # We have a good chance, we can skip this one
 217             $diff = compare($file,$targetfile);
 218         } else {
 219             print "#$file and $targetfile differ\n" if $verbose>1;
 220             $diff++;
 221         }
 222
 223         next unless $diff;
 224         if ($nonono) {
 225             if ($verbose) {
 226                 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
 227                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
 228                 $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
 229             }
 230             # if not verbose, we just say nothing
 231         } else {
 232             print "Unlinking $targetfile (shadowing?)\n";
 233             forceunlink($targetfile);
 234         }
 235     }
 236 }
 237
 238 sub pm_to_blib {
 239     my($fromto,$autodir) = @_;
 240
 241     use File::Basename qw(dirname);
 242     use File::Copy qw(copy);
 243     use File::Path qw(mkpath);
 244     use File::Compare qw(compare);
 245     use AutoSplit;
 246     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
 247     # require $my_req; # Hairy, but for the first
 248
 249     if (!ref($fromto) && -r $fromto)
 250      {
 251       # Win32 has severe command line length limitations, but
 252       # can generate temporary files on-the-fly
 253       # so we pass name of file here - eval it to get hash
 254       open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
 255       my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
 256       eval $str;
 257       close(FROMTO);
 258      }
 259
 260     mkpath($autodir,0,0755);
 261     foreach (keys %$fromto) {
 262         next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
 263         unless (compare($_,$fromto->{$_})){
 264             print "Skip $fromto->{$_} (unchanged)\n";
 265             next;
 266         }
 267         if (-f $fromto->{$_}){
 268             forceunlink($fromto->{$_});
 269         } else {
 270             mkpath(dirname($fromto->{$_}),0,0755);
 271         }
 272         copy($_,$fromto->{$_});
 273         my($mode,$atime,$mtime) = (stat)[2,8,9];
 274         utime($atime,$mtime+$Is_VMS,$fromto->{$_});
 275         chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
 276         print "cp $_ $fromto->{$_}\n";
 277         next unless /\.pm\z/;
 278         autosplit($fromto->{$_},$autodir);
 279     }
 280 }
 281
 282 package ExtUtils::Install::Warn;
 283
 284 sub new { bless {}, shift }
 285
 286 sub add {
 287     my($self,$file,$targetfile) = @_;
 288     push @{$self->{$file}}, $targetfile;
 289 }
 290
 291 sub DESTROY {
 292     my $self = shift;
 293     my($file,$i,$plural);
 294     foreach $file (sort keys %$self) {
 295         $plural = @{$self->{$file}} > 1 ? "s" : "";
 296         print "## Differing version$plural of $file found. You might like to\n";
 297         for (0..$#{$self->{$file}}) {
 298             print "rm ", $self->{$file}[$_], "\n";
 299             $i++;
 300         }
 301     }
 302     $plural = $i>1 ? "all those files" : "this file";
 303     print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
 304 }
 305
 306 1;
 307
 308 __END__
 309
 310 =head1 NAME
 311
 312 ExtUtils::Install - install files from here to there
 313
 314 =head1 SYNOPSIS
 315
 316 B<use ExtUtils::Install;>
 317
 318 B<install($hashref,$verbose,$nonono);>
 319
 320 B<uninstall($packlistfile,$verbose,$nonono);>
 321
 322 B<pm_to_blib($hashref);>
 323
 324 =head1 DESCRIPTION
 325
 326 Both install() and uninstall() are specific to the way
 327 ExtUtils::MakeMaker handles the installation and deinstallation of
 328 perl modules. They are not designed as general purpose tools.
 329
 330 install() takes three arguments. A reference to a hash, a verbose
 331 switch and a don't-really-do-it switch. The hash ref contains a
 332 mapping of directories: each key/value pair is a combination of
 333 directories to be copied. Key is a directory to copy from, value is a
 334 directory to copy to. The whole tree below the "from" directory will
 335 be copied preserving timestamps and permissions.
 336
 337 There are two keys with a special meaning in the hash: "read" and
 338 "write". After the copying is done, install will write the list of
 339 target files to the file named by C<$hashref-E<gt>{write}>. If there is
 340 another file named by C<$hashref-E<gt>{read}>, the contents of this file will
 341 be merged into the written file. The read and the written file may be
 342 identical, but on AFS it is quite likely that people are installing to a
 343 different directory than the one where the files later appear.
 344
 345 install_default() takes one or less arguments.  If no arguments are
 346 specified, it takes $ARGV[0] as if it was specified as an argument.
 347 The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
 348 This function calls install() with the same arguments as the defaults
 349 the MakeMaker would use.
 350
 351 The argument-less form is convenient for install scripts like
 352
 353   perl -MExtUtils::Install -e install_default Tk/Canvas
 354
 355 Assuming this command is executed in a directory with a populated F<blib>
 356 directory, it will proceed as if the F<blib> was build by MakeMaker on
 357 this machine.  This is useful for binary distributions.
 358
 359 uninstall() takes as first argument a file containing filenames to be
 360 unlinked. The second argument is a verbose switch, the third is a
 361 no-don't-really-do-it-now switch.
 362
 363 pm_to_blib() takes a hashref as the first argument and copies all keys
 364 of the hash to the corresponding values efficiently. Filenames with
 365 the extension pm are autosplit. Second argument is the autosplit
 366 directory.
 367
 368 =cut