File Coverage

blib/lib/experimental.pm

Criterion	Covered	Total	%
statement	27	49	55.1
branch	9	32	28.1
condition	0	2	0.0
subroutine	7	9	77.7
pod			n/a
total	43	92	46.7

package experimental;
$experimental::VERSION = '0.030';
use strict;
use warnings;
use version ();

BEGIN { eval { require feature } };
use Carp qw/croak carp/;

my %warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offsets;
my %removed_warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::NoOp;
my %features = map { $_ => 1 } $] > 5.015006 ? keys %feature::feature : do {
	my @features;
	if ($] >= 5.010) {
		push @features, qw/switch say state/;
		push @features, 'unicode_strings' if $] > 5.011002;
	}
	@features;
};

my %min_version = (
	args_array_with_signatures => '5.20.0',
	array_base      => '5',
	autoderef       => '5.14.0',
	bitwise         => '5.22.0',
	builtin         => '5.35.7',
	const_attr      => '5.22.0',
	current_sub     => '5.16.0',
	declared_refs   => '5.26.0',
	defer           => '5.35.4',
	evalbytes       => '5.16.0',
	extra_paired_delims => '5.35.9',
	fc              => '5.16.0',
	for_list        => '5.35.5',
	isa             => '5.31.7',
	lexical_topic   => '5.10.0',
	lexical_subs    => '5.18.0',
	postderef       => '5.20.0',
	postderef_qq    => '5.20.0',
	refaliasing     => '5.22.0',
	regex_sets      => '5.18.0',
	say             => '5.10.0',
	smartmatch      => '5.10.0',
	signatures      => '5.20.0',
	state           => '5.10.0',
	switch          => '5.10.0',
	try             => '5.34.0',
	unicode_eval    => '5.16.0',
	unicode_strings => '5.12.0',
);
my %removed_in_version = (
	array_base      => '5.30.0',
	autoderef       => '5.24.0',
	lexical_topic   => '5.24.0',
);

$_ = version->new($_) for values %min_version;
$_ = version->new($_) for values %removed_in_version;

my %additional = (
	postderef     => ['postderef_qq'],
	switch        => ['smartmatch'],
	declared_refs => ['refaliasing'],
);

sub _enable {
	my $pragma = shift;
	if ($warnings{"experimental::$pragma"}) {
		warnings->unimport("experimental::$pragma");
		feature->import($pragma) if exists $features{$pragma};
		_enable(@{ $additional{$pragma} }) if $additional{$pragma};
	}
	elsif ($features{$pragma}) {
		feature->import($pragma);
		_enable(@{ $additional{$pragma} }) if $additional{$pragma};
	}
	elsif ($removed_warnings{"experimental::$pragma"}) {
		_enable(@{ $additional{$pragma} }) if $additional{$pragma};
	}
	elsif (not exists $min_version{$pragma}) {
		croak "Can't enable unknown feature $pragma";
	}
	elsif ($] < $min_version{$pragma}) {
		my $stable = $min_version{$pragma}->stringify;
		$stable =~ s/^ 5\. ([0-9]?[13579]) \. \d+ $/"5." . ($1 + 1) . ".0"/xe;
		croak "Need perl $stable or later for feature $pragma";
	}
	elsif ($] >= ($removed_in_version{$pragma} || 7)) {
		croak "Experimental feature $pragma has been removed from perl in version $removed_in_version{$pragma}";
	}
}

sub import {
	my ($self, @pragmas) = @_;

	for my $pragma (@pragmas) {
		_enable($pragma);
	}
	return;
}

sub _disable {
	my $pragma = shift;
	if ($warnings{"experimental::$pragma"}) {
		warnings->import("experimental::$pragma");
		feature->unimport($pragma) if exists $features{$pragma};
		_disable(@{ $additional{$pragma} }) if $additional{$pragma};
	}
	elsif ($features{$pragma}) {
		feature->unimport($pragma);
		_disable(@{ $additional{$pragma} }) if $additional{$pragma};
	}
	elsif (not exists $min_version{$pragma}) {
		carp "Can't disable unknown feature $pragma, ignoring";
	}
}

sub unimport {
	my ($self, @pragmas) = @_;

	for my $pragma (@pragmas) {
		_disable($pragma);
	}
	return;
}

1;

#ABSTRACT: Experimental features made easy

__END__