home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / ExtUtils / Install.pm < prev    next >
Text File  |  1997-05-19  |  10KB  |  344 lines
  1. package ExtUtils::Install;
  2.  
  3. $VERSION = substr q$Revision: 1.3 $, 10;
  4. # $Date: 1997/05/19 12:32:09 $
  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.     if (!ref($fromto) && -r $fromto)
  237.      {
  238.       # Win32 has severe command line length limitations, but
  239.       # can generate temporary files on-the-fly
  240.       # so we pass name of file here - eval it to get hash 
  241.       open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
  242.       my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
  243.       eval $str;
  244.       close(FROMTO);
  245.      }
  246.  
  247.     my $umask = umask 0022 unless $Is_VMS;
  248.     mkpath($autodir,0,0755);
  249.     foreach (keys %$fromto) {
  250.     next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
  251.     unless (my_cmp($_,$fromto->{$_})){
  252.         print "Skip $fromto->{$_} (unchanged)\n";
  253.         next;
  254.     }
  255.     if (-f $fromto->{$_}){
  256.         forceunlink($fromto->{$_});
  257.     } else {
  258.         mkpath(dirname($fromto->{$_}),0,0755);
  259.     }
  260.     copy($_,$fromto->{$_});
  261.     my($mode,$atime,$mtime) = (stat)[2,8,9];
  262.     utime($atime,$mtime+$Is_VMS,$fromto->{$_});
  263.     chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
  264.     print "cp $_ $fromto->{$_}\n";
  265.     next unless /\.pm$/;
  266.     autosplit($fromto->{$_},$autodir);
  267.     }
  268.     umask $umask unless $Is_VMS;
  269. }
  270.  
  271. package ExtUtils::Install::Warn;
  272.  
  273. sub new { bless {}, shift }
  274.  
  275. sub add {
  276.     my($self,$file,$targetfile) = @_;
  277.     push @{$self->{$file}}, $targetfile;
  278. }
  279.  
  280. sub DESTROY {
  281.     my $self = shift;
  282.     my($file,$i,$plural);
  283.     foreach $file (sort keys %$self) {
  284.     $plural = @{$self->{$file}} > 1 ? "s" : "";
  285.     print "## Differing version$plural of $file found. You might like to\n";
  286.     for (0..$#{$self->{$file}}) {
  287.         print "rm ", $self->{$file}[$_], "\n";
  288.         $i++;
  289.     }
  290.     }
  291.     $plural = $i>1 ? "all those files" : "this file";
  292.     print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
  293. }
  294.  
  295. 1;
  296.  
  297. __END__
  298.  
  299. =head1 NAME
  300.  
  301. ExtUtils::Install - install files from here to there
  302.  
  303. =head1 SYNOPSIS
  304.  
  305. B<use ExtUtils::Install;>
  306.  
  307. B<install($hashref,$verbose,$nonono);>
  308.  
  309. B<uninstall($packlistfile,$verbose,$nonono);>
  310.  
  311. B<pm_to_blib($hashref);>
  312.  
  313. =head1 DESCRIPTION
  314.  
  315. Both install() and uninstall() are specific to the way
  316. ExtUtils::MakeMaker handles the installation and deinstallation of
  317. perl modules. They are not designed as general purpose tools.
  318.  
  319. install() takes three arguments. A reference to a hash, a verbose
  320. switch and a don't-really-do-it switch. The hash ref contains a
  321. mapping of directories: each key/value pair is a combination of
  322. directories to be copied. Key is a directory to copy from, value is a
  323. directory to copy to. The whole tree below the "from" directory will
  324. be copied preserving timestamps and permissions.
  325.  
  326. There are two keys with a special meaning in the hash: "read" and
  327. "write". After the copying is done, install will write the list of
  328. target files to the file named by C<$hashref-E<gt>{write}>. If there is
  329. another file named by C<$hashref-E<gt>{read}>, the contents of this file will
  330. be merged into the written file. The read and the written file may be
  331. identical, but on AFS it is quite likely, people are installing to a
  332. different directory than the one where the files later appear.
  333.  
  334. uninstall() takes as first argument a file containing filenames to be
  335. unlinked. The second argument is a verbose switch, the third is a
  336. no-don't-really-do-it-now switch.
  337.  
  338. pm_to_blib() takes a hashref as the first argument and copies all keys
  339. of the hash to the corresponding values efficiently. Filenames with
  340. the extension pm are autosplit. Second argument is the autosplit
  341. directory.
  342.  
  343. =cut
  344.