home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / SLAKWARE / D12 / PERL1.TGZ / perl1.tar / usr / lib / perl5 / ExtUtils / Install.pm next >
Text File  |  1996-06-28  |  10KB  |  338 lines
  1. package ExtUtils::Install;
  2.  
  3. $VERSION = substr q$Revision: 1.12 $, 10;
  4. # $Id: Install.pm,v 1.12 1996/06/23 20:46:07 k 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