summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/PPM/RelocPerl.pm
blob: dc512e500c00c4750fbdde6f7aefab53a827d979 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
#
# Search for our Unix signature in text and binary files
# and replace it with the real prefix ($Config{prefix} by default).
#
package PPM::RelocPerl;
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(RelocPerl);

use File::Find;
use Config;
use strict;
use vars qw( $VERSION );
$VERSION = '0.01_01';

# We have to build up this variable, otherwise
# PPM will mash it when it upgrades itself.
my $frompath_default
  = '/tmp' . '/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
;
my ($topath, $frompath);

sub wanted {
    if (-l) {
        return;         # do nothing for symlinks
    }
    elsif (-B) {
        check_for_frompath($_, 1);   # binary file edit
    }
    elsif (-e && -s && -f) {
        check_for_frompath($_, 0);   # text file edit
    }
}

sub check_for_frompath {
    my ($file, $binmode) = @_;
    local(*F, $_);
    open(F, "<$file") or die "Can't open `$file': $!";
    binmode F if $binmode;
    while (<F>) {
        if (/\Q$frompath\E/o) {
	    close F;
            edit_it($file, $binmode);
            last;
        }
    }
    # implicit close of F;
}

sub edit_it
{
    my ($file, $binmode) = @_;
    my $nullpad = length($frompath) - length($topath);
    $nullpad = "\0" x $nullpad;

    local $/;
    # Force the file to be writable
    my $mode = (stat($file))[2] & 07777;
    chmod $mode | 0222, $file;
    open(F, "+<$file") or die "Couldn't open $file: $!";
    binmode(F) if $binmode;
    my $dat = <F>;
    if ($binmode) {
        $dat =~ s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|gs;
    } else {
        $dat =~ s|\Q$frompath\E|$topath|gs;
    }
    seek(F, 0, 0) or die "Couldn't seek on $file: $!";
    print F $dat;
    close(F);
    # Restore the permissions
    chmod $mode, $file;
}

sub RelocPerl
{
    my ($dir, $opt_topath, $opt_frompath) = @_;
    $topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
    $frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;

    find(\&wanted, $dir);
}

1;