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