view release on metacpan or  search on metacpan

lib/App/ChangeShebang.pm  view on Meta::CPAN

package App::ChangeShebang v1.0.0;
use v5.24;
use warnings;
use experimental qw(lexical_subs signatures);

use ExtUtils::MakeMaker ();
use File::Basename ();
use File::Temp ();
use Getopt::Long ();
use Pod::Usage ();

our $TRIAL = 0;

sub new ($class) {
    bless {}, $class;
}

sub parse_options ($self, @argv) {
    my $parser = Getopt::Long::Parser->new(
        config => [qw(no_auto_abbrev no_ignore_case)],
    );
    $parser->getoptionsfromarray(
        \@argv,
        "version|v" => sub (@) { printf "%s %s\n", __PACKAGE__, __PACKAGE__->VERSION; exit },
        "quiet|q"   => \$self->{quiet},
        "force|f"   => \$self->{force},
        "help|h"    => sub (@) { Pod::Usage::pod2usage(0) },
    ) or Pod::Usage::pod2usage(1);

    my @file = @argv;
    if (!@file) {
        warn "Missing file arguments.\n";
        Pod::Usage::pod2usage(1);
    }
    $self->{file} = \@file;
    $self;
}

sub run ($self) {
    for my $file ($self->{file}->@*) {
        next unless -f $file && !-l $file;
        next unless $self->is_perl_shebang( $file );
        unless ($self->{force}) {
            my $anser = ExtUtils::MakeMaker::prompt( "change shebang line of $file? (y/N)", "N" );
            next if $anser !~ /^y(es)?$/i;
        }
        $self->change_shebang($file);
        warn "changed shebang line of $file\n" unless $self->{quiet};
    }
}

sub is_perl_shebang ($self, $file) {
    open my $fh, "<:raw", $file or die "open $file: $!\n";
    read $fh, my $first, 100 or die "read $file: $!\n";
    return $first =~ /^#!([^\n]*)perl/ ? 1 : 0;
}

my $remove = do {
    my $s = qr/[ \t]*/;
    my $w = qr/[^\n]*/;
    my $running_under_some_shell = qr/\n*
        $s eval $s ['"] exec $w \n
            $s if $s (?:0|\$running_under_some_shell) $w \n
    /xsm;
    my $shebang = qr/\n*
        \#! $w \n
    /xsm;
    qr/\A(?:$running_under_some_shell|$shebang)+/;
};

sub change_shebang ($self, $file) {
    my $content = do {
        open my $fh, "<:raw", $file or die "open $file: $!\n";
        local $/; <$fh>;
    };

    $content =~ s/$remove//;

    my $mode = (stat $file)[2];

    my ($tmp_fh, $tmp_name) = File::Temp::tempfile UNLINK => 0, DIR => File::Basename::dirname($file);
    chmod $mode, $tmp_name;
    print {$tmp_fh} <<'...';
#!/bin/sh
exec "$(dirname "$0")"/perl -x "$0" "$@"
#!perl
...
    print {$tmp_fh} $content;
    close $tmp_fh;
    rename $tmp_name, $file or die "rename $tmp_name, $file: $!\n";
}

1;
__END__

=encoding utf-8

=head1 NAME

App::ChangeShebang - change shebang lines for relocatable perl

=head1 SYNOPSIS

    > change-shebang /path/to/bin/script.pl