home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / ExtUtils / Install.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  10.5 KB  |  350 lines
  1. package ExtUtils::Install;
  2.  
  3. $VERSION = substr q$Revision: 1.19 $, 10;
  4.  
  5. use Exporter;
  6. use Carp ();
  7. use Config qw(%Config);
  8. use vars qw(@ISA @EXPORT $VERSION);
  9. @ISA = ('Exporter');
  10. @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
  11. $Is_VMS = $^O eq 'VMS';
  12.  
  13. my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':';
  14. my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
  15. my $Inc_uninstall_warn_handler;
  16.  
  17.  
  18. sub forceunlink {
  19.     chmod 0666, $_[0];
  20.     unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
  21. }
  22.  
  23. sub install {
  24.     my($hash,$verbose,$nonono,$inc_uninstall) = @_;
  25.     $verbose ||= 0;
  26.     $nonono  ||= 0;
  27.  
  28.     use Cwd qw(cwd);
  29.     use ExtUtils::MakeMaker; # to implement a MY class
  30.     use File::Basename qw(dirname);
  31.     use File::Copy qw(copy);
  32.     use File::Find qw(find);
  33.     use File::Path qw(mkpath);
  34.  
  35.     my(%hash) = %$hash;
  36.     my(%pack, %write, $dir, $warn_permissions);
  37.     $warn_permissions++ if $^O eq 'MSWin32';
  38.     local(*DIR, *P);
  39.     for (qw/read write/) {
  40.     $pack{$_}=$hash{$_};
  41.     delete $hash{$_};
  42.     }
  43.     my($source_dir_or_file);
  44.     foreach $source_dir_or_file (sort keys %hash) {
  45.     opendir DIR, $source_dir_or_file or next;
  46.     for (readdir DIR) {
  47.         next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
  48.         if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) {
  49.         last;
  50.         } else {
  51.         warn "Warning: You do not have permissions to install into $hash{$source_dir_or_file}"
  52.             unless $warn_permissions++;
  53.         }
  54.     }
  55.     closedir DIR;
  56.     }
  57.     if (-f $pack{"read"}) {
  58.     open P, $pack{"read"} or Carp::croak("Couldn't read $pack{'read'}");
  59.     while (<P>) {
  60.         chomp;
  61.         $write{$_}++;
  62.     }
  63.     close P;
  64.     }
  65.     my $cwd = cwd();
  66.     my $umask = umask 0 unless $Is_VMS;
  67.  
  68.     my $MY = {};
  69.     bless $MY, 'MY';
  70.     my($source);
  71.     MOD_INSTALL: foreach $source (sort keys %hash) {
  72.     chdir($source) or next;
  73.     find(sub {
  74.         my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  75.                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
  76.         return unless -f _;
  77.         return if $_ eq ".exists";
  78.         my $targetdir = $MY->catdir($hash{$source},$File::Find::dir);
  79.         my $targetfile = $MY->catfile($targetdir,$_);
  80.  
  81.         my $diff = 0;
  82.         if ( -f $targetfile && -s _ == $size) {
  83.         $diff = my_cmp($_,$targetfile);
  84.         } else {
  85.         print "$_ differs\n" if $verbose>1;
  86.         $diff++;
  87.         }
  88.  
  89.         if ($diff){
  90.         if (-f $targetfile){
  91.             forceunlink($targetfile) unless $nonono;
  92.         } else {
  93.             mkpath($targetdir,0,0755) unless $nonono;
  94.             print "mkpath($targetdir,0,0755)\n" if $verbose>1;
  95.         }
  96.         copy($_,$targetfile) unless $nonono;
  97.         print "Installing $targetfile\n";
  98.         utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
  99.         print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
  100.         $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
  101.         chmod $mode, $targetfile;
  102.         print "chmod($mode, $targetfile)\n" if $verbose>1;
  103.         } else {
  104.         print "Skipping $targetfile (unchanged)\n" if $verbose;
  105.         }
  106.         
  107.         if (! defined $inc_uninstall) { # it's called 
  108.         } elsif ($inc_uninstall == 0){
  109.         inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
  110.         } else {
  111.         inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
  112.         }
  113.         $write{$targetfile}++;
  114.  
  115.     }, ".");
  116.     chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
  117.     }
  118.     umask $umask unless $Is_VMS;
  119.     if ($pack{'write'}) {
  120.     $dir = dirname($pack{'write'});
  121.     mkpath($dir,0,0755);
  122.     print "Writing $pack{'write'}\n";
  123.     open P, ">$pack{'write'}" or Carp::croak("Couldn't write $pack{'write'}: $!");
  124.     for (sort keys %write) {
  125.         print P "$_\n";
  126.     }
  127.     close P;
  128.     }
  129. }
  130.  
  131. sub install_default {
  132.   @_ < 2 or die "install_default should be called with 0 or 1 argument";
  133.   my $FULLEXT = @_ ? shift : $ARGV[0];
  134.   defined $FULLEXT or die "Do not know to where to write install log";
  135.   my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
  136.   my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
  137.   my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
  138.   my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
  139.   my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
  140.   my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
  141.   install({
  142.        read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
  143.        write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
  144.        $INST_LIB => $Config{installsitelib},
  145.        $INST_ARCHLIB => $Config{installsitearch},
  146.        $INST_BIN => $Config{installbin} ,
  147.        $INST_SCRIPT => $Config{installscript},
  148.        $INST_MAN1DIR => $Config{installman1dir},
  149.        $INST_MAN3DIR => $Config{installman3dir},
  150.       },1,0,0);
  151. }
  152.  
  153. sub my_cmp {
  154.     my($one,$two) = @_;
  155.     local(*F,*T);
  156.     my $diff = 0;
  157.     open T, $two or return 1;
  158.     open F, $one or Carp::croak("Couldn't open $one: $!");
  159.     my($fr, $tr, $fbuf, $tbuf, $size);
  160.     $size = 1024;
  161.     while ( $fr = read(F,$fbuf,$size)) {
  162.     unless (
  163.         $tr = read(T,$tbuf,$size) and 
  164.         $tbuf eq $fbuf
  165.            ){
  166.         $diff++;
  167.         last;
  168.     }
  169.     }
  170.     close F;
  171.     close T;
  172.     $diff;
  173. }
  174.  
  175. sub uninstall {
  176.     my($fil,$verbose,$nonono) = @_;
  177.     die "no packlist file found: $fil" unless -f $fil;
  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{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.     my $diff = 0;
  202.     if ( -f $targetfile && -s _ == -s $file) {
  203.         $diff = my_cmp($file,$targetfile);
  204.     } else {
  205.         print "#$file and $targetfile differ\n" if $verbose>1;
  206.         $diff++;
  207.     }
  208.  
  209.     next unless $diff;
  210.     if ($nonono) {
  211.         if ($verbose) {
  212.         $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
  213.         $libdir =~ s|^\./|| ; # That's just cosmetics, no need to port. It looks prettier.
  214.         $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
  215.         }
  216.     } else {
  217.         print "Unlinking $targetfile (shadowing?)\n";
  218.         forceunlink($targetfile);
  219.     }
  220.     }
  221. }
  222.  
  223. sub pm_to_blib {
  224.     my($fromto,$autodir) = @_;
  225.  
  226.     use File::Basename qw(dirname);
  227.     use File::Copy qw(copy);
  228.     use File::Path qw(mkpath);
  229.     use AutoSplit;
  230.  
  231.     if (!ref($fromto) && -r $fromto)
  232.      {
  233.       open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
  234.       my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
  235.       eval $str;
  236.       close(FROMTO);
  237.      }
  238.  
  239.     my $umask = umask 0022 unless $Is_VMS;
  240.     mkpath($autodir,0,0755);
  241.     foreach (keys %$fromto) {
  242.     next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
  243.     unless (my_cmp($_,$fromto->{$_})){
  244.         print "Skip $fromto->{$_} (unchanged)\n";
  245.         next;
  246.     }
  247.     if (-f $fromto->{$_}){
  248.         forceunlink($fromto->{$_});
  249.     } else {
  250.         mkpath(dirname($fromto->{$_}),0,0755);
  251.     }
  252.     copy($_,$fromto->{$_});
  253.     my($mode,$atime,$mtime) = (stat)[2,8,9];
  254.     utime($atime,$mtime+$Is_VMS,$fromto->{$_});
  255.     chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
  256.     print "cp $_ $fromto->{$_}\n";
  257.     next unless /\.pm$/;
  258.     autosplit($fromto->{$_},$autodir);
  259.     }
  260.     umask $umask unless $Is_VMS;
  261. }
  262.  
  263. package ExtUtils::Install::Warn;
  264.  
  265. sub new { bless {}, shift }
  266.  
  267. sub add {
  268.     my($self,$file,$targetfile) = @_;
  269.     push @{$self->{$file}}, $targetfile;
  270. }
  271.  
  272. sub DESTROY {
  273.     my $self = shift;
  274.     my($file,$i,$plural);
  275.     foreach $file (sort keys %$self) {
  276.     $plural = @{$self->{$file}} > 1 ? "s" : "";
  277.     print "## Differing version$plural of $file found. You might like to\n";
  278.     for (0..$#{$self->{$file}}) {
  279.         print "rm ", $self->{$file}[$_], "\n";
  280.         $i++;
  281.     }
  282.     }
  283.     $plural = $i>1 ? "all those files" : "this file";
  284.     print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
  285. }
  286.  
  287. 1;
  288.  
  289. __END__
  290.  
  291. =head1 NAME
  292.  
  293. ExtUtils::Install - install files from here to there
  294.  
  295. =head1 SYNOPSIS
  296.  
  297. B<use ExtUtils::Install;>
  298.  
  299. B<install($hashref,$verbose,$nonono);>
  300.  
  301. B<uninstall($packlistfile,$verbose,$nonono);>
  302.  
  303. B<pm_to_blib($hashref);>
  304.  
  305. =head1 DESCRIPTION
  306.  
  307. Both install() and uninstall() are specific to the way
  308. ExtUtils::MakeMaker handles the installation and deinstallation of
  309. perl modules. They are not designed as general purpose tools.
  310.  
  311. install() takes three arguments. A reference to a hash, a verbose
  312. switch and a don't-really-do-it switch. The hash ref contains a
  313. mapping of directories: each key/value pair is a combination of
  314. directories to be copied. Key is a directory to copy from, value is a
  315. directory to copy to. The whole tree below the "from" directory will
  316. be copied preserving timestamps and permissions.
  317.  
  318. There are two keys with a special meaning in the hash: "read" and
  319. "write". After the copying is done, install will write the list of
  320. target files to the file named by C<$hashref-E<gt>{write}>. If there is
  321. another file named by C<$hashref-E<gt>{read}>, the contents of this file will
  322. be merged into the written file. The read and the written file may be
  323. identical, but on AFS it is quite likely, people are installing to a
  324. different directory than the one where the files later appear.
  325.  
  326. install_default() takes one or less arguments.  If no arguments are 
  327. specified, it takes $ARGV[0] as if it was specified as an argument.  
  328. The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.  
  329. This function calls install() with the same arguments as the defaults 
  330. the MakeMaker would use.
  331.  
  332. The argumement-less form is convenient for install scripts like
  333.  
  334.   perl -MExtUtils::Install -e install_default Tk/Canvas
  335.  
  336. Assuming this command is executed in a directory with populated F<blib> 
  337. directory, it will proceed as if the F<blib> was build by MakeMaker on 
  338. this machine.  This is useful for binary distributions.
  339.  
  340. uninstall() takes as first argument a file containing filenames to be
  341. unlinked. The second argument is a verbose switch, the third is a
  342. no-don't-really-do-it-now switch.
  343.  
  344. pm_to_blib() takes a hashref as the first argument and copies all keys
  345. of the hash to the corresponding values efficiently. Filenames with
  346. the extension pm are autosplit. Second argument is the autosplit
  347. directory.
  348.  
  349. =cut
  350.