File Coverage

blib/lib/Modern/Perl/Prelude.pm

Criterion	Covered	Total	%
statement	92	92	100.0
branch	28	28	100.0
condition	6	6	100.0
subroutine	19	19	100.0
pod			n/a
total	145	145	100.0

package Modern::Perl::Prelude;

use v5.30;
use strict;
use warnings;

# ABSTRACT: Project prelude for modern Perl style on Perl 5.30+
our $VERSION = '0.008';

use Import::Into ();
use strict   ();
use warnings ();
use feature  ();
use utf8     ();
use true     ();

use Feature::Compat::Try ();
use builtin::compat      ();

my @FEATURES = qw(
    say
    state
    fc
);

my @BUILTINS = qw(
    blessed
    refaddr
    reftype
    trim
    ceil
    floor
    true
    false
    weaken
    unweaken
    is_weak
);

my %KNOWN_FLAG = map { $_ => 1 } qw(
    -utf8
    -class
    -defer
    -corinna
    -always_true
);

my %KNOWN_HASH_KEY = map { $_ => 1 } qw(
    utf8
    class
    defer
    corinna
    always_true
);

sub import {
    my ($class, @args) = @_;
    my $target = caller;
    my $config = _parse_args(@args);

    _validate_config($config);

    strict->import::into($target);
    warnings->import::into($target);

    feature->import::into($target, @FEATURES);

    Feature::Compat::Try->import::into($target);

    builtin::compat->import::into($target, @BUILTINS);

    utf8->import::into($target) if $config->{utf8};

    _set_always_true(1) if $config->{always_true};

    _import_optional_module($target, 'Feature::Compat::Class', $config->{class})
        if $config->{class};

    _import_optional_module($target, 'Feature::Compat::Defer', $config->{defer})
        if $config->{defer};

    _import_optional_module($target, 'Object::Pad', $config->{corinna})
        if $config->{corinna};

    return;
}

sub unimport {
    my ($class, @args) = @_;
    my $target = caller;
    my $config = _parse_args(@args);

    _validate_config($config);

    strict->unimport::out_of($target);
    warnings->unimport::out_of($target);

    feature->unimport::out_of($target, @FEATURES);
    utf8->unimport::out_of($target);

    _set_always_true(0) if $config->{always_true};

    return;
}

sub _parse_args {
    my (@args) = @_;

    return {} unless @args;

    if (@args == 1 && ref($args[0]) eq 'HASH') {
        return _parse_hash_args($args[0]);
    }

    return _parse_flag_args(@args);
}

sub _parse_flag_args {
    my (@args) = @_;
    my %config;

    for my $arg (@args) {
        die __PACKAGE__ . qq{: hash-style arguments must be passed as a single hash reference\n}
            if ref $arg;

        die __PACKAGE__ . qq{: unknown import option "$arg"\n}
            unless $KNOWN_FLAG{$arg};

        (my $key = $arg) =~ s/^-//;
        $config{$key} = 1;
    }

    return \%config;
}

sub _parse_hash_args {
    my ($raw) = @_;
    my %config = %{$raw};

    for my $key (keys %config) {
        die __PACKAGE__ . qq{: unknown import key "$key"\n}
            unless $KNOWN_HASH_KEY{$key};
    }

    return \%config;
}

sub _validate_config {
    my ($config) = @_;

    die __PACKAGE__ . qq{: options "-class" and "-corinna" are mutually exclusive\n}
        if $config->{class} && $config->{corinna};

    return;
}

sub _set_always_true {
    my ($enabled) = @_;

    if ($enabled) {
        true->import();
    }
    else {
        true->unimport();
    }

    return;
}

sub _import_optional_module {
    my ($target, $module, $opts) = @_;

    (my $file = "$module.pm") =~ s{::}{/}g;
    require $file;

    if (ref($opts) eq 'HASH') {
        $module->import::into($target, %{$opts});
    }
    else {
        $module->import::into($target);
    }

    return;
}

1;

__END__