File Coverage

blib/lib/exact.pm

Criterion	Covered	Total	%
statement	164	173	94.8
branch	46	70	65.7
condition	10	27	37.0
subroutine	30	32	93.7
pod	6	6	100.0
total	256	308	83.1

package exact;
# ABSTRACT: Perl pseudo pragma to enable strict, warnings, features, mro, filehandle methods

use 5.014;
use strict;
use warnings;
use namespace::autoclean;
use Import::Into;
use Sub::Util 'set_subname';
use Syntax::Keyword::Try;

our $VERSION = '1.22'; # VERSION

use feature      ();
use utf8         ();
use mro          ();
use Carp         qw( croak carp confess cluck );
use IO::File     ();
use IO::Handle   ();
use Try::Tiny    ();
use PerlX::Maybe ();

my ($perl_version) = $^V =~ /^v5\.(\d+)/;

my $features_available = ( %feature::feature_bundle and $feature::feature_bundle{all} )
    ? $feature::feature_bundle{all}
    : [ qw( say state switch unicode_strings ) ];

my $functions_available = [ qw(
    nostrict nowarnings
    nofeatures nobundle noskipexperimentalwarnings
    noutf8 noc3 nocarp notry trytiny nomaybe noautoclean
) ];

my $functions_deprecated = ['noexperiments'];

my ( $no_parent, $late_parent );

sub import {
    my ( $self, $caller ) = ( shift, caller() );

    my ( @features, @nofeatures, @functions, @bundles, @classes );
    for (@_) {
        ( my $opt = $_ ) =~ s/^\-//;

        if ( $opt eq 'class' ) {
            push( @classes, $opt );
        }
        elsif ( $opt eq 'cor' ) {
            push( @features, 'class' );
        }
        elsif ( $opt eq 'nocor' ) {
            push( @nofeatures, 'class' );
        }
        elsif ( grep { $_ eq $opt } @$features_available ) {
            push( @features, $opt );
        }
        elsif ( my ($nofeature) = grep { 'no' . $_ eq $opt } @$features_available ) {
            push( @nofeatures, $nofeature );
        }
        elsif ( grep { $_ eq $opt } @$functions_available, @$functions_deprecated ) {
            push( @functions, $opt ) if ( grep { $_ eq $opt } @$functions_available );
        }
        elsif ( $opt =~ /^:?v?5?\.?(\d+)/ and $1 >= 10 ) {
            push( @bundles, $1 );
        }
        else {
            push( @classes, $opt ) if ( $opt !~ /^no[a-z]{2}/ );
        }
    }

    strict  ->import unless ( grep { $_ eq 'nostrict'   } @functions );
    warnings->import unless ( grep { $_ eq 'nowarnings' } @functions );

    if (@bundles) {
        feature->import( ':5.' . $_ ) for (@bundles);
    }
    elsif (
        not grep { $_ eq 'nofeatures' } @functions and
        not grep { $_ eq 'nobundle'   } @functions
    ) {
        feature->import( $perl_version >= 16 ? ':all' : ':5.' . $perl_version );
    }
    feature->import($_)   for (@features);
    feature->unimport($_) for (@nofeatures);

    unless ( grep { $_ eq 'noutf8' } @functions ) {
        utf8->import;
        binmode( $_, ':utf8' ) for ( *STDIN, *STDERR, *STDOUT );
        'open'->import::into( $caller, ':std', ':utf8' );
    }

    mro::set_mro( $caller, 'c3' ) unless ( grep { $_ eq 'noc3' } @functions );

    monkey_patch( $self, $caller, ( map { $_ => \&{ 'Carp::' . $_ } } qw( croak carp confess cluck ) ) )
        unless ( grep { $_ eq 'nocarp' } @functions );

    feature->unimport('try') if (
        grep { $_ eq 'try' } @$features_available and
        (
            grep { $_ eq 'notry'   } @functions or
            grep { $_ eq 'trytiny' } @functions
        )
    );
    Syntax::Keyword::Try->import_into($caller) if (
        $perl_version < 36 and
        not grep { $_ eq 'notry'   } @functions and
        not grep { $_ eq 'trytiny' } @functions
    );
    eval qq{
        package $caller {
            use Try::Tiny;
        };
    } if ( grep { $_ eq 'trytiny' } @functions );

    monkey_patch( $self, $caller, ( map { $_ => \&{ 'PerlX::Maybe::' . $_ } } qw(
        maybe provided provided_deref provided_deref_with_maybe
    ) ) ) unless ( grep { $_ eq 'nomaybe' } @functions );

    my @late_parents = ();
    my $use          = sub {
        my ( $class, $pm, $caller, $params ) = @_;

        my $failed_require;
        try {
            require "$pm" unless ( do {
                no strict 'refs';
                no warnings 'once';
                ${"${caller}::INC"}{$pm};
            } );
        }
        catch {
            croak($@) unless ( index( $@, q{Can't locate } ) == 0 );
            return 0;
        }

        ( $no_parent, $late_parent ) = ( undef, undef );

        "$class"->import( $caller, @$params ) if ( "$class"->can('import') );

        if ($late_parent) {
            push( @late_parents, [ $class, $caller ] );
        }
        elsif ( not $no_parent and index( $class, 'exact::' ) != 0 ) {
            $self->add_isa( $class, $caller );
        }

        return 1;
    };
    for my $class (@classes) {
        my $params = ( $class =~ s/\(([^\)]+)\)// ) ? [$1] : [];
        ( my $pm = $class ) =~ s{::|'}{/}g;
        $pm .= '.pm';

        $use->(
            'exact::' . $class,
            'exact/' . $pm,
            $caller,
            $params,
        ) or $use->(
            $class,
            $pm,
            $caller,
            $params,
        ) or croak(
            "Can't locate exact/$pm or $pm in \@INC " .
            "(you may need to install the exact::$class or $class module)" .
            '(@INC contains: ' . join( ' ', @INC ) . ')'
        );
    }
    $self->add_isa(@$_) for @late_parents;

    warnings->unimport('experimental')
        unless ( $perl_version < 18 or grep { $_ eq 'noskipexperimentalwarnings' } @functions );

    namespace::autoclean->import( -cleanee => $caller ) unless ( grep { $_ eq 'noautoclean' } @functions );
}

sub monkey_patch {
    my ( $self, $class, %patch ) = @_;
    {
        no strict 'refs';
        no warnings 'redefine';
        *{"${class}::$_"} = set_subname( "${class}::$_", $patch{$_} ) for ( keys %patch );
    }
    return;
}

sub add_isa {
    my ( $self, $parent, $child ) = @_;
    {
        no strict 'refs';
        push( @{"${child}::ISA"}, $parent ) unless ( grep { $_ eq $parent } @{"${child}::ISA"} );
    }
    return;
}

sub no_parent {
    $no_parent = 1;
    return;
}

sub late_parent {
    $late_parent = 1;
    return;
}

sub _patch_import {
    my ( $type, $self, @names ) = @_;

    my $target          = ( caller(1) )[0];
    my $original_import = $target->can('import');

    my %groups;
    if ( $type eq 'provide' ) {
        %groups = map { %$_ } grep { ref $_ eq 'HASH' } @names;
        @names = grep { not ref $_ } @names;
    }

    monkey_patch(
        $self,
        $target,
        import => sub {
            my ( $package, @exports ) = @_;

            $original_import->(@_) if ($original_import);

            if ( $type eq 'force' ) {
                @exports = @names;
            }
            elsif ( $type eq 'provide' ) {
                @exports = grep { defined } map {
                    my $name = $_;

                    ( grep { $name eq $_ } @names ) ? $name                   :
                    ( exists $groups{$name}       ) ? ( @{ $groups{$name} } ) : undef;
                } @exports;
            }

            monkey_patch(
                $package,
                ( caller(0) )[0],
                map { $_ => \&{ $package . '::' . $_ } } @exports
            );

            return;
        },
    );
}

sub export {
    _patch_import( 'force', @_ );
    return;
}

sub exportable {
    _patch_import( 'provide', @_ );
    return;
}

1;

__END__