home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Install.pm < prev    next >
Text File  |  2005-01-27  |  16KB  |  557 lines
  1. package ExtUtils::Install;
  2.  
  3. use 5.00503;
  4. use vars qw(@ISA @EXPORT $VERSION);
  5. $VERSION = 1.32;
  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. $Is_MacPerl = $^O eq 'MacOS';
  14.  
  15. my $Inc_uninstall_warn_handler;
  16.  
  17. # install relative to here
  18.  
  19. my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
  20.  
  21. use File::Spec;
  22. my $Curdir = File::Spec->curdir;
  23. my $Updir  = File::Spec->updir;
  24.  
  25.  
  26. =head1 NAME
  27.  
  28. ExtUtils::Install - install files from here to there
  29.  
  30. =head1 SYNOPSIS
  31.  
  32.   use ExtUtils::Install;
  33.  
  34.   install({ 'blib/lib' => 'some/install/dir' } );
  35.  
  36.   uninstall($packlist);
  37.  
  38.   pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
  39.  
  40.  
  41. =head1 DESCRIPTION
  42.  
  43. Handles the installing and uninstalling of perl modules, scripts, man
  44. pages, etc...
  45.  
  46. Both install() and uninstall() are specific to the way
  47. ExtUtils::MakeMaker handles the installation and deinstallation of
  48. perl modules. They are not designed as general purpose tools.
  49.  
  50. =head2 Functions
  51.  
  52. =over 4
  53.  
  54. =item B<install>
  55.  
  56.     install(\%from_to);
  57.     install(\%from_to, $verbose, $dont_execute, $uninstall_shadows);
  58.  
  59. Copies each directory tree of %from_to to its corresponding value
  60. preserving timestamps and permissions.
  61.  
  62. There are two keys with a special meaning in the hash: "read" and
  63. "write".  These contain packlist files.  After the copying is done,
  64. install() will write the list of target files to $from_to{write}. If
  65. $from_to{read} is given the contents of this file will be merged into
  66. the written file. The read and the written file may be identical, but
  67. on AFS it is quite likely that people are installing to a different
  68. directory than the one where the files later appear.
  69.  
  70. If $verbose is true, will print out each file removed.  Default is
  71. false.  This is "make install VERBINST=1"
  72.  
  73. If $dont_execute is true it will only print what it was going to do
  74. without actually doing it.  Default is false.
  75.  
  76. If $uninstall_shadows is true any differing versions throughout @INC
  77. will be uninstalled.  This is "make install UNINST=1"
  78.  
  79. =cut
  80.  
  81. sub install {
  82.     my($from_to,$verbose,$nonono,$inc_uninstall) = @_;
  83.     $verbose ||= 0;
  84.     $nonono  ||= 0;
  85.  
  86.     use Cwd qw(cwd);
  87.     use ExtUtils::Packlist;
  88.     use File::Basename qw(dirname);
  89.     use File::Copy qw(copy);
  90.     use File::Find qw(find);
  91.     use File::Path qw(mkpath);
  92.     use File::Compare qw(compare);
  93.  
  94.     my(%from_to) = %$from_to;
  95.     my(%pack, $dir, $warn_permissions);
  96.     my($packlist) = ExtUtils::Packlist->new();
  97.     # -w doesn't work reliably on FAT dirs
  98.     $warn_permissions++ if $^O eq 'MSWin32';
  99.     local(*DIR);
  100.     for (qw/read write/) {
  101.     $pack{$_}=$from_to{$_};
  102.     delete $from_to{$_};
  103.     }
  104.     my($source_dir_or_file);
  105.     foreach $source_dir_or_file (sort keys %from_to) {
  106.     #Check if there are files, and if yes, look if the corresponding
  107.     #target directory is writable for us
  108.     opendir DIR, $source_dir_or_file or next;
  109.     for (readdir DIR) {
  110.         next if $_ eq $Curdir || $_ eq $Updir || $_ eq ".exists";
  111.             my $targetdir = install_rooted_dir($from_to{$source_dir_or_file});
  112.             mkpath($targetdir) unless $nonono;
  113.         if (!$nonono && !-w $targetdir) {
  114.         warn "Warning: You do not have permissions to " .
  115.             "install into $from_to{$source_dir_or_file}"
  116.             unless $warn_permissions++;
  117.         }
  118.     }
  119.     closedir DIR;
  120.     }
  121.     my $tmpfile = install_rooted_file($pack{"read"});
  122.     $packlist->read($tmpfile) if (-f $tmpfile);
  123.     my $cwd = cwd();
  124.  
  125.     MOD_INSTALL: foreach my $source (sort keys %from_to) {
  126.     #copy the tree to the target directory without altering
  127.     #timestamp and permission and remember for the .packlist
  128.     #file. The packlist file contains the absolute paths of the
  129.     #install locations. AFS users may call this a bug. We'll have
  130.     #to reconsider how to add the means to satisfy AFS users also.
  131.  
  132.     #October 1997: we want to install .pm files into archlib if
  133.     #there are any files in arch. So we depend on having ./blib/arch
  134.     #hardcoded here.
  135.  
  136.     my $targetroot = install_rooted_dir($from_to{$source});
  137.  
  138.         my $blib_lib  = File::Spec->catdir('blib', 'lib');
  139.         my $blib_arch = File::Spec->catdir('blib', 'arch');
  140.     if ($source eq $blib_lib and
  141.         exists $from_to{$blib_arch} and
  142.         directory_not_empty($blib_arch)) {
  143.         $targetroot = install_rooted_dir($from_to{$blib_arch});
  144.             print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
  145.     }
  146.  
  147.         chdir $source or next;
  148.     find(sub {
  149.         my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
  150.         return unless -f _;
  151.  
  152.             my $origfile = $_;
  153.         return if $origfile eq ".exists";
  154.         my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
  155.         my $targetfile = File::Spec->catfile($targetdir, $origfile);
  156.             my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
  157.             my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
  158.  
  159.             my $save_cwd = cwd;
  160.             chdir $cwd;  # in case the target is relative
  161.                          # 5.5.3's File::Find missing no_chdir option.
  162.  
  163.         my $diff = 0;
  164.         if ( -f $targetfile && -s _ == $size) {
  165.         # We have a good chance, we can skip this one
  166.         $diff = compare($sourcefile, $targetfile);
  167.         } else {
  168.         print "$sourcefile differs\n" if $verbose>1;
  169.         $diff++;
  170.         }
  171.  
  172.         if ($diff){
  173.         if (-f $targetfile){
  174.             forceunlink($targetfile) unless $nonono;
  175.         } else {
  176.             mkpath($targetdir,0,0755) unless $nonono;
  177.             print "mkpath($targetdir,0,0755)\n" if $verbose>1;
  178.         }
  179.         copy($sourcefile, $targetfile) unless $nonono;
  180.         print "Installing $targetfile\n";
  181.         utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
  182.         print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
  183.         $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
  184.         chmod $mode, $targetfile;
  185.         print "chmod($mode, $targetfile)\n" if $verbose>1;
  186.         } else {
  187.         print "Skipping $targetfile (unchanged)\n" if $verbose;
  188.         }
  189.  
  190.         if (defined $inc_uninstall) {
  191.         inc_uninstall($sourcefile,$File::Find::dir,$verbose, 
  192.                               $inc_uninstall ? 0 : 1);
  193.         }
  194.  
  195.         # Record the full pathname.
  196.         $packlist->{$targetfile}++;
  197.  
  198.             # File::Find can get confused if you chdir in here.
  199.             chdir $save_cwd;
  200.  
  201.         # File::Find seems to always be Unixy except on MacPerl :(
  202.     }, $Is_MacPerl ? $Curdir : '.' );
  203.     chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
  204.     }
  205.     if ($pack{'write'}) {
  206.     $dir = install_rooted_dir(dirname($pack{'write'}));
  207.     mkpath($dir,0,0755) unless $nonono;
  208.     print "Writing $pack{'write'}\n";
  209.     $packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
  210.     }
  211. }
  212.  
  213. sub install_rooted_file {
  214.     if (defined $INSTALL_ROOT) {
  215.     File::Spec->catfile($INSTALL_ROOT, $_[0]);
  216.     } else {
  217.     $_[0];
  218.     }
  219. }
  220.  
  221.  
  222. sub install_rooted_dir {
  223.     if (defined $INSTALL_ROOT) {
  224.     File::Spec->catdir($INSTALL_ROOT, $_[0]);
  225.     } else {
  226.     $_[0];
  227.     }
  228. }
  229.  
  230.  
  231. sub forceunlink {
  232.     chmod 0666, $_[0];
  233.     unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
  234. }
  235.  
  236.  
  237. sub directory_not_empty ($) {
  238.   my($dir) = @_;
  239.   my $files = 0;
  240.   find(sub {
  241.        return if $_ eq ".exists";
  242.        if (-f) {
  243.          $File::Find::prune++;
  244.          $files = 1;
  245.        }
  246.        }, $dir);
  247.   return $files;
  248. }
  249.  
  250.  
  251. =item B<install_default> I<DISCOURAGED>
  252.  
  253.     install_default();
  254.     install_default($fullext);
  255.  
  256. Calls install() with arguments to copy a module from blib/ to the
  257. default site installation location.
  258.  
  259. $fullext is the name of the module converted to a directory
  260. (ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
  261. will attempt to read it from @ARGV.
  262.  
  263. This is primarily useful for install scripts.
  264.  
  265. B<NOTE> This function is not really useful because of the hard-coded
  266. install location with no way to control site vs core vs vendor
  267. directories and the strange way in which the module name is given.
  268. Consider its use discouraged.
  269.  
  270. =cut
  271.  
  272. sub install_default {
  273.   @_ < 2 or die "install_default should be called with 0 or 1 argument";
  274.   my $FULLEXT = @_ ? shift : $ARGV[0];
  275.   defined $FULLEXT or die "Do not know to where to write install log";
  276.   my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
  277.   my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
  278.   my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
  279.   my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
  280.   my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
  281.   my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
  282.   install({
  283.        read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
  284.        write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
  285.        $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
  286.              $Config{installsitearch} :
  287.              $Config{installsitelib},
  288.        $INST_ARCHLIB => $Config{installsitearch},
  289.        $INST_BIN => $Config{installbin} ,
  290.        $INST_SCRIPT => $Config{installscript},
  291.        $INST_MAN1DIR => $Config{installman1dir},
  292.        $INST_MAN3DIR => $Config{installman3dir},
  293.       },1,0,0);
  294. }
  295.  
  296.  
  297. =item B<uninstall>
  298.  
  299.     uninstall($packlist_file);
  300.     uninstall($packlist_file, $verbose, $dont_execute);
  301.  
  302. Removes the files listed in a $packlist_file.
  303.  
  304. If $verbose is true, will print out each file removed.  Default is
  305. false.
  306.  
  307. If $dont_execute is true it will only print what it was going to do
  308. without actually doing it.  Default is false.
  309.  
  310. =cut
  311.  
  312. sub uninstall {
  313.     use ExtUtils::Packlist;
  314.     my($fil,$verbose,$nonono) = @_;
  315.     $verbose ||= 0;
  316.     $nonono  ||= 0;
  317.  
  318.     die "no packlist file found: $fil" unless -f $fil;
  319.     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
  320.     # require $my_req; # Hairy, but for the first
  321.     my ($packlist) = ExtUtils::Packlist->new($fil);
  322.     foreach (sort(keys(%$packlist))) {
  323.     chomp;
  324.     print "unlink $_\n" if $verbose;
  325.     forceunlink($_) unless $nonono;
  326.     }
  327.     print "unlink $fil\n" if $verbose;
  328.     forceunlink($fil) unless $nonono;
  329. }
  330.  
  331. sub inc_uninstall {
  332.     my($filepath,$libdir,$verbose,$nonono) = @_;
  333.     my($dir);
  334.     my $file = (File::Spec->splitpath($filepath))[2];
  335.     my %seen_dir = ();
  336.  
  337.     my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} 
  338.       ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
  339.  
  340.     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
  341.                           privlibexp
  342.                           sitearchexp
  343.                           sitelibexp)}) {
  344.     next if $dir eq $Curdir;
  345.     next if $seen_dir{$dir}++;
  346.     my($targetfile) = File::Spec->catfile($dir,$libdir,$file);
  347.     next unless -f $targetfile;
  348.  
  349.     # The reason why we compare file's contents is, that we cannot
  350.     # know, which is the file we just installed (AFS). So we leave
  351.     # an identical file in place
  352.     my $diff = 0;
  353.     if ( -f $targetfile && -s _ == -s $filepath) {
  354.         # We have a good chance, we can skip this one
  355.         $diff = compare($filepath,$targetfile);
  356.     } else {
  357.         print "#$file and $targetfile differ\n" if $verbose>1;
  358.         $diff++;
  359.     }
  360.  
  361.     next unless $diff;
  362.     if ($nonono) {
  363.         if ($verbose) {
  364.         $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
  365.         $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
  366.         $Inc_uninstall_warn_handler->add(
  367.                                      File::Spec->catfile($libdir, $file),
  368.                                      $targetfile
  369.                                     );
  370.         }
  371.         # if not verbose, we just say nothing
  372.     } else {
  373.         print "Unlinking $targetfile (shadowing?)\n";
  374.         forceunlink($targetfile);
  375.     }
  376.     }
  377. }
  378.  
  379. sub run_filter {
  380.     my ($cmd, $src, $dest) = @_;
  381.     local(*CMD, *SRC);
  382.     open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
  383.     open(SRC, $src)           || die "Cannot open $src: $!";
  384.     my $buf;
  385.     my $sz = 1024;
  386.     while (my $len = sysread(SRC, $buf, $sz)) {
  387.     syswrite(CMD, $buf, $len);
  388.     }
  389.     close SRC;
  390.     close CMD or die "Filter command '$cmd' failed for $src";
  391. }
  392.  
  393.  
  394. =item B<pm_to_blib>
  395.  
  396.     pm_to_blib(\%from_to, $autosplit_dir);
  397.     pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
  398.  
  399. Copies each key of %from_to to its corresponding value efficiently.
  400. Filenames with the extension .pm are autosplit into the $autosplit_dir.
  401.  
  402. $filter_cmd is an optional shell command to run each .pm file through
  403. prior to splitting and copying.  Input is the contents of the module,
  404. output the new module contents.
  405.  
  406. You can have an environment variable PERL_INSTALL_ROOT set which will
  407. be prepended as a directory to each installed file (and directory).
  408.  
  409. =cut
  410.  
  411. sub pm_to_blib {
  412.     my($fromto,$autodir,$pm_filter) = @_;
  413.  
  414.     use File::Basename qw(dirname);
  415.     use File::Copy qw(copy);
  416.     use File::Path qw(mkpath);
  417.     use File::Compare qw(compare);
  418.     use AutoSplit;
  419.     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
  420.     # require $my_req; # Hairy, but for the first
  421.  
  422.     if (!ref($fromto) && -r $fromto)
  423.      {
  424.       # Win32 has severe command line length limitations, but
  425.       # can generate temporary files on-the-fly
  426.       # so we pass name of file here - eval it to get hash 
  427.       open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
  428.       my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
  429.       eval $str;
  430.       close(FROMTO);
  431.      }
  432.  
  433.     mkpath($autodir,0,0755);
  434.     while(my($from, $to) = each %$fromto) {
  435.     if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
  436.             print "Skip $to (unchanged)\n";
  437.             next;
  438.         }
  439.  
  440.     # When a pm_filter is defined, we need to pre-process the source first
  441.     # to determine whether it has changed or not.  Therefore, only perform
  442.     # the comparison check when there's no filter to be ran.
  443.     #    -- RAM, 03/01/2001
  444.  
  445.     my $need_filtering = defined $pm_filter && length $pm_filter && 
  446.                              $from =~ /\.pm$/;
  447.  
  448.     if (!$need_filtering && 0 == compare($from,$to)) {
  449.         print "Skip $to (unchanged)\n";
  450.         next;
  451.     }
  452.     if (-f $to){
  453.         forceunlink($to);
  454.     } else {
  455.         mkpath(dirname($to),0,0755);
  456.     }
  457.     if ($need_filtering) {
  458.         run_filter($pm_filter, $from, $to);
  459.         print "$pm_filter <$from >$to\n";
  460.     } else {
  461.         copy($from,$to);
  462.         print "cp $from $to\n";
  463.     }
  464.     my($mode,$atime,$mtime) = (stat $from)[2,8,9];
  465.     utime($atime,$mtime+$Is_VMS,$to);
  466.     chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
  467.     next unless $from =~ /\.pm$/;
  468.     _autosplit($to,$autodir);
  469.     }
  470. }
  471.  
  472.  
  473. =begin _private
  474.  
  475. =item _autosplit
  476.  
  477. From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
  478. the file being split.  This causes problems on systems with mandatory
  479. locking (ie. Windows).  So we wrap it and close the filehandle.
  480.  
  481. =end _private
  482.  
  483. =cut
  484.  
  485. sub _autosplit {
  486.     my $retval = autosplit(@_);
  487.     close *AutoSplit::IN if defined *AutoSplit::IN{IO};
  488.  
  489.     return $retval;
  490. }
  491.  
  492.  
  493. package ExtUtils::Install::Warn;
  494.  
  495. sub new { bless {}, shift }
  496.  
  497. sub add {
  498.     my($self,$file,$targetfile) = @_;
  499.     push @{$self->{$file}}, $targetfile;
  500. }
  501.  
  502. sub DESTROY {
  503.     unless(defined $INSTALL_ROOT) {
  504.         my $self = shift;
  505.         my($file,$i,$plural);
  506.         foreach $file (sort keys %$self) {
  507.             $plural = @{$self->{$file}} > 1 ? "s" : "";
  508.             print "## Differing version$plural of $file found. You might like to\n";
  509.             for (0..$#{$self->{$file}}) {
  510.                 print "rm ", $self->{$file}[$_], "\n";
  511.                 $i++;
  512.             }
  513.         }
  514.         $plural = $i>1 ? "all those files" : "this file";
  515.         print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
  516.     }
  517. }
  518.  
  519. =back
  520.  
  521.  
  522. =head1 ENVIRONMENT
  523.  
  524. =over 4
  525.  
  526. =item B<PERL_INSTALL_ROOT>
  527.  
  528. Will be prepended to each install path.
  529.  
  530. =back
  531.  
  532. =head1 AUTHOR
  533.  
  534. Original author lost in the mists of time.  Probably the same as Makemaker.
  535.  
  536. Currently maintained by Michael G Schwern <F<schwern@pobox.com>>
  537.  
  538. Send patches and ideas to <F<makemaker@perl.org>>.
  539.  
  540. Send bug reports via http://rt.cpan.org/.  Please send your
  541. generated Makefile along with your report.
  542.  
  543. For more up-to-date information, see http://www.makemaker.org.
  544.  
  545.  
  546. =head1 LICENSE
  547.  
  548. This program is free software; you can redistribute it and/or 
  549. modify it under the same terms as Perl itself.
  550.  
  551. See F<http://www.perl.com/perl/misc/Artistic.html>
  552.  
  553.  
  554. =cut
  555.  
  556. 1;
  557.