polyperl

#! /usr/bin/env perl
use strict;
use warnings;
no if $] >= 5.018, warnings => 'experimental::smartmatch';
use 5.010;

### This program selects the best available perl (or other utility)
### based on the contents of the script it is passed.
### It acts like regular perl eventually will: selecting the best
### perl semantics according to a Perl program's "use VERSION" declaration

my $DEFAULT_PERL    = 'perl';
my $DEFAULT_VERSION = '5.016';
my $DEFAULT_APP     = $DEFAULT_PERL;
my $PERL6           = 'perl6';

# Locate perlbrew available versions...
my @raw_versions = `perlbrew list`;
my @perlbrew_versions = sort { normalize($a) <=> normalize($b) }
                             map { m{ perl-blead\s*\((\S+)\) | perl-(\S+) }xms ? $+ : () }
                                 @raw_versions;
my $BLEAD_VERSION = (map { m{ perl-blead\s*\((\S+)\) }xms ? $+ : () } @raw_versions )[0];

chomp @perlbrew_versions;

# Separate the filename and other args...
my $source_file;
my %config;
ARG:
while (my $arg = shift @ARGV) {
    if ($arg eq '-d' )  { $config{debug} = 1;             next ARG; }
    if ($arg eq '-m' )  { $config{pager} = 1;             next ARG; }
    if ($arg eq '-c')   { $config{vim_compile} = 1;       next ARG; }
    if ($arg eq '-p' )  { $config{pause_after} = 1;       next ARG; }
    if ($arg eq '-s' )  { $config{getopt} = 1;            next ARG; }
    if ($arg =~ /^-/ )  { $config{extraargs} .= " $arg "; next ARG; }

    $source_file = $arg;
    last ARG;
}
$config{extraargs} //= '';

# Grab the source...
my $source_code = slurp($source_file) // exit;

# Set up pager, if requested...
if ($config{pause_after}) {
    $config{pager} = 1;
    $ENV{PAGER} = "$ENV{HOME}/bin/lessen";
    *STDOUT->autoflush;
}
if ($config{pager}) {
    require IO::Page;
}

# Is there to be regex debugging...
my $rxrx = $source_code =~ /^\s*use\s*Regexp::Debugger/m;

# Is there a shebang line???
my $shebang = $source_code =~ m{ \A \s* [#]! \s* ([^\n]+) }xms ? $1 : q{};

# Is there a Perl 6 version number???
if ($source_code =~ m{ ^ \s* use \s+ v6 (?: \. \w+ )? \s* ; }xms) {
    exec "$PERL6 $source_file @ARGV";
}

# Is there a chronoperl version number???
if ($source_code =~ m{ ^ \s* use \s+ v (?: [7-9] | \d{2,}) (?: \. \w+ )? \s* ; }xms) {
    exec "chronoperl $source_file @ARGV";
}


# Is it a Perl 5 program???
my $is_perl5 = $config{vim_compile}
            || $shebang =~ m{ perl (?!6) }xms
            || $shebang !~ m{ rakudo | perl6 }xms
            && $source_file =~ m{ [.] (?: p[ml] | [.] t ) (?: .vp[de] )? \Z }xms;

# If it's a Perl file work out the best version of perl to execute it with...
if ($is_perl5) {
    call_with_best_perl($source_code);
}

# Otherwise, if there's a shebang line, use the program specified by that...
elsif (length $shebang && !$config{debug}) {
    exec "$shebang $source_file @ARGV";
}

# Otherwise, assume it's the default app...
else {
    call_with_best_perl($source_code);
}


# Version number comparison function...
sub candidate_satisfies {
    my ($candidate_version_ref, $version_ref) = @_;
    for my $index (0..$#{$version_ref}) {
        no warnings 'uninitialized';
        return 0 if $candidate_version_ref->[$index] < $version_ref->[$index];
    }
    return 1;
}

# Parse out the 'use VERSION' line, if any...
sub get_version {
    my ($string, $prefix) = @_;

    given ($string) {
        when (m{ $prefix v?(?<!\d)6 }xms) {
           return 6, 0;
        }
        when (m{ $prefix  v? (\d++) [.] (\d++) [.] (\d++) }xms) {
            return $1+0, $2+0, $3+0;
        }
        when (m{ $prefix  v (\d++) [.] (\d++) }xms) {
           return $1+0, $2+0;
        }
        when (m{ $prefix  (\d++) [.] (\d{1,3}+) (\d{1,3}+) }xms) {
            return $1+0, $2+0, $3+0;
        }
        when (m{ $prefix  (\d++) [.] (\d{1,3}+) }xms) {
            return $1+0, $2+0;
        }
    }

    return;
}

# Read in the contents of a file...
sub slurp {
    local (@ARGV,$/) = shift;
    return scalar readline;
}

# Execute a command under the specified version of Perl...
sub call_via_perlbrew {
    my ($version, $config_ref, $command) = @_;

    if (defined $BLEAD_VERSION && $version eq $BLEAD_VERSION) {
        $version = 'perl-blead';
    }

    # Which form of Perl???
    my $perl = 'perl' . $config_ref->{extraargs};
    if ($config_ref->{debug}) {
        $perl .= ' -d';
    }
    if ($config_ref->{getopt}) {
        $perl .= ' -s';
    }

    # This will be a sub-shell usage of perlbrew...
    $ENV{PERLBREW_SKIP_INIT} = 1;

    # Which shell are we using???
    my $env_extractor_pat
        = $ENV{SHELL} =~ m{csh \Z}xms  ?  qr{\A \s* setenv \s+ (\S+) \s+ (.*)}xms
        :                                 qr{\A \s* export \s+ (\S+?) =  (.*)}xms
        ;

    # Ask perlbrew for the necessary environment for the given version...
    for my $env (`perlbrew env $version`) {
        # Extract the data and update the current environment...
        chomp $env;
        $env =~ $env_extractor_pat  or next;
        $ENV{$1} = eval $2;
    }
    $ENV{PATH} = '.' . $ENV{PERLBREW_PATH} . ':' . $ENV{PATH};

    # Execute it...
    if ($config_ref->{vim_compile}) {
        my @errors   = `$ENV{SHELL} -c '$perl -cw $command' >& /dev/stdout`;
        if (@errors) {
            print @errors;
        }
        else {
            say q{No errors};
        }
    }
    elsif (!$rxrx && $version =~ /^5\.\d\d/ && $shebang !~ /^\s*$|polyperl/ && $0 =~ m{\b motleyperl \Z}xms) {
        system qq{$ENV{SHELL} -c '$perl $config_ref->{extraargs} -MTerm::Tint $command'};
    }
    else {
        system qq{$ENV{SHELL} -c '$perl $config_ref->{extraargs} $command'};
    }
}

# Support :make error format in vim...
sub _convert_to_vim_errors {
    my $warning = shift;
    my $errors = 0;
    my $messages;
    for my $line (@_) {
        chomp $line;
        next if $line !~ m{\A (.*) \s at \s (.*) \s line \s (\d+) (.*) \Z}xms;
        my ($message, $file, $lineno, $rest) = ($1, $2, $3, $4);
        $message .= $rest if $rest =~ s/^,//;
        $messages .= "$file:$lineno$warning:$message\n";
        $errors++;
    }
    if (!$errors) {
        return "";
    }
    else {
        return $messages;
    }
}

# Use most appropriate perlbrew'd perl...
sub call_with_best_perl {
    my ($source_code) = @_;

    # Is there a specific Perl version specified???
    my @version = get_version($source_code, qr{^ \s* use \s+}xms);
    @version = get_version($DEFAULT_VERSION, q{}) if ! @version;

    if ($version[0] == 6) {
        if ($config{debug}) {
            my $old_profile = quotemeta `terminal_profile grey report`;
            system qq{$ENV{SHELL} -c '$PERL6-debug-m $source_file @ARGV'};
            system qq{terminal_profile $old_profile};
        }
        else {
            system qq{$ENV{SHELL} -c '$PERL6 $source_file @ARGV'};
        }
    }

    # Otherwise, find perlbrew version that best satisfies the requirement...
    my @candidates;
    for my $candidate_perl (@perlbrew_versions) {
        my @candidate_version = get_version($candidate_perl, q{^});
        if (candidate_satisfies(\@candidate_version, \@version)) {
            if (@candidates && $candidates[-1] =~ /^$candidate_version[0]\.$candidate_version[1]\./) {
                $candidates[-1] = $candidate_perl;
            }
            else {
                push @candidates, $candidate_perl;
            }
        }
    }

    # Call the right (minimal) version via perlbrew, if there is a right version...
    if (@candidates) {
        call_via_perlbrew($candidates[0], \%config, "$source_file @ARGV");
    }
    # Otherwise, follow the shebang line...
    elsif (length $shebang) {
        if ($config{vim_compile}) {
            _convert_to_vim_errors(`$shebang -c $source_file >& /dev/stdout `);
        }
        else {
            exec "$shebang $source_file @ARGV";
        }
    }
    # Otherwise, use the default...
    else {
        if ($config{vim_compile}) {
            _convert_to_vim_errors(`$DEFAULT_PERL -c $source_file >& /dev/stdout`);
        }
        else {
            exec "$DEFAULT_PERL $source_file @ARGV";
        }
    }

}

# Normalize a X.Y.Z version number to XXXYYYZZZ...
sub normalize { @_ ? sprintf("%03d%03d%03d", split /[.]/, shift) : undef }

# Strip duplicates
sub unique { my %seen; grep {!$seen{$_}} @_ }