home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _8a2f1aa92c942bd27283944e4e28593f < prev    next >
Text File  |  2000-03-23  |  5KB  |  228 lines
  1. #!/tmp/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl/bin/perl -w
  2.  
  3. =head1 NAME
  4.  
  5. reloc_perl - relocate a perl installation
  6.  
  7. =head1 SYNOPSIS
  8.  
  9.     reloc_perl [-b] [-d] [-i] [-t] [-r] [-v] toperlpath [fromperlpath]
  10.  
  11. This tool will move a perl installation wholesale to a new location.
  12.  
  13. Edits path names in binaries (e.g., a2p, perl, libperl.a) to reflect the
  14. new location, but preserves the size of strings by null padding them as
  15. necessary.
  16.  
  17. Edits text files by simple substitution.
  18.  
  19. 'toperlpath' cannot be longer than 'fromperlpath'.
  20.  
  21. If 'fromperlpath' is not found in any files, no changes whatsoever
  22. are made.
  23.  
  24. Running the tool without arguments provides more help.
  25.  
  26. =head1 COPYRIGHT
  27.  
  28. (c) 1999, ActiveState Tool Corp.  All rights reserved.
  29.  
  30. =cut
  31.  
  32. BEGIN {
  33.     $tmp = $ENV{'TEMP'} || $ENV{'tmp'} || 
  34.     ($Config{'osname'} eq 'MSWin32' ? 'c:/temp' : '/tmp');
  35.     open(STDERR, ">> $tmp/ActivePerlInstall.log");
  36. }
  37. use strict;
  38. use Config;
  39. use File::Find;
  40. use File::Path qw(mkpath rmtree);
  41. use Getopt::Std;
  42. use vars qw($opt_b $opt_d $opt_i $opt_t $opt_r $opt_v *ARGVOUT);
  43. my $frompath_default
  44.   = '/tmp/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl';
  45.  
  46. getopts('bditrv') or usage('');
  47.  
  48. my $topath    = shift || usage('');
  49. my $frompath    = shift || $frompath_default;
  50. my $bak        = '.~1~';
  51. my $nullpad    = length($frompath) - length($topath);
  52.  
  53. usage("$topath is longer than $frompath")    if $nullpad < 0;
  54.  
  55. $nullpad    = "\0" x $nullpad;
  56.  
  57. if (-d $topath) {
  58.     if (not -d $frompath) {
  59.     warn "Will do inplace edit of `$topath'\n";
  60.     $opt_i++;
  61.     }
  62. }
  63. elsif ($opt_i) {
  64.     usage("Directory `$topath' doesn't exist, can't do inplace edit");
  65. }
  66.  
  67. my(@edit_bin, @edit_txt);
  68.  
  69. sub usage {
  70.     my $msg = shift;
  71.     warn <<EOT;
  72.     $msg
  73.     Usage:
  74.     $0 [-b] [-i] [-t] [-r] toperlpath [fromperlpath]
  75.  
  76.     -b    don't delete backups after edit
  77.     -d    delete source tree after relocation
  78.     -i    edit perl installation at `toperlpath' insitu
  79.             (makes no attempt to move installation, -d is ignored)
  80.     -t      only edit text files
  81.     -r    do not run `ranlib' on *.a files that were edited
  82.     -v    verbose messages
  83.  
  84.     'toperlpath' must be shorter than 'fromperlpath'
  85.  
  86.     'fromperlpath' defaults to '$frompath_default'
  87.  
  88.     -i is assumed if `toperlpath' exists, is a directory, and
  89.     `fromperlpath' doesn't exist.
  90. EOT
  91.     exit(1);
  92. }
  93.  
  94. sub wanted {
  95.     if (-l) {
  96.     return;        # do nothing for symlinks
  97.     }
  98.     elsif (!$opt_t && -B) {
  99.     edit_bin($_);    # binary file edit
  100.     }
  101.     elsif (-e && -s && -f) {
  102.     edit_txt($_);    # text file edit
  103.     }
  104. }
  105.  
  106. sub edit_bin {
  107.     my $file = shift;
  108.     local(*F, $_);
  109.     open(F, "<$file") or die "Can't open `$file': $!";
  110.     binmode F;
  111.     while (<F>) {
  112.     if (/\Q$frompath\E/o) {
  113.         push @edit_bin, $File::Find::name;
  114.         last;
  115.     }
  116.     }
  117.     close F;
  118. }
  119.  
  120. sub edit_txt {
  121.     my $file = shift;
  122.     local(*F, $_);
  123.     open(F, "<$file") or die "Can't open `$file': $!";
  124.     while (<F>) {
  125.     if (/\Q$frompath\E/o) {
  126.         push @edit_txt, $File::Find::name;
  127.         last;
  128.     }
  129.     }
  130.     close F;
  131. }
  132.  
  133.  
  134. # move tree
  135. unless ($opt_i) {
  136.     # create parent path to destination
  137.     my $toparent = $topath;
  138.     $toparent =~ s|^(.*)/.+$|$1|;
  139.     $toparent = '/' if $toparent eq '';
  140.     mkpath($toparent,1,0755) unless -d $toparent;
  141.  
  142. #    # check if they're on same device and do quick rename
  143. #    # XXX not enabled, since doing this is risky (NFS!)
  144. #    if ((stat($toparent))[0] == (stat($frompath))[0]) {
  145. #    warn "renaming $frompath to $topath\n" if $opt_v;
  146. #    rename $frompath, $topath
  147. #        or die "rename $frompath $topath failed: $!";
  148. #    }
  149. #    # must copy
  150. #    else
  151.     {
  152.     # HPUX 11.00 tar gives warnings about uid and gid not existing.
  153.     # -o should shut it off (according to the man page), but doesn't,
  154.     # so we'll use pre-POSIX tar format on HPUX 11.
  155.     my $platform = `uname -a`;
  156.     my $tar_opts = ($platform =~ /hpux11/) ? 'cOf' : 'cf';
  157.  
  158.     my $mvdir = "(cd $frompath; tar $tar_opts - .)|(cd $topath; tar xf -)";
  159.     unless (-d $topath) {
  160.         mkdir $topath, 0755 or die "Can't create `$topath': $!";
  161.     }
  162.     warn "running system('$mvdir')...\n" if $opt_v;
  163.     system($mvdir) == 0 or die "system('$mvdir') failed: $?\n";
  164.     if ($opt_d) {
  165.         warn "deleting $frompath\n" if $opt_v;
  166.         rmtree($frompath,0,0);
  167.     }
  168.     }
  169. }
  170.  
  171. find(\&wanted, $topath);
  172.  
  173. if (@edit_txt or @edit_bin) {
  174.  
  175.     # show affected files
  176.     warn "Configuring Perl installation at $topath\n";
  177.     if ($opt_v) {
  178.     for (@edit_bin,@edit_txt) {
  179.         warn "editing $_\n";
  180.     }
  181.     }
  182.  
  183.     # edit files
  184.     {
  185.     local $^I = $bak;
  186.     if (@edit_txt) {
  187.         local @ARGV = @edit_txt;
  188.         while (<>) {
  189.         s|\Q$frompath\E|$topath|go;
  190.         print;
  191.         close ARGV if eof;
  192.         }
  193.     }
  194.  
  195.     if (@edit_bin) {
  196.         local @ARGV = @edit_bin;
  197.         binmode(ARGV);
  198.         binmode(ARGVOUT);
  199.         while (<>) {
  200.         s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|go;
  201.         print;
  202.         close ARGV if eof;
  203.         }
  204.     }
  205.     }
  206.  
  207.     # clobber backups
  208.     unless ($opt_b) {
  209.     warn "cleaning out backups\n" if $opt_v;
  210.     for (@edit_bin,@edit_txt) {
  211.         unlink "$_$bak";
  212.     }
  213.     }
  214.  
  215.     # run ranlib, where appropriate
  216.     my $ranlib = $Config{ranlib};
  217.     $ranlib = '' if $ranlib =~ /^:?\s*$/;
  218.     if ($ranlib and !$opt_r) {
  219.     for (@edit_bin) {
  220.         if (/\Q$Config{_a}\E$/o) {
  221.         warn "$ranlib $_\n" if $opt_v;
  222.         system("$ranlib $_") == 0 or die "`$ranlib $_' failed: $?\n";
  223.         }
  224.     }
  225.     }
  226. }
  227.  
  228.