File Coverage

blib/lib/Module/Pragma.pm

Criterion	Covered	Total	%
statement	97	97	100.0
branch	36	36	100.0
condition	13	13	100.0
subroutine	19	19	100.0
pod	13	13	100.0
total	178	178	100.0

package Module::Pragma;

use 5.010_000;

use strict;
use warnings;

#use Smart::Comments; # for debugging

our $VERSION = '0.02';

my %register  = ();

sub import
{
	my $class = shift @_;

	return if $class eq __PACKAGE__;

	@_ = $class->default_import() unless @_;

	### import: \@_, join ' ', caller

	$class->check_exclusive(@_);

	$^H{$class}  |=  $class->pack_tags(@_);
	$^H{$class}  &= ~$class->pack_tags( $class->exclusive_tags(@_) );
}

sub unimport
{
	my $class = shift @_;

	return if $class eq __PACKAGE__;

	### unimport: \@_, join ' ', caller

	if(@_){
		$class->check_exclusive(@_);

		$^H{$class}  |=  $class->pack_tags( $class->exclusive_tags(@_) );
		$^H{$class}  &= ~$class->pack_tags(@_);
	}
	else{
		delete $^H{$class};
	}
}

sub enabled
{
	my $class = shift @_;

	my $bits = $class->hint(1);

	$bits &= $class->pack_tags(@_) if @_;

	return wantarray ? $class->unpack_tags($bits) : $bits;
}

sub hint
{
	my($class, $level) = @_;

	my $hint_hash;
	my $bits;
	do {
		my $pkg;
		($pkg, $hint_hash) = ( caller ++$level )[0, 10];

		return undef unless defined $pkg;

	} until defined( $bits =  $hint_hash->{$class} );

	return $bits;
}

sub unknown_tag
{
	my($class, $tag) = @_;

	$class->_die("unknown subpragma '$tag'");
}


sub default_import
{
	my($class) = @_;

	$class->_die('requires explicit arguments');
}

sub _die
{
	my $class = shift @_;

	require Carp;
	Carp::croak("$class: ", @_);
}


sub register_tags
{
	my($class, @tags) = @_;

	my $map = $register{$class} //= {};

	my $bit_ref = \($map->{___bit___});


	while(defined(my $tag = shift @tags)){

		unless($$bit_ref){
			$$bit_ref = 1;
		}
		else{
			my $old = $$bit_ref;
			$$bit_ref <<= 1;

			#bitmask test
			if($$bit_ref == 0){
				__PACKAGE__->_die("$tag=($old << 1) is not a valid bitmask (integer overflowed?)");
			}
		}

		if($tag =~ /^___/){
			__PACKAGE__->_die("'$tag' is not a valid tag name");
		}

		if(@tags && $tags[0] =~ /^\d+$/){
			$$bit_ref = int shift @tags;
		}

		$map->{$tag} = $$bit_ref;

	}

	return $$bit_ref;
}

sub register_bundle
{
	my($class, $bundle, @tags) = @_;

	$register{$class}{':' . $bundle} = $class->pack_tags(@tags);
}

sub register_exclusive
{
	my $class = shift @_;

	my $ex = $register{$class}{___ex___} //= {};

	foreach my $x(@_){
		foreach my $y(@_){
			unless($x eq $y){
				push @ {$ex->{$x} }, $y;
				$ex->{$x, $y} = 1;
			}
		}
	}
}

sub exclusive_tags
{
	my $class = shift @_;

	my $ex = $register{$class}{___ex___} or return;

	my @ex_tags;
	my %seen;

	# expansion and regulation
	foreach my $tag(grep{ $ex->{$_} } map{ $class->unpack_tags( $class->tag($_) ) } @_)
	{
		push @ex_tags,
			grep{ !$seen{$_}++ } # uniq
			map { $class->unpack_tags( $class->tag($_) ) }
			@{ $ex->{$tag} };

	}
	return @ex_tags;
}
sub check_exclusive
{
	my $class = shift @_;

	my $ex = $register{$class}{___ex___} or return;

	# check whether these are exclusive
	foreach my $x(@_){
		foreach my $y(@_){
			$class->_die("'$x' and '$y' are exclusive mutually") if $ex->{$x, $y};
		}
	}
}

sub tag
{
	my($class, $tag) = @_;
	return $register{$class}{$tag} // $class->unknown_tag($tag);
}

sub tags
{
	my($class) = @_;

	my $map = $register{$class} or return;

	return grep{ not( /^:/ or /^__/ ) } keys %$map;
}


sub pack_tags
{
	my $class = shift @_;

	my $bits = 0;
	foreach my $tag(@_){
		$bits |= $class->tag($tag);
	}
	return $bits;
}
sub unpack_tags
{
	my($class, $bits) = @_;

	return unless defined $bits;

	return grep{ $class->tag($_) & $bits or $class->tag($_) == $bits } $class->tags;
}

1;
__END__