File Coverage

blib/lib/Devel/Main.pm

Criterion	Covered	Total	%
statement	38	40	95.0
branch	7	12	58.3
condition	5	12	41.6
subroutine	8	8	100.0
pod	0	1	0.0
total	58	73	79.4

# ABSTRACT: Syntactic sugar for a script's main routine
use strict;
use warnings;

package Devel::Main;

our $VERSION = 0.005;

sub import {
    my $class  = shift;
    @_ = 'main' unless @_;

    my $opts   = ref($_[0]) ? shift : {};
    my $caller = $opts->{into} // scalar(caller($opts->{into_level} // 0));

    while (@_) {
        my $name = shift;
        my $args = ref($_[0]) ? shift : {};
        my $gen  = $class->can("$name\_generator")
            or do { require Carp; Carp::croak("$class does not export sub '$name'") };
        my $code = $gen->( $class, $name, $args );

        my $as = join '', grep defined, (
            $args->{ -prefix },
            ($args->{ -as } // $name),
            $args->{ -suffix },
        );

        no strict 'refs';
        *{"$caller\::$as"} = $code;
    }
}

sub main_generator {
    my ( $class, $name, $args ) = @_;

    my $run_sub_name = $args->{'run_sub_name'} // "run_$name";
    my $exit         = $args->{'exit'}         // 1;

    return sub (&) {
        my ($main_sub) = @_;

        # If we're called from a script, run main and exit
        if ( !defined caller(1) ) {
            $main_sub->();
            exit(0) if $exit;
        }

        # Otherwise, create a sub that turns its arguments into @ARGV
        else {
            no strict 'refs';
            my $package = caller;
            *{"${package}::$run_sub_name"} = sub {
                local @ARGV = @_;
                return $main_sub->();
            };

            # Return 1 to make the script pass 'require'
            return 1;
        }
    };
}

1;

__END__