File Coverage

blib/lib/exact.pm

Criterion	Covered	Total	%
statement	183	194	94.3
branch	50	74	67.5
condition	17	36	47.2
subroutine	35	37	94.5
pod	8	8	100.0
total	293	349	83.9

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 B::Deparse;
use Import::Into;
use Sub::Util 'set_subname';
use Syntax::Keyword::Defer;
use Syntax::Keyword::Try;

our $VERSION = '1.32'; # 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 nodefer 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 ) ),
        ( map { $_ => \&{$_} } qw( deat deattry ) ),
    ) 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
    );
    Try::Tiny->import::into($caller) if ( grep { $_ eq 'trytiny' } @functions );

    Syntax::Keyword::Defer->import_into($caller) if (
        $perl_version < 36 and
        not grep { $_ eq 'nodefer' } @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 ($e) {
            croak($e) unless ( index( $e, qq{Can't locate $pm in } ) == 0 );
            return 0;
        }

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

        my $is_exact_extension = 0;
        {
            no strict 'refs';
            $is_exact_extension = grep { index( $_, 'exact::' ) == 0 } $class, @{"${class}::ISA"};
        }
        $class->import( $params, $caller ) if ( $is_exact_extension and $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 : undef;
        ( 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 ( $child->isa($parent) );
    }
    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 ) = @_;

            if ( $original_import and ref $original_import eq 'CODE' ) {
                ( my $b_deparsed_sub = B::Deparse->new->coderef2text($original_import) ) =~ s/;//g;
                $original_import->(@_) if ($b_deparsed_sub);
            }

            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;
}

sub deat ($) {
    ( my $e = reverse $_[0] ) =~ s/^\s*\.\d+\s+enil\s+.*?\s+ta\s+//;
    return '' . reverse $e;
}

sub deattry (&) {
    try {
        return $_[0]->();
    }
    catch ($e) {
        die deat $e, "\n";
    }
}

1;

__END__