File Coverage

blib/lib/App/ChangeShebang.pm

Criterion	Covered	Total	%
statement	56	64	87.5
branch	13	24	54.1
condition	1	3	33.3
subroutine	12	15	80.0
pod	0	6	0.0
total	82	112	73.2

package App::ChangeShebang 0.10;
use v5.16;
use warnings;

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

sub prompt { ExtUtils::MakeMaker::prompt(@_) }

sub new {
    my $class = shift;
    bless {@_}, $class;
}

sub parse_options {
    my ($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 {
    my $self = shift;
    for my $file (@{ $self->{file} }) {
        next unless -f $file && !-l $file;
        next unless $self->is_perl_shebang( $file );
        unless ($self->{force}) {
            my $anser = 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 {
    my ($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 {
    my ($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__