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