File Coverage

blib/lib/PPM/RelocPerl.pm

Criterion	Covered	Total	%
statement	12	45	26.6
branch	0	24	0.0
condition	0	6	0.0
subroutine	4	8	50.0
pod	0	4	0.0
total	16	87	18.3

#
# 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 () {
        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 = ;
    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;