lib/ExtUtils/Install.pm

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