File Coverage

blib/lib/experimentals.pm

Criterion	Covered	Total	%
statement	24	33	72.7
branch	4	10	40.0
condition	1	3	33.3
subroutine	7	8	87.5
pod			n/a
total	36	54	66.6

package experimentals;
our $VERSION = '0.020';

use 5.010;
use strict;
use warnings;
use feature      ();

# Module enables/disables these features...
my %FEATURES
    = map { $_ => 1 } ( $] >  5.015006 ? keys %feature::feature
                      : $] >= 5.011002 ? qw< say state switch unicode_strings  >
                      : $] >= 5.010000 ? qw< say state switch                  >
                      :                  qw<                                   >
                      );

# Module disables these warnings...
my %WARNINGS = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offsets;

# In -report mode, the code is not run...
my $DO_NOT_RUN;
{
    no warnings 'void';
    INIT { exit if $DO_NOT_RUN; }
}

# Grab and reformat experimental warnings (when assigned to $SIG{__WARN__})...
sub _report_experimentals {
    my $warning = "@_";

    # Reformat any experimental warning (ignoring anything else)...
    if ($warning =~ m{\A(.*) is experimental\b(?:.*) at (.* line \d+)}) {
        printf {*STDERR} "%s:\t%s\n", $2, ucfirst $1;
    }
}

# Handle 'use experimentals'...
sub import {
    # Handle deprecation of smartmatching in Perl 5.38..5.40
    warnings->unimport('deprecated::smartmatch')
        if $] >= 5.038 && $] < 5.042;

    # Always enable all available features...
    feature->import(keys %FEATURES);

    # Turn on utf8 if the feature requires it...
    if ($FEATURES{ extra_paired_delimiters }) {
        require utf8;
        utf8->import();
    }

    # Are we reporting???
    my $reporting = grep { defined $_ && lc($_) eq '-report' } @_;

    # If not reporting, disable all warnings about experimental features...
    if (!$reporting) {
        warnings->unimport(keys %WARNINGS);
    }

    # Otherwise, set up a filter to grab and reformat experimental warnings...
    else {
        # Enable the warnings we're going to grab...
        warnings->import(keys %WARNINGS);

        # Install the code to grab them...
        $SIG{__WARN__} = \&_report_experimentals;

        # Prevent actual code execution...
        $DO_NOT_RUN = 1;
    }
}

# Handle 'no experimentals'...
sub unimport {
    # Enable features that don't have experimental warnings...
    feature->import(grep { !$WARNINGS{"experimental::$_"} } keys %FEATURES);

    # Enable experimental warnings...
    warnings->import(keys %WARNINGS);
}

1; # Magic true value required at end of module

__END__