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;
|