home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _e62e349c76b890402ed10c624633518a < prev    next >
Encoding:
Text File  |  2000-03-15  |  2.0 KB  |  84 lines
  1. #
  2. # Search for our Unix signature in text and binary files
  3. # and replace it with the real prefix ($Config{prefix} by default).
  4. #
  5. package PPM::RelocPerl;
  6. require Exporter;
  7.  
  8. @ISA = qw(Exporter);
  9. @EXPORT = qw(RelocPerl);
  10.  
  11. use File::Find;
  12. use Config;
  13. use strict;
  14.  
  15. # We have to build up this variable, otherwise
  16. # PPM will mash it when it upgrades itself.
  17. my $frompath_default
  18.   = '/tmp' . '/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
  19. ;
  20. my ($topath, $frompath);
  21.  
  22. sub wanted {
  23.     if (-l) {
  24.         return;         # do nothing for symlinks
  25.     }
  26.     elsif (-B) {
  27.         check_for_frompath($_, 1);   # binary file edit
  28.     }
  29.     elsif (-e && -s && -f) {
  30.         check_for_frompath($_, 0);   # text file edit
  31.     }
  32. }
  33.  
  34. sub check_for_frompath {
  35.     my ($file, $binmode) = @_;
  36.     local(*F, $_);
  37.     open(F, "<$file") or die "Can't open `$file': $!";
  38.     binmode F if $binmode;
  39.     while (<F>) {
  40.         if (/\Q$frompath\E/o) {
  41.         close F;
  42.             edit_it($file, $binmode);
  43.             last;
  44.         }
  45.     }
  46.     # implicit close of F;
  47. }
  48.  
  49. sub edit_it
  50. {
  51.     my ($file, $binmode) = @_;
  52.     my $nullpad = length($frompath) - length($topath);
  53.     $nullpad = "\0" x $nullpad;
  54.  
  55.     local $/;
  56.     # Force the file to be writable
  57.     my $mode = (stat($file))[2] & 07777;
  58.     chmod $mode | 0222, $file;
  59.     open(F, "+<$file") or die "Couldn't open $file: $!";
  60.     binmode(F) if $binmode;
  61.     my $dat = <F>;
  62.     if ($binmode) {
  63.         $dat =~ s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|gs;
  64.     } else {
  65.         $dat =~ s|\Q$frompath\E|$topath|gs;
  66.     }
  67.     seek(F, 0, 0) or die "Couldn't seek on $file: $!";
  68.     print F $dat;
  69.     close(F);
  70.     # Restore the permissions
  71.     chmod $mode, $file;
  72. }
  73.  
  74. sub RelocPerl
  75. {
  76.     my ($dir, $opt_topath, $opt_frompath) = @_;
  77.     $topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
  78.     $frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;
  79.  
  80.     find(\&wanted, $dir);
  81. }
  82.  
  83. 1;
  84.