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