#!/bin/sh
echo Perl2Exe Perl Distribution Setup

# configure perl
if [ -d perl5 ] ; then
  ./perl5/bin/perl -I./perl5/lib -x $0 `pwd`/perl5 `pwd`/perl5
  cd ..
  echo
  echo Please add the following to your PATH:
  echo `pwd`
  echo `pwd`/perl5/bin
  echo
else
  echo
  echo Please add the following to your PATH:
  echo `pwd`
  echo
fi
exit;
#!perl

# Relocate Perl to new directory
my $dir = $ARGV[0];	    # directory containing files to be patched
my $newprefix = $ARGV[1];
# Get old prefix path from @INC
#

use strict;
use File::Find;

=comment
# note -I./perl5/lib will expand to "./perl5/lib;./perl5/lib/5.24.0;./perl5/lib/5.24.0/x86_64-linux-thread-multi"

Patch1:
/perl5-PREFIX-PLACEHOLDER-1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890/lib
/home/indigo/dev/p2x-24.00/build/perl2exe-Linux-5.24.0/perl5/libzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
Patch2:
/home/indigo/dev/p2x-24.00/build/perl2exe-Linux-5.24.0/perl5/libzzzzzzzzzzzz
/home/indigo/dev/p2x-24.00/build/test/perl2exe-Linux-5.24.0/perl5/lib/5.24.0


=cut

#print "Current INC list=\n" . join("\n", @INC) . "\n";
my $oldprefix = $INC[@INC-2]; # last -l

die if ($oldprefix !~ m|/lib.*|);

$oldprefix =~ s|/lib.*||;


print "\n";
print "dir       = $dir\n";
print "oldprefix = $oldprefix\n";
print "newprefix = $newprefix\n\n";

if ($newprefix eq $oldprefix) {
#    print "Nothing to do\n";
#    exit 0;
}


my @flist = dirlist_recursive($dir);
foreach (@flist) {
    my $file = $_;
    #print "file=$file\n";
    check_and_patch($file);
}


sub check_and_patch
{
    my $file = $_;

    return unless  -f && -e;    # skip directories
    return if -l;     # skip symlink

    my $binmode = -B $file;
    #print ("CHECK $file binmode=$binmode\n");

    local(*F, $_);
    open(F, "<$file") or die "Can't open `$file': $!";
    binmode F if $binmode;
    my $data;
    read (F, $data, (-s $file));
    close F;

    if ($binmode) {
        if ($data =~ /\Q$oldprefix\E/o) {
            print ("BIN PATCH $file\n");
            patch_file($file, $oldprefix, $newprefix);

        }
    }
    else {
        if ($data =~ /\Q$oldprefix\E/o) {
            #print ("TXT PATCH $file\n");
            patch_file($file, $oldprefix, $newprefix);
        }
    }
} # sub







sub patch_file
{
    my ($file, $oldstring, $newstring) = @_;

    my $binmode = -B $file;

    local $/;
    my $mode = (stat($file))[2] & 07777;    # save file permissions
    my ($atime, $mtime) = (stat($file))[8,9];   # save file time

    chmod $mode | 0222, $file;     # make file writable
    open(F, "<$file") or die "Couldn't open $file: $!";
    binmode(F) if $binmode;
    my $dat = <F>;
    close F;

    my $oldpad = oldpad($oldstring, $newstring);
    my $newpad = newpad($oldstring, $newstring);

    my $oldzpad = 'z' x length($oldpad);
    my $newzpad = 'z' x length($newpad);


#/perl5-PREFIX-PLACEHOLDER-1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890/libZ
#/home/indigo/dev/p2x-24.00/build/perl2exe-Linux-5.24.0/perl5/libzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzZ


    if ($binmode) {
	$dat =~ s|(\Q$oldstring\E(.*?)$oldpad)\0|$newstring$2$newpad\0|gs;
#	while ($dat =~ m|(\Q$oldstring\E(.*?)$oldpad)\0|gs) {
#		print "MATCH $oldstring$2$oldzpad\n";
#		print "REPLA $newstring$2$newzpad\n";
#	}

    } else {
        $dat =~ s|\Q$oldstring\E|$newstring|gs;
    }

    if (!open(F, ">$file")) {
	# binary perl file may be busy with "Text file busy"
	unlink($file);
        open(F, ">$file") or die "Couldn't open $file for writing: $!";
    }
    binmode(F) if $binmode;
    print F $dat;
    close(F);

    utime($atime, $mtime, $file);    # restore time
    chmod $mode, $file;     # restore file permissions
}

sub oldpad
{
    my ($oldstr, $newstr) = @_;
    my $padlen = length($newstr) - length($oldstr);
    $padlen = 0 if ($padlen < 0);
    #print "old padlen=$padlen\n";
    my $pad = "\0" x $padlen;
    return $pad;
}


sub newpad
{
    my ($oldstr, $newstr) = @_;
    my $padlen = length($oldstr) - length($newstr);
    $padlen = 0 if ($padlen < 0);
    #print "new padlen=$padlen\n";
    my $pad = "\0" x $padlen;
    return $pad;
}


sub paddedstr
{
    # return a new string padded to same length as old
    my ($oldstring, $d1, $newstring) = @_;

    my $d2 = $d1; $d2 =~ s/:.*//;     # remove old padd if any

    my $xpad = 'x' x (length("$oldstring$d1") - length("$newstring$d2:"));

    my $padded = "$newstring$d2:" . $xpad;

    #my $old = "$oldstring$d1";
    #print "OLD=$old\n";
    #print "NEW=$padded\n";

    return $padded;
}







sub dirlist_recursive
{
    my($maindir, $pattern) = @_;

    # recursively get list of files and directories
    # dir = starting directory, $pattern = regular expression
    # to get files only use: @files = grep (-f $_, DirList($dir, $pattern));
    # to remove leading directory path use: my $l = length($dir); @files = map(substr($_, $l+1), @files);

    my $dir;
    my @subdirs = $maindir;
    my(@files, $e);

    while (@subdirs) {
        $dir = shift @subdirs;

        # read all the entries for this directory
        opendir(DIR, $dir) || die "$0: error opening directory $dir: $!\n";
        my (@e) = ();
        while (defined($e = readdir(DIR))) {
            push(@e, $e) if ($e ne "." && $e ne "..");
        }
        closedir(DIR);
        # it only makes sense to sort within a directory, if at all
        #@e = sort @e;

        foreach $e (@e) {
            if (-d "$dir/$e") {  # directory
                push(@subdirs, "$dir/$e");
                push(@files, "$dir/$e");
            } elsif ((!$pattern) || $e =~ /$pattern/) {
                push(@files, "$dir/$e");
            }
        }
    }

    return @files;
}


