Chip 2000 May/Chip_2000-05_cd1.bin/zkuste/Perl/ActivePerl-5.6.0.613.msi/䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥/_8a2f1aa92c942bd27283944e4e28593f

Text File | 2000-03-23 | 5.4 KB | 228 lines

#!/tmp/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl/bin/perl -w

=head1 NAME

reloc_perl - relocate a perl installation

=head1 SYNOPSIS

    reloc_perl [-b] [-d] [-i] [-t] [-r] [-v] toperlpath [fromperlpath]

This tool will move a perl installation wholesale to a new location.

Edits path names in binaries (e.g., a2p, perl, libperl.a) to reflect the
new location, but preserves the size of strings by null padding them as
necessary.

Edits text files by simple substitution.

'toperlpath' cannot be longer than 'fromperlpath'.

If 'fromperlpath' is not found in any files, no changes whatsoever
are made.

Running the tool without arguments provides more help.

=head1 COPYRIGHT

(c) 1999, ActiveState Tool Corp.  All rights reserved.

=cut

BEGIN {
    $tmp = $ENV{'TEMP'} || $ENV{'tmp'} ||
    ($Config{'osname'} eq 'MSWin32' ? 'c:/temp' : '/tmp');
    open(STDERR, ">> $tmp/ActivePerlInstall.log");
}
use strict;
use Config;
use File::Find;
use File::Path qw(mkpath rmtree);
use Getopt::Std;
use vars qw($opt_b $opt_d $opt_i $opt_t $opt_r $opt_v *ARGVOUT);
my $frompath_default
  = '/tmp/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl';

getopts('bditrv') or usage('');

my $topath    = shift || usage('');
my $frompath    = shift || $frompath_default;
my $bak        = '.~1~';
my $nullpad    = length($frompath) - length($topath);

usage("$topath is longer than $frompath")    if $nullpad < 0;

$nullpad    = "\0" x $nullpad;

if (-d $topath) {
    if (not -d $frompath) {
    warn "Will do inplace edit of `$topath'\n";
    $opt_i++;
    }
}
elsif ($opt_i) {
    usage("Directory `$topath' doesn't exist, can't do inplace edit");
}

my(@edit_bin, @edit_txt);

sub usage {
    my $msg = shift;
    warn <<EOT;
    $msg
    Usage:
    $0 [-b] [-i] [-t] [-r] toperlpath [fromperlpath]

    -b    don't delete backups after edit
    -d    delete source tree after relocation
    -i    edit perl installation at `toperlpath' insitu
            (makes no attempt to move installation, -d is ignored)
    -t      only edit text files
    -r    do not run `ranlib' on *.a files that were edited
    -v    verbose messages

    'toperlpath' must be shorter than 'fromperlpath'

    'fromperlpath' defaults to '$frompath_default'

    -i is assumed if `toperlpath' exists, is a directory, and
    `fromperlpath' doesn't exist.
EOT
    exit(1);
}

sub wanted {
    if (-l) {
    return;        # do nothing for symlinks
    }
    elsif (!$opt_t && -B) {
    edit_bin($_);    # binary file edit
    }
    elsif (-e && -s && -f) {
    edit_txt($_);    # text file edit
    }
}

sub edit_bin {
    my $file = shift;
    local(*F, $_);
    open(F, "<$file") or die "Can't open `$file': $!";
    binmode F;
    while (<F>) {
    if (/\Q$frompath\E/o) {
        push @edit_bin, $File::Find::name;
        last;
    }
    }
    close F;
}

sub edit_txt {
    my $file = shift;
    local(*F, $_);
    open(F, "<$file") or die "Can't open `$file': $!";
    while (<F>) {
    if (/\Q$frompath\E/o) {
        push @edit_txt, $File::Find::name;
        last;
    }
    }
    close F;
}


# move tree
unless ($opt_i) {
    # create parent path to destination
    my $toparent = $topath;
    $toparent =~ s|^(.*)/.+$|$1|;
    $toparent = '/' if $toparent eq '';
    mkpath($toparent,1,0755) unless -d $toparent;

#    # check if they're on same device and do quick rename
#    # XXX not enabled, since doing this is risky (NFS!)
#    if ((stat($toparent))[0] == (stat($frompath))[0]) {
#    warn "renaming $frompath to $topath\n" if $opt_v;
#    rename $frompath, $topath
#        or die "rename $frompath $topath failed: $!";
#    }
#    # must copy
#    else
    {
    # HPUX 11.00 tar gives warnings about uid and gid not existing.
    # -o should shut it off (according to the man page), but doesn't,
    # so we'll use pre-POSIX tar format on HPUX 11.
    my $platform = `uname -a`;
    my $tar_opts = ($platform =~ /hpux11/) ? 'cOf' : 'cf';

    my $mvdir = "(cd $frompath; tar $tar_opts - .)|(cd $topath; tar xf -)";
    unless (-d $topath) {
        mkdir $topath, 0755 or die "Can't create `$topath': $!";
    }
    warn "running system('$mvdir')...\n" if $opt_v;
    system($mvdir) == 0 or die "system('$mvdir') failed: $?\n";
    if ($opt_d) {
        warn "deleting $frompath\n" if $opt_v;
        rmtree($frompath,0,0);
    }
    }
}

find(\&wanted, $topath);

if (@edit_txt or @edit_bin) {

    # show affected files
    warn "Configuring Perl installation at $topath\n";
    if ($opt_v) {
    for (@edit_bin,@edit_txt) {
        warn "editing $_\n";
    }
    }

    # edit files
    {
    local $^I = $bak;
    if (@edit_txt) {
        local @ARGV = @edit_txt;
        while (<>) {
        s|\Q$frompath\E|$topath|go;
        print;
        close ARGV if eof;
        }
    }

    if (@edit_bin) {
        local @ARGV = @edit_bin;
        binmode(ARGV);
        binmode(ARGVOUT);
        while (<>) {
        s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|go;
        print;
        close ARGV if eof;
        }
    }
    }

    # clobber backups
    unless ($opt_b) {
    warn "cleaning out backups\n" if $opt_v;
    for (@edit_bin,@edit_txt) {
        unlink "$_$bak";
    }
    }

    # run ranlib, where appropriate
    my $ranlib = $Config{ranlib};
    $ranlib = '' if $ranlib =~ /^:?\s*$/;
    if ($ranlib and !$opt_r) {
    for (@edit_bin) {
        if (/\Q$Config{_a}\E$/o) {
        warn "$ranlib $_\n" if $opt_v;
        system("$ranlib $_") == 0 or die "`$ranlib $_' failed: $?\n";
        }
    }
    }
}