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