PageRenderTime 32ms CodeModel.GetById 18ms app.highlight 11ms RepoModel.GetById 1ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/site/lib/ppm/relocperl.pm

#
Perl | 87 lines | 71 code | 8 blank | 8 comment | 6 complexity | 45869379f11efe16e1885ed0b40a5b93 MD5 | raw file
 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#
 5package PPM::RelocPerl;
 6require Exporter;
 7
 8@ISA = qw(Exporter);
 9@EXPORT = qw(RelocPerl);
10
11use File::Find;
12use Config;
13use strict;
14
15# We have to build up this variable, otherwise
16# PPM will mash it when it upgrades itself.
17my $frompath_default
18  = '/tmp' . '/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
19;
20my ($topath, $frompath);
21
22sub 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
34sub 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
49sub 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    close(F) or die "Couldn't close $file: $!";
68
69    open(F, ">$file") or die "Couldn't open $file for writing: $!";
70    binmode(F) if $binmode;
71    
72    print F $dat;
73    close(F);
74    # Restore the permissions
75    chmod $mode, $file;
76}
77
78sub RelocPerl
79{
80    my ($dir, $opt_topath, $opt_frompath) = @_;
81    $topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
82    $frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;
83
84    find(\&wanted, $dir);
85}
86
871;