lib/ExtUtils/Install.pm

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