#!/usr/bin/env perl
use strict;
use warnings FATAL => 'all';
use utf8;
use Getopt::Long qw(:config no_auto_abbrev no_ignore_case bundling);
use 5.10.1;
use Config;
use Cwd 'getcwd';
use File::Spec;
use File::Temp qw(tempfile tempdir);
use File::Path 'rmtree';
use File::Basename 'dirname';
use Pod::Usage 'pod2usage';
use Devel::PatchPerl;
use CPAN::Perl::Releases::MetaCPAN 'perl_tarballs';
use HTTP::Tinyish;
use IPC::Run3 'run3';
use version;
use POSIX 'uname';

sub run {
    my ($cmd, $log) = @_;
    warn "---> @$cmd\n";
    run3 $cmd, undef, $log, $log, { append_stdout => 1 };
    if ($? != 0) {
        open my $fh, "<", $log or die;
        while (<$fh>) {
            print;
        }
        die;
    }
    return 1;
}

=head1 NAME

relocatable-perl-build - building perl with relocatable settings

=head1 SYNOPSIS

    > relocatable-perl-build OPTIONS

    Options:
    --prefix         install prefix, this is just for installation.
                     After installation, you can move perl wherever you want!
    --perl_version   install perl version
    --tarball        use local tar.gz
    --extra_option   an extra option to pass on to ./Configure (can be specified multiple times)
    --jobs           parallel build, default: 1
    --help, -h       show this help message

    Examples:
    > relocatable-perl-build --prefix /usr/local --perl_version 5.20.0
    > relocatable-perl-build --prefix ~/perl --tarball /tmp/perl-5.18.2.tar.gz

=head1 AUTHOR

Shoichi Kaji

=cut


GetOptions
    "prefix=s"       => \(my $prefix),
    "perl_version=s" => \(my $perl_version),
    "tarball=s"      => \(my $tarball),
    "extra_option=s@" => \(my $extra_options),
    "jobs=i"         => \(my $jobs),
    "help|h"         => sub { pod2usage(0) },
or pod2usage(1);


$prefix or do { warn "prefix option is required.\n"; pod2usage(1) };
if ($tarball && $tarball =~ /5\.(\d+)\.(\d+)/) {
    $perl_version = "5.$1.$2";
}
$perl_version or do { warn "perl_verion option is required.\n"; pod2usage(1) };

if (!-d $prefix) {
    mkdir $prefix or die "mkdir $prefix: $!\n";
} elsif (!-w $prefix) {
    die "don't have write permission to $prefix\n";
}

perl_build($prefix, $perl_version, $tarball, $extra_options);
force_symlink($prefix, $perl_version);

my $config_heavy = `$prefix/bin/perldoc -lm Config_heavy.pl`;
die "failed to exec $prefix/bin/perldoc -lm Config_heavy.pl\n" if $? != 0;
chomp $config_heavy;
patch_config_heavy($config_heavy);

my $config_pm = `$prefix/bin/perldoc -lm Config`;
die "failed to exec $prefix/bin/perldoc -lm Config\n" if $? != 0;
chomp $config_pm;
patch_config_pm($config_pm);

say "---> successfully build perl $perl_version to $prefix";
system "$prefix/bin/perl -V";

exit;

sub perl_build {
    my ($prefix, $perl_version, $tarball, $extra_options) = @_;

    my $current_dir = getcwd;

    my $now = time;
    my $tempdir = "/tmp/perl-build-$now.$$";
    my $log     = "/tmp/perl-build-$now.$$.log";
    mkdir $tempdir or die "mkdir $tempdir: $!\n";

    my %tar_option = ("tar.gz" => "xzf", "tar.bz2" => "xjf", "tar.xz" => "xJf");
    if ($tarball) {
        say "---> use $tarball";
        my ($suffix) = $tarball =~ /\.(tar\.(?:gz|bz2|xz))$/;
        run ["tar", $tar_option{$suffix}, $tarball, "-C", $tempdir], $log;
    } else {
        say "---> downloding perl-$perl_version";
        chdir $tempdir;
        my $found = perl_tarballs $perl_version;
        die "Couldn't find $perl_version\n" if !$found || !keys %$found;
        my ($suffix) = keys %$found;
        my $url = "https://cpan.metacpan.org/authors/id/" . $found->{$suffix};
        my $res = HTTP::Tinyish->new->mirror($url => "perl-$perl_version.$suffix");
        die "$url, $res->{status} $res->{reason}\n" unless $res->{success};
        run ["tar", $tar_option{$suffix}, "perl-$perl_version.$suffix"], $log;
    }

    my @Configure = (
        "./Configure",
        "-Dprefix=$prefix",
        "-Duserelocatableinc",
        "-Dman1dir=none",
        "-Dman3dir=none",
        "-DDEBUGGING=-g",
        "-des",
    );

    if ($extra_options) {
	push @Configure, @$extra_options;
    }

    if ($^O eq "linux") {
        # ubuntu 18.04 does not have xlocale.h
        # we can safely remove xlocale.h because locale.h reads it
        # see https://github.com/agracio/electron-edge-js/issues/16
        push @Configure, "-Ui_xlocale";

        # RHEL8, Fedora28, CentOS8 does not have libnsl.so.1 by default; remove -lnsl
        push @Configure, "-Dlibs=-lpthread -ldl -lm -lcrypt -lutil -lc";

        # RHEL9 removes libcrypt.so.1 by default; so we will link libcrypt.a statically
        # manually define d_crypt here
        push @Configure, "-Dd_crypt";

        # math.h in debian does not define _LIB_VERSION
        push @Configure, "-Ud_libm_lib_version";

        my $arch = (uname)[4];
        my @libpth = (
            "/lib",
            "/lib/$arch-linux-gnu",
            "/lib64",
            "/usr/lib",
            "/usr/lib/$arch-linux-gnu",
            "/usr/lib64",
            "/usr/local/lib",
            "/usr/local/lib64",
        );
        push @Configure, "-Dlibpth=@libpth";
    }

    chdir "$tempdir/perl-$perl_version" or die;
    my $devel = "Devel::PatchPerl";
    say "---> patching by $devel " . $devel->VERSION;
    $devel->patch_source($perl_version, ".");
    if ($^O eq "darwin") {
        {
            say "---> patching, do not add macosx_version_min";
            my $file = "hints/darwin.sh";
            open my $in, "<", $file or die;
            open my $out, ">", "$file.tmp" or die;
            while (my $line = <$in>) {
                print {$out} $line;
                if ($line =~ m{^ \s* add_macosx_version_min \s* \( }x) {
                    print {$out} "  return\n";
                }
            }
            close $in;
            close $out;
            rename "$file.tmp", $file or die;
        }
    }
    say "---> building perl $perl_version, see $log for progress";
    run \@Configure, $log;
    my @option = $jobs ? ("--jobs=$jobs") : ();
    run ["make", @option, "install"], $log;
    chdir $current_dir;
    rmtree $tempdir;
}

sub patch_config_heavy {
    my $config_heavy = shift;
    my @relocatable = do {
        open my $fh, "<", $config_heavy or die "open $config_heavy: $!\n";
        my @relocatable;
        while (<$fh>) {
            if (/^([^=]+)=['"].*\.\.\./) {
                push @relocatable, $1;
            }
        }
        @relocatable;
    };

    open my $in, "<", $config_heavy or die "open $config_heavy: $!\n";
    my ($out, $tmpname) = tempfile UNLINK => 0, DIR => dirname($config_heavy);
    my $mode = (stat $config_heavy)[2];
    chmod $mode, $tmpname;

    my %fix = (
        # XXX initialinstalllocation
        installbin    => '.../../bin',
        installprefix => '.../..',
        perlpath      => '.../perl',
        startperl   => '#!.../perl',
    );
    push @relocatable, sort keys %fix;
    @relocatable = uniq(@relocatable);

    my $fix_line1 = 'foreach my $what';
    my $fix_line2 = 's/^($what=)';

    while (<$in>) {
        if (/^([a-zA-Z0-9_]+)=/ && $fix{$1}) {
            say {$out} "$1='$fix{$1}'";
        } elsif (/^\Q$fix_line1\E/) {
            say {$out} 'foreach my $what (qw(' . "@relocatable" . ')) {';
        } elsif (/^(\s+)\Q$fix_line2\E/) {
            say {$out} $1, q{s/^($what=)(['"])(#!)?(.*?)\2/$1 . $2 . ($3 || "") . relocate_inc($4) . $2/me;};
        } else {
            print {$out} $_;
        }
    }
    close $_ for $in, $out;
    rename $tmpname, $config_heavy or die "rename $tmpname $config_heavy: $!\n";
}

sub patch_config_pm {
    my $config_pm = shift;
    open my $in, "<", $config_pm or die "open $config_pm: $!\n";
    my ($out, $tmpname) = tempfile UNLINK => 0, DIR => dirname($config_pm);
    my $mode = (stat $config_pm)[2];
    chmod $mode, $tmpname;

    my %fix = (
           'while ($libdir =~ m!^\.\./!) {',
        => 'while ($libdir =~ m!^\.\.(?:/|$)!) {',
           '$libdir = "$prefix/$libdir";',
        => '$libdir = $prefix . (length $libdir ? "/$libdir" : "");',
    );
    my $fix = join "|", map { quotemeta $_ } sort keys %fix;
    while (<$in>) {
        if (/^(\s*)($fix)$/) {
            say {$out} "$1$fix{$2}";
        } elsif (/^(\s+)scriptdir\s*=>/) {
            say {$out} "$1scriptdir => relocate_inc('.../'),";
        } else {
            print {$out} $_;
        }
    }
    close $_ for $in, $out;
    rename $tmpname, $config_pm or die "rename $tmpname $config_pm: $!\n";
}

sub uniq {
    my @item = @_;
    my %seen;
    grep { !$seen{$_}++ } @item;
}

sub force_symlink {
    my ($prefix, $perl_version) = @_;
    # See utils.lst and installperl
    my %map = (
        perl    => "perl$perl_version",
        c2ph    => "pstruct",
        perlbug => "perlthanks",
    );
    my $cwd = getcwd;
    chdir "$prefix/bin" or die "Failed to chdir $prefix/bin: $!";
    for my $file (grep -f, values %map) {
        unlink $file or die "Failed to unlink $file: $!";
    }
    for my $from (sort grep -f, keys %map) {
        my $target = $map{$from};
        symlink $from => $target or die "Failed to symlink $from => $target: $!";
    }
    chdir $cwd;
}
