lib/ExtUtils/Install.pm

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