home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / ExtUtils / Install.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  32.4 KB  |  1,148 lines
  1. package ExtUtils::Install;
  2. use 5.00503;
  3. use strict;
  4.  
  5. use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
  6. $VERSION = '1.44';
  7. $VERSION = eval $VERSION;
  8.  
  9. use AutoSplit;
  10. use Carp ();
  11. use Config qw(%Config);
  12. use Cwd qw(cwd);
  13. use Exporter;
  14. use ExtUtils::Packlist;
  15. use File::Basename qw(dirname);
  16. use File::Compare qw(compare);
  17. use File::Copy;
  18. use File::Find qw(find);
  19. use File::Path;
  20. use File::Spec;
  21.  
  22.  
  23. @ISA = ('Exporter');
  24. @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
  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. =head1 DESCRIPTION
  41.  
  42. Handles the installing and uninstalling of perl modules, scripts, man
  43. pages, etc...
  44.  
  45. Both install() and uninstall() are specific to the way
  46. ExtUtils::MakeMaker handles the installation and deinstallation of
  47. perl modules. They are not designed as general purpose tools.
  48.  
  49. On some operating systems such as Win32 installation may not be possible
  50. until after a reboot has occured. This can have varying consequences:
  51. removing an old DLL does not impact programs using the new one, but if
  52. a new DLL cannot be installed properly until reboot then anything
  53. depending on it must wait. The package variable
  54.  
  55.   $ExtUtils::Install::MUST_REBOOT
  56.  
  57. is used to store this status.
  58.  
  59. If this variable is true then such an operation has occured and
  60. anything depending on this module cannot proceed until a reboot
  61. has occured.
  62.  
  63. If this value is defined but false then such an operation has
  64. ocurred, but should not impact later operations.
  65.  
  66. =begin _private
  67.  
  68. =item _chmod($$;$)
  69.  
  70. Wrapper to chmod() for debugging and error trapping.
  71.  
  72. =item _warnonce(@)
  73.  
  74. Warns about something only once.
  75.  
  76. =item _choke(@)
  77.  
  78. Dies with a special message.
  79.  
  80. =end _private
  81.  
  82. =cut
  83.  
  84. my $Is_VMS     = $^O eq 'VMS';
  85. my $Is_MacPerl = $^O eq 'MacOS';
  86. my $Is_Win32   = $^O eq 'MSWin32';
  87. my $Is_cygwin  = $^O eq 'cygwin';
  88. my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);
  89.  
  90. # *note* CanMoveAtBoot is only incidentally the same condition as below
  91. # this needs not hold true in the future.
  92. my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
  93.     ? (eval {require Win32API::File; 1} || 0)
  94.     : 0;
  95.  
  96.  
  97. my $Inc_uninstall_warn_handler;
  98.  
  99. # install relative to here
  100.  
  101. my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
  102.  
  103. my $Curdir = File::Spec->curdir;
  104. my $Updir  = File::Spec->updir;
  105.  
  106. sub _estr(@) {
  107.     return join "\n",'!' x 72,@_,'!' x 72,'';
  108. }
  109.  
  110. {my %warned;
  111. sub _warnonce(@) {
  112.     my $first=shift;
  113.     my $msg=_estr "WARNING: $first",@_;
  114.     warn $msg unless $warned{$msg}++;
  115. }}
  116.  
  117. sub _choke(@) {
  118.     my $first=shift;
  119.     my $msg=_estr "ERROR: $first",@_;
  120.     Carp::croak($msg);
  121. }
  122.  
  123.  
  124. sub _chmod($$;$) {
  125.     my ( $mode, $item, $verbose )=@_;
  126.     $verbose ||= 0;
  127.     if (chmod $mode, $item) {
  128.         print "chmod($mode, $item)\n" if $verbose > 1;
  129.     } else {
  130.         my $err="$!";
  131.         _warnonce "WARNING: Failed chmod($mode, $item): $err\n"
  132.             if -e $item;
  133.     }
  134. }
  135.  
  136. =begin _private
  137.  
  138. =item _move_file_at_boot( $file, $target, $moan  )
  139.  
  140. OS-Specific, Win32/Cygwin
  141.  
  142. Schedules a file to be moved/renamed/deleted at next boot.
  143. $file should be a filespec of an existing file
  144. $target should be a ref to an array if the file is to be deleted
  145. otherwise it should be a filespec for a rename. If the file is existing
  146. it will be replaced.
  147.  
  148. Sets $MUST_REBOOT to 0 to indicate a deletion operation has occured
  149. and sets it to 1 to indicate that a move operation has been requested.
  150.  
  151. returns 1 on success, on failure if $moan is false errors are fatal.
  152. If $moan is true then returns 0 on error and warns instead of dies.
  153.  
  154. =end _private
  155.  
  156. =cut
  157.  
  158.  
  159.  
  160. sub _move_file_at_boot { #XXX OS-SPECIFIC
  161.     my ( $file, $target, $moan  )= @_;
  162.     Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
  163.          unless $CanMoveAtBoot;
  164.  
  165.     my $descr= ref $target
  166.                 ? "'$file' for deletion"
  167.                 : "'$file' for installation as '$target'";
  168.  
  169.     if ( ! $Has_Win32API_File ) {
  170.  
  171.         my @msg=(
  172.             "Cannot schedule $descr at reboot.",
  173.             "Try installing Win32API::File to allow operations on locked files",
  174.             "to be scheduled during reboot. Or try to perform the operation by",
  175.             "hand yourself. (You may need to close other perl processes first)"
  176.         );
  177.         if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
  178.         return 0;
  179.     }
  180.     my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
  181.     $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
  182.         unless ref $target;
  183.  
  184.     _chmod( 0666, $file );
  185.     _chmod( 0666, $target ) unless ref $target;
  186.  
  187.     if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
  188.         $MUST_REBOOT ||= ref $target ? 0 : 1;
  189.         return 1;
  190.     } else {
  191.         my @msg=(
  192.             "MoveFileEx $descr at reboot failed: $^E",
  193.             "You may try to perform the operation by hand yourself. ",
  194.             "(You may need to close other perl processes first).",
  195.         );
  196.         if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
  197.     }
  198.     return 0;
  199. }
  200.  
  201.  
  202. =begin _private
  203.  
  204. =item _unlink_or_rename( $file, $tryhard, $installing )
  205.  
  206. OS-Specific, Win32/Cygwin
  207.  
  208. Tries to get a file out of the way by unlinking it or renaming it. On
  209. some OS'es (Win32 based) DLL files can end up locked such that they can
  210. be renamed but not deleted. Likewise sometimes a file can be locked such
  211. that it cant even be renamed or changed except at reboot. To handle
  212. these cases this routine finds a tempfile name that it can either rename
  213. the file out of the way or use as a proxy for the install so that the
  214. rename can happen later (at reboot).
  215.  
  216.   $file : the file to remove.
  217.   $tryhard : should advanced tricks be used for deletion
  218.   $installing : we are not merely deleting but we want to overwrite
  219.  
  220. When $tryhard is not true if the unlink fails its fatal. When $tryhard
  221. is true then the file is attempted to be renamed. The renamed file is
  222. then scheduled for deletion. If the rename fails then $installing
  223. governs what happens. If it is false the failure is fatal. If it is true
  224. then an attempt is made to schedule installation at boot using a
  225. temporary file to hold the new file. If this fails then a fatal error is
  226. thrown, if it succeeds it returns the temporary file name (which will be
  227. a derivative of the original in the same directory) so that the caller can
  228. use it to install under. In all other cases of success returns $file.
  229. On failure throws a fatal error.
  230.  
  231. =end _private
  232.  
  233. =cut
  234.  
  235.  
  236.  
  237. sub _unlink_or_rename { #XXX OS-SPECIFIC
  238.     my ( $file, $tryhard, $installing )= @_;
  239.  
  240.     _chmod( 0666, $file );
  241.     unlink $file
  242.         and return $file;
  243.     my $error="$!";
  244.  
  245.     _choke("Cannot unlink '$file': $!")
  246.           unless $CanMoveAtBoot && $tryhard;
  247.  
  248.     my $tmp= "AAA";
  249.     ++$tmp while -e "$file.$tmp";
  250.     $tmp= "$file.$tmp";
  251.  
  252.     warn "WARNING: Unable to unlink '$file': $error\n",
  253.          "Going to try to rename it to '$tmp'.\n";
  254.  
  255.     if ( rename $file, $tmp ) {
  256.         warn "Rename succesful. Scheduling '$tmp'\nfor deletion at reboot.\n";
  257.         # when $installing we can set $moan to true.
  258.         # IOW, if we cant delete the renamed file at reboot its
  259.         # not the end of the world. The other cases are more serious
  260.         # and need to be fatal.
  261.         _move_file_at_boot( $tmp, [], $installing );
  262.         return $file;
  263.     } elsif ( $installing ) {
  264.         _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
  265.              " installation as '$file' at reboot.\n");
  266.         _move_file_at_boot( $tmp, $file );
  267.         return $tmp;
  268.     } else {
  269.         _choke("Rename failed:$!", "Cannot procede.");
  270.     }
  271.  
  272. }
  273.  
  274.  
  275.  
  276. =head2 Functions
  277.  
  278. =over 4
  279.  
  280. =item B<install>
  281.  
  282.     install(\%from_to);
  283.     install(\%from_to, $verbose, $dont_execute, $uninstall_shadows, $skip);
  284.  
  285. Copies each directory tree of %from_to to its corresponding value
  286. preserving timestamps and permissions.
  287.  
  288. There are two keys with a special meaning in the hash: "read" and
  289. "write".  These contain packlist files.  After the copying is done,
  290. install() will write the list of target files to $from_to{write}. If
  291. $from_to{read} is given the contents of this file will be merged into
  292. the written file. The read and the written file may be identical, but
  293. on AFS it is quite likely that people are installing to a different
  294. directory than the one where the files later appear.
  295.  
  296. If $verbose is true, will print out each file removed.  Default is
  297. false.  This is "make install VERBINST=1". $verbose values going
  298. up to 5 show increasingly more diagnostics output.
  299.  
  300. If $dont_execute is true it will only print what it was going to do
  301. without actually doing it.  Default is false.
  302.  
  303. If $uninstall_shadows is true any differing versions throughout @INC
  304. will be uninstalled.  This is "make install UNINST=1"
  305.  
  306. As of 1.37_02 install() supports the use of a list of patterns to filter
  307. out files that shouldn't be installed. If $skip is omitted or undefined
  308. then install will try to read the list from INSTALL.SKIP in the CWD.
  309. This file is a list of regular expressions and is just like the
  310. MANIFEST.SKIP file used by L<ExtUtils::Manifest>.
  311.  
  312. A default site INSTALL.SKIP may be provided by setting then environment
  313. variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there
  314. isn't a distribution specific INSTALL.SKIP. If the environment variable
  315. EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
  316. performed.
  317.  
  318. If $skip is undefined then the skip file will be autodetected and used if it
  319. is found. If $skip is a reference to an array then it is assumed
  320. the array contains the list of patterns, if $skip is a true non reference it is
  321. assumed to be the filename holding the list of patterns, any other value of
  322. $skip is taken to mean that no install filtering should occur.
  323.  
  324.  
  325. =cut
  326.  
  327. =begin _private
  328.  
  329. =item _get_install_skip
  330.  
  331. Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
  332.  
  333. =cut
  334.  
  335.  
  336.  
  337. sub _get_install_skip {
  338.     my ( $skip, $verbose )= @_;
  339.     if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
  340.         print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
  341.             if $verbose>2;
  342.         return [];
  343.     }
  344.     if ( ! defined $skip ) {
  345.         print "Looking for install skip list\n"
  346.             if $verbose>2;
  347.         for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
  348.             next unless $file;
  349.             print "\tChecking for $file\n"
  350.                 if $verbose>2;
  351.             if (-e $file) {
  352.                 $skip= $file;
  353.                 last;
  354.             }
  355.         }
  356.     }
  357.     if ($skip && !ref $skip) {
  358.         print "Reading skip patterns from '$skip'.\n"
  359.             if $verbose;
  360.         if (open my $fh,$skip ) {
  361.             my @patterns;
  362.             while (<$fh>) {
  363.                 chomp;
  364.                 next if /^\s*(?:#|$)/;
  365.                 print "\tSkip pattern: $_\n" if $verbose>3;
  366.                 push @patterns, $_;
  367.             }
  368.             $skip= \@patterns;
  369.         } else {
  370.             warn "Can't read skip file:'$skip':$!\n";
  371.             $skip=[];
  372.         }
  373.     } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
  374.         print "Using array for skip list\n"
  375.             if $verbose>2;
  376.     } elsif ($verbose) {
  377.         print "No skip list found.\n"
  378.             if $verbose>1;
  379.         $skip= [];
  380.     }
  381.     warn "Got @{[0+@$skip]} skip patterns.\n"
  382.         if $verbose>3;
  383.     return $skip
  384. }
  385.  
  386. =item _have_write_access
  387.  
  388. Abstract a -w check that tries to use POSIX::access() if possible.
  389.  
  390. =cut
  391.  
  392.  
  393. {
  394.     my  $has_posix;
  395.     sub _have_write_access {
  396.         my $dir=shift;
  397.         if (!defined $has_posix) {
  398.             $has_posix=eval "local $^W; require POSIX; 1" || 0;
  399.         }
  400.         if ($has_posix) {
  401.             return POSIX::access($dir, POSIX::W_OK());
  402.         } else {
  403.             return -w $dir;
  404.         }
  405.     }
  406. }
  407.  
  408.  
  409. =item _can_write_dir(C<$dir>)
  410.  
  411. Checks whether a given directory is writable, taking account
  412. the possibility that the directory might not exist and would have to
  413. be created first.
  414.  
  415. Returns a list, containing: C<($writable, $determined_by, @create)>
  416.  
  417. C<$writable> says whether whether the directory is (hypothetically) writable
  418.  
  419. C<$determined_by> is the directory the status was determined from. It will be
  420. either the C<$dir>, or one of its parents.
  421.  
  422. C<@create> is a list of directories that would probably have to be created
  423. to make the requested directory. It may not actually be correct on
  424. relative paths with C<..> in them. But for our purposes it should work ok
  425.  
  426. =cut
  427.  
  428.  
  429. sub _can_write_dir {
  430.     my $dir=shift;
  431.     return
  432.         unless defined $dir and length $dir;
  433.  
  434.     my ($vol, $dirs, $file) = File::Spec->splitpath(File::Spec->rel2abs($dir),1);
  435.     my @dirs = File::Spec->splitdir($dirs);
  436.     my $path='';
  437.     my @make;
  438.     while (@dirs) {
  439.         $dir = File::Spec->catdir($vol,@dirs);
  440.         next if ( $dir eq $path );
  441.         if ( ! -e $dir ) {
  442.             unshift @make,$dir;
  443.             next;
  444.         }
  445.         if ( _have_write_access($dir) ) {
  446.             return 1,$dir,@make
  447.         } else {
  448.             return 0,$dir,@make
  449.         }
  450.     } continue {
  451.         pop @dirs;
  452.     }
  453.     return 0;
  454. }
  455.  
  456. =item _mkpath($dir,$show,$verbose,$fake)
  457.  
  458. Wrapper around File::Path::mkpath() to handle errors.
  459.  
  460. If $verbose is true and >1 then additional diagnostics will be produced, also
  461. this will force $show to true.
  462.  
  463. If $fake is true then the directory will not be created but a check will be
  464. made to see whether it would be possible to write to the directory, or that
  465. it would be possible to create the directory.
  466.  
  467. If $fake is not true dies if the directory can not be created or is not
  468. writable.
  469.  
  470. =cut
  471.  
  472. sub _mkpath {
  473.     my ($dir,$show,$verbose,$fake)=@_;
  474.     if ( $verbose && $verbose > 1 && ! -d $dir) {
  475.         $show= 1;
  476.         printf "mkpath(%s,%d)\n", $dir, $show;
  477.     }
  478.     if (!$fake) {
  479.         if ( ! eval { File::Path::mkpath($dir,$show); 1 } ) {
  480.             _choke("Can't create '$dir'","$@");
  481.         }
  482.  
  483.     }
  484.     my ($can,$root,@make)=_can_write_dir($dir);
  485.     if (!$can) {
  486.         my @msg=(
  487.             "Can't create '$dir'",
  488.             $root ? "Do not have write permissions on '$root'"
  489.                   : "Unknown Error"
  490.         );
  491.         if ($fake) {
  492.             _warnonce @msg;
  493.         } else {
  494.             _choke @msg;
  495.         }
  496.     } elsif ($show and $fake) {
  497.         print "$_\n" for @make;
  498.     }
  499. }
  500.  
  501. =item _copy($from,$to,$verbose,$fake)
  502.  
  503. Wrapper around File::Copy::copy to handle errors.
  504.  
  505. If $verbose is true and >1 then additional dignostics will be emitted.
  506.  
  507. If $fake is true then the copy will not actually occur.
  508.  
  509. Dies if the copy fails.
  510.  
  511. =cut
  512.  
  513.  
  514. sub _copy {
  515.     my ( $from, $to, $verbose, $nonono)=@_;
  516.     if ($verbose && $verbose>1) {
  517.         printf "copy(%s,%s)\n", $from, $to;
  518.     }
  519.     if (!$nonono) {
  520.         File::Copy::copy($from,$to)
  521.             or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
  522.     }
  523. }
  524.  
  525. =item _chdir($from)
  526.  
  527. Wrapper around chdir to catch errors.
  528.  
  529. If not called in void context returns the cwd from before the chdir.
  530.  
  531. dies on error.
  532.  
  533. =cut
  534.  
  535. sub _chdir {
  536.     my ($dir)= @_;
  537.     my $ret;
  538.     if (defined wantarray) {
  539.         $ret= cwd;
  540.     }
  541.     chdir $dir
  542.         or _choke("Couldn't chdir to '$dir': $!");
  543.     return $ret;
  544. }
  545.  
  546. =end _private
  547.  
  548. =cut
  549.  
  550. sub install { #XXX OS-SPECIFIC
  551.     my($from_to,$verbose,$nonono,$inc_uninstall,$skip) = @_;
  552.     $verbose ||= 0;
  553.     $nonono  ||= 0;
  554.  
  555.     $skip= _get_install_skip($skip,$verbose);
  556.  
  557.     my(%from_to) = %$from_to;
  558.     my(%pack, $dir, %warned);
  559.     my($packlist) = ExtUtils::Packlist->new();
  560.  
  561.     local(*DIR);
  562.     for (qw/read write/) {
  563.         $pack{$_}=$from_to{$_};
  564.         delete $from_to{$_};
  565.     }
  566.     my $tmpfile = install_rooted_file($pack{"read"});
  567.     $packlist->read($tmpfile) if (-f $tmpfile);
  568.     my $cwd = cwd();
  569.     my @found_files;
  570.     my %check_dirs;
  571.     
  572.     MOD_INSTALL: foreach my $source (sort keys %from_to) {
  573.         #copy the tree to the target directory without altering
  574.         #timestamp and permission and remember for the .packlist
  575.         #file. The packlist file contains the absolute paths of the
  576.         #install locations. AFS users may call this a bug. We'll have
  577.         #to reconsider how to add the means to satisfy AFS users also.
  578.  
  579.         #October 1997: we want to install .pm files into archlib if
  580.         #there are any files in arch. So we depend on having ./blib/arch
  581.         #hardcoded here.
  582.  
  583.         my $targetroot = install_rooted_dir($from_to{$source});
  584.  
  585.         my $blib_lib  = File::Spec->catdir('blib', 'lib');
  586.         my $blib_arch = File::Spec->catdir('blib', 'arch');
  587.         if ($source eq $blib_lib and
  588.             exists $from_to{$blib_arch} and
  589.             directory_not_empty($blib_arch)
  590.         ){
  591.             $targetroot = install_rooted_dir($from_to{$blib_arch});
  592.             print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
  593.         }
  594.  
  595.         next unless -d $source;
  596.         _chdir($source);
  597.         # 5.5.3's File::Find missing no_chdir option
  598.         # XXX OS-SPECIFIC
  599.         # File::Find seems to always be Unixy except on MacPerl :(
  600.         my $current_directory= $Is_MacPerl ? $Curdir : '.';
  601.         find(sub {
  602.             my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
  603.  
  604.             return if !-f _;
  605.             my $origfile = $_;
  606.  
  607.             return if $origfile eq ".exists";
  608.             my $targetdir  = File::Spec->catdir($targetroot, $File::Find::dir);
  609.             my $targetfile = File::Spec->catfile($targetdir, $origfile);
  610.             my $sourcedir  = File::Spec->catdir($source, $File::Find::dir);
  611.             my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
  612.  
  613.             for my $pat (@$skip) {
  614.                 if ( $sourcefile=~/$pat/ ) {
  615.                     print "Skipping $targetfile (filtered)\n"
  616.                         if $verbose>1;
  617.                     return;
  618.                 }
  619.             }
  620.             # we have to do this for back compat with old File::Finds
  621.             # and because the target is relative
  622.             my $save_cwd = _chdir($cwd); 
  623.             my $diff = 0;
  624.             if ( -f $targetfile && -s _ == $size) {
  625.                 # We have a good chance, we can skip this one
  626.                 $diff = compare($sourcefile, $targetfile);
  627.             } else {
  628.                 $diff++;
  629.             }
  630.             $check_dirs{$targetdir}++ 
  631.                 unless -w $targetfile;
  632.             
  633.             push @found_files,
  634.                 [ $diff, $File::Find::dir, $origfile,
  635.                   $mode, $size, $atime, $mtime,
  636.                   $targetdir, $targetfile, $sourcedir, $sourcefile,
  637.                   
  638.                 ];  
  639.             #restore the original directory we were in when File::Find
  640.             #called us so that it doesnt get horribly confused.
  641.             _chdir($save_cwd);                
  642.         }, $current_directory ); 
  643.         _chdir($cwd);
  644.     }   
  645.     
  646.     foreach my $targetdir (sort keys %check_dirs) {
  647.         _mkpath( $targetdir, 0, $verbose, $nonono );
  648.     }
  649.     foreach my $found (@found_files) {
  650.         my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
  651.             $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
  652.         
  653.         my $realtarget= $targetfile;
  654.         if ($diff) {
  655.             if (-f $targetfile) {
  656.                 print "_unlink_or_rename($targetfile)\n" if $verbose>1;
  657.                 $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
  658.                     unless $nonono;
  659.             } elsif ( ! -d $targetdir ) {
  660.                 _mkpath( $targetdir, 0, $verbose, $nonono );
  661.             }
  662.             print "Installing $targetfile\n";
  663.             _copy( $sourcefile, $targetfile, $verbose, $nonono, );
  664.             #XXX OS-SPECIFIC
  665.             print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
  666.             utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
  667.  
  668.  
  669.             $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
  670.             $mode = $mode | 0222
  671.                 if $realtarget ne $targetfile;
  672.             _chmod( $mode, $targetfile, $verbose );
  673.         } else {
  674.             print "Skipping $targetfile (unchanged)\n" if $verbose;
  675.         }
  676.  
  677.         if ( $inc_uninstall ) {
  678.             inc_uninstall($sourcefile,$ffd, $verbose,
  679.                           $nonono,
  680.                           $realtarget ne $targetfile ? $realtarget : "");
  681.         }
  682.  
  683.         # Record the full pathname.
  684.         $packlist->{$targetfile}++;
  685.     }
  686.  
  687.     if ($pack{'write'}) {
  688.         $dir = install_rooted_dir(dirname($pack{'write'}));
  689.         _mkpath( $dir, 0, $verbose, $nonono );
  690.         print "Writing $pack{'write'}\n";
  691.         $packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
  692.     }
  693.  
  694.     _do_cleanup($verbose);
  695. }
  696.  
  697. =begin _private
  698.  
  699. =item _do_cleanup
  700.  
  701. Standardize finish event for after another instruction has occured.
  702. Handles converting $MUST_REBOOT to a die for instance.
  703.  
  704. =end _private
  705.  
  706. =cut
  707.  
  708. sub _do_cleanup {
  709.     my ($verbose) = @_;
  710.     if ($MUST_REBOOT) {
  711.         die _estr "Operation not completed! ",
  712.             "You must reboot to complete the installation.",
  713.             "Sorry.";
  714.     } elsif (defined $MUST_REBOOT & $verbose) {
  715.         warn _estr "Installation will be completed at the next reboot.\n",
  716.              "However it is not necessary to reboot immediately.\n";
  717.     }
  718. }
  719.  
  720. =begin _undocumented
  721.  
  722. =item install_rooted_file( $file )
  723.  
  724. Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
  725. is defined.
  726.  
  727. =item install_rooted_dir( $dir )
  728.  
  729. Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
  730. is defined.
  731.  
  732. =end _undocumented
  733.  
  734. =cut
  735.  
  736.  
  737. sub install_rooted_file {
  738.     if (defined $INSTALL_ROOT) {
  739.         File::Spec->catfile($INSTALL_ROOT, $_[0]);
  740.     } else {
  741.         $_[0];
  742.     }
  743. }
  744.  
  745.  
  746. sub install_rooted_dir {
  747.     if (defined $INSTALL_ROOT) {
  748.         File::Spec->catdir($INSTALL_ROOT, $_[0]);
  749.     } else {
  750.         $_[0];
  751.     }
  752. }
  753.  
  754. =begin _undocumented
  755.  
  756. =item forceunlink( $file, $tryhard )
  757.  
  758. Tries to delete a file. If $tryhard is true then we will use whatever
  759. devious tricks we can to delete the file. Currently this only applies to
  760. Win32 in that it will try to use Win32API::File to schedule a delete at
  761. reboot. A wrapper for _unlink_or_rename().
  762.  
  763. =end _undocumented
  764.  
  765. =cut
  766.  
  767.  
  768. sub forceunlink {
  769.     my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
  770.     _unlink_or_rename( $file, $tryhard );
  771. }
  772.  
  773. =begin _undocumented
  774.  
  775. =item directory_not_empty( $dir )
  776.  
  777. Returns 1 if there is an .exists file somewhere in a directory tree.
  778. Returns 0 if there is not.
  779.  
  780. =end _undocumented
  781.  
  782. =cut
  783.  
  784. sub directory_not_empty ($) {
  785.   my($dir) = @_;
  786.   my $files = 0;
  787.   find(sub {
  788.            return if $_ eq ".exists";
  789.            if (-f) {
  790.              $File::Find::prune++;
  791.              $files = 1;
  792.            }
  793.        }, $dir);
  794.   return $files;
  795. }
  796.  
  797.  
  798. =item B<install_default> I<DISCOURAGED>
  799.  
  800.     install_default();
  801.     install_default($fullext);
  802.  
  803. Calls install() with arguments to copy a module from blib/ to the
  804. default site installation location.
  805.  
  806. $fullext is the name of the module converted to a directory
  807. (ie. Foo::Bar would be Foo/Bar).  If $fullext is not specified, it
  808. will attempt to read it from @ARGV.
  809.  
  810. This is primarily useful for install scripts.
  811.  
  812. B<NOTE> This function is not really useful because of the hard-coded
  813. install location with no way to control site vs core vs vendor
  814. directories and the strange way in which the module name is given.
  815. Consider its use discouraged.
  816.  
  817. =cut
  818.  
  819. sub install_default {
  820.   @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
  821.   my $FULLEXT = @_ ? shift : $ARGV[0];
  822.   defined $FULLEXT or die "Do not know to where to write install log";
  823.   my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
  824.   my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
  825.   my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
  826.   my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
  827.   my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
  828.   my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
  829.   install({
  830.            read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
  831.            write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
  832.            $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
  833.                          $Config{installsitearch} :
  834.                          $Config{installsitelib},
  835.            $INST_ARCHLIB => $Config{installsitearch},
  836.            $INST_BIN => $Config{installbin} ,
  837.            $INST_SCRIPT => $Config{installscript},
  838.            $INST_MAN1DIR => $Config{installman1dir},
  839.            $INST_MAN3DIR => $Config{installman3dir},
  840.           },1,0,0);
  841. }
  842.  
  843.  
  844. =item B<uninstall>
  845.  
  846.     uninstall($packlist_file);
  847.     uninstall($packlist_file, $verbose, $dont_execute);
  848.  
  849. Removes the files listed in a $packlist_file.
  850.  
  851. If $verbose is true, will print out each file removed.  Default is
  852. false.
  853.  
  854. If $dont_execute is true it will only print what it was going to do
  855. without actually doing it.  Default is false.
  856.  
  857. =cut
  858.  
  859. sub uninstall {
  860.     my($fil,$verbose,$nonono) = @_;
  861.     $verbose ||= 0;
  862.     $nonono  ||= 0;
  863.  
  864.     die _estr "ERROR: no packlist file found: '$fil'"
  865.         unless -f $fil;
  866.     # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
  867.     # require $my_req; # Hairy, but for the first
  868.     my ($packlist) = ExtUtils::Packlist->new($fil);
  869.     foreach (sort(keys(%$packlist))) {
  870.         chomp;
  871.         print "unlink $_\n" if $verbose;
  872.         forceunlink($_,'tryhard') unless $nonono;
  873.     }
  874.     print "unlink $fil\n" if $verbose;
  875.     forceunlink($fil, 'tryhard') unless $nonono;
  876.     _do_cleanup($verbose);
  877. }
  878.  
  879. =begin _undocumented
  880.  
  881. =item inc_uninstall($filepath,$libdir,$verbose,$nonono,$ignore)
  882.  
  883. Remove shadowed files. If $ignore is true then it is assumed to hold
  884. a filename to ignore. This is used to prevent spurious warnings from
  885. occuring when doing an install at reboot.
  886.  
  887. =end _undocumented
  888.  
  889. =cut
  890.  
  891. sub inc_uninstall {
  892.     my($filepath,$libdir,$verbose,$nonono,$ignore) = @_;
  893.     my($dir);
  894.     $ignore||="";
  895.     my $file = (File::Spec->splitpath($filepath))[2];
  896.     my %seen_dir = ();
  897.  
  898.     my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
  899.       ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
  900.  
  901.     foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
  902.                                                   privlibexp
  903.                                                   sitearchexp
  904.                                                   sitelibexp)}) {
  905.         my $canonpath = File::Spec->canonpath($dir);
  906.         next if $canonpath eq $Curdir;
  907.         next if $seen_dir{$canonpath}++;
  908.         my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
  909.         next unless -f $targetfile;
  910.  
  911.         # The reason why we compare file's contents is, that we cannot
  912.         # know, which is the file we just installed (AFS). So we leave
  913.         # an identical file in place
  914.         my $diff = 0;
  915.         if ( -f $targetfile && -s _ == -s $filepath) {
  916.             # We have a good chance, we can skip this one
  917.             $diff = compare($filepath,$targetfile);
  918.         } else {
  919.             $diff++;
  920.         }
  921.         print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
  922.  
  923.         next if !$diff or $targetfile eq $ignore;
  924.         if ($nonono) {
  925.             if ($verbose) {
  926.                 $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
  927.                 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
  928.                 $Inc_uninstall_warn_handler->add(
  929.                                      File::Spec->catfile($libdir, $file),
  930.                                      $targetfile
  931.                                     );
  932.             }
  933.             # if not verbose, we just say nothing
  934.         } else {
  935.             print "Unlinking $targetfile (shadowing?)\n" if $verbose;
  936.             forceunlink($targetfile,'tryhard');
  937.         }
  938.     }
  939. }
  940.  
  941. =begin _undocumented
  942.  
  943. =item run_filter($cmd,$src,$dest)
  944.  
  945. Filter $src using $cmd into $dest.
  946.  
  947. =end _undocumented
  948.  
  949. =cut
  950.  
  951. sub run_filter {
  952.     my ($cmd, $src, $dest) = @_;
  953.     local(*CMD, *SRC);
  954.     open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
  955.     open(SRC, $src)           || die "Cannot open $src: $!";
  956.     my $buf;
  957.     my $sz = 1024;
  958.     while (my $len = sysread(SRC, $buf, $sz)) {
  959.         syswrite(CMD, $buf, $len);
  960.     }
  961.     close SRC;
  962.     close CMD or die "Filter command '$cmd' failed for $src";
  963. }
  964.  
  965.  
  966. =item B<pm_to_blib>
  967.  
  968.     pm_to_blib(\%from_to, $autosplit_dir);
  969.     pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
  970.  
  971. Copies each key of %from_to to its corresponding value efficiently.
  972. Filenames with the extension .pm are autosplit into the $autosplit_dir.
  973. Any destination directories are created.
  974.  
  975. $filter_cmd is an optional shell command to run each .pm file through
  976. prior to splitting and copying.  Input is the contents of the module,
  977. output the new module contents.
  978.  
  979. You can have an environment variable PERL_INSTALL_ROOT set which will
  980. be prepended as a directory to each installed file (and directory).
  981.  
  982. =cut
  983.  
  984. sub pm_to_blib {
  985.     my($fromto,$autodir,$pm_filter) = @_;
  986.  
  987.     _mkpath($autodir,0);
  988.     while(my($from, $to) = each %$fromto) {
  989.         if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
  990.             print "Skip $to (unchanged)\n";
  991.             next;
  992.         }
  993.  
  994.         # When a pm_filter is defined, we need to pre-process the source first
  995.         # to determine whether it has changed or not.  Therefore, only perform
  996.         # the comparison check when there's no filter to be ran.
  997.         #    -- RAM, 03/01/2001
  998.  
  999.         my $need_filtering = defined $pm_filter && length $pm_filter &&
  1000.                              $from =~ /\.pm$/;
  1001.  
  1002.         if (!$need_filtering && 0 == compare($from,$to)) {
  1003.             print "Skip $to (unchanged)\n";
  1004.             next;
  1005.         }
  1006.         if (-f $to){
  1007.             # we wont try hard here. its too likely to mess things up.
  1008.             forceunlink($to);
  1009.         } else {
  1010.             _mkpath(dirname($to),0);
  1011.         }
  1012.         if ($need_filtering) {
  1013.             run_filter($pm_filter, $from, $to);
  1014.             print "$pm_filter <$from >$to\n";
  1015.         } else {
  1016.             _copy( $from, $to );
  1017.             print "cp $from $to\n";
  1018.         }
  1019.         my($mode,$atime,$mtime) = (stat $from)[2,8,9];
  1020.         utime($atime,$mtime+$Is_VMS,$to);
  1021.         _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
  1022.         next unless $from =~ /\.pm$/;
  1023.         _autosplit($to,$autodir);
  1024.     }
  1025. }
  1026.  
  1027.  
  1028. =begin _private
  1029.  
  1030. =item _autosplit
  1031.  
  1032. From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
  1033. the file being split.  This causes problems on systems with mandatory
  1034. locking (ie. Windows).  So we wrap it and close the filehandle.
  1035.  
  1036. =end _private
  1037.  
  1038. =cut
  1039.  
  1040. sub _autosplit { #XXX OS-SPECIFIC
  1041.     my $retval = autosplit(@_);
  1042.     close *AutoSplit::IN if defined *AutoSplit::IN{IO};
  1043.  
  1044.     return $retval;
  1045. }
  1046.  
  1047.  
  1048. package ExtUtils::Install::Warn;
  1049.  
  1050. sub new { bless {}, shift }
  1051.  
  1052. sub add {
  1053.     my($self,$file,$targetfile) = @_;
  1054.     push @{$self->{$file}}, $targetfile;
  1055. }
  1056.  
  1057. sub DESTROY {
  1058.     unless(defined $INSTALL_ROOT) {
  1059.         my $self = shift;
  1060.         my($file,$i,$plural);
  1061.         foreach $file (sort keys %$self) {
  1062.             $plural = @{$self->{$file}} > 1 ? "s" : "";
  1063.             print "## Differing version$plural of $file found. You might like to\n";
  1064.             for (0..$#{$self->{$file}}) {
  1065.                 print "rm ", $self->{$file}[$_], "\n";
  1066.                 $i++;
  1067.             }
  1068.         }
  1069.         $plural = $i>1 ? "all those files" : "this file";
  1070.         my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
  1071.                  ? ( $Config::Config{make} || 'make' ).' install UNINST=1'
  1072.                  : './Build install uninst=1';
  1073.         print "## Running '$inst' will unlink $plural for you.\n";
  1074.     }
  1075. }
  1076.  
  1077. =begin _private
  1078.  
  1079. =item _invokant
  1080.  
  1081. Does a heuristic on the stack to see who called us for more intelligent
  1082. error messages. Currently assumes we will be called only by Module::Build
  1083. or by ExtUtils::MakeMaker.
  1084.  
  1085. =end _private
  1086.  
  1087. =cut
  1088.  
  1089. sub _invokant {
  1090.     my @stack;
  1091.     my $frame = 0;
  1092.     while (my $file = (caller($frame++))[1]) {
  1093.         push @stack, (File::Spec->splitpath($file))[2];
  1094.     }
  1095.  
  1096.     my $builder;
  1097.     my $top = pop @stack;
  1098.     if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
  1099.         $builder = 'Module::Build';
  1100.     } else {
  1101.         $builder = 'ExtUtils::MakeMaker';
  1102.     }
  1103.     return $builder;
  1104. }
  1105.  
  1106.  
  1107. =back
  1108.  
  1109. =head1 ENVIRONMENT
  1110.  
  1111. =over 4
  1112.  
  1113. =item B<PERL_INSTALL_ROOT>
  1114.  
  1115. Will be prepended to each install path.
  1116.  
  1117. =item B<EU_INSTALL_IGNORE_SKIP>
  1118.  
  1119. Will prevent the automatic use of INSTALL.SKIP as the install skip file.
  1120.  
  1121. =item B<EU_INSTALL_SITE_SKIPFILE>
  1122.  
  1123. If there is no INSTALL.SKIP file in the make directory then this value
  1124. can be used to provide a default.
  1125.  
  1126. =back
  1127.  
  1128. =head1 AUTHOR
  1129.  
  1130. Original author lost in the mists of time.  Probably the same as Makemaker.
  1131.  
  1132. Production release currently maintained by demerphq C<yves at cpan.org>
  1133.  
  1134. Send bug reports via http://rt.cpan.org/.  Please send your
  1135. generated Makefile along with your report.
  1136.  
  1137. =head1 LICENSE
  1138.  
  1139. This program is free software; you can redistribute it and/or
  1140. modify it under the same terms as Perl itself.
  1141.  
  1142. See L<http://www.perl.com/perl/misc/Artistic.html>
  1143.  
  1144.  
  1145. =cut
  1146.  
  1147. 1;
  1148.