File Coverage

blib/lib/Type/Tiny/Bitfield.pm

Criterion	Covered	Total	%
statement	135	136	99.2
branch	36	44	81.8
condition	29	46	63.0
subroutine	28	28	100.0
pod	9	10	90.0
total	237	264	89.7

package Type::Tiny::Bitfield;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Type::Tiny::Bitfield::AUTHORITY = 'cpan:TOBYINK';
	$Type::Tiny::Bitfield::VERSION   = '2.004000';
}

$Type::Tiny::Bitfield::VERSION =~ tr/_//d;

sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }

use Exporter::Tiny 1.004001 ();
use Type::Tiny ();
use Types::Common::Numeric qw( +PositiveOrZeroInt );
use Eval::TypeTiny qw( eval_closure );

our @ISA = qw( Type::Tiny Exporter::Tiny );

__PACKAGE__->_install_overloads(
	q[+] => 'new_combined',
);

sub _is_power_of_two { not $_[0] & $_[0]-1 }

sub _exporter_fail {
	my ( $class, $type_name, $args, $globals ) = @_;
	my $caller = $globals->{into};
	my %values = %$args;
	/^[-]/ && delete( $values{$_} ) for keys %values;
	my $type = $class->new(
		name      => $type_name,
		values    => \%values,
		coercion  => 1,
	);
	$INC{'Type/Registry.pm'}
		? 'Type::Registry'->for_class( $caller )->add_type( $type, $type_name )
		: ( $Type::Registry::DELAYED{$caller}{$type_name} = $type )
		unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
	return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
}

sub new {
	my $proto = shift;

	my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
	_croak
		"Bitfield type constraints cannot have a parent constraint passed to the constructor"
		if exists $opts{parent};
	_croak
		"Bitfield type constraints cannot have a constraint coderef passed to the constructor"
		if exists $opts{constraint};
	_croak
		"Bitfield type constraints cannot have a inlining coderef passed to the constructor"
		if exists $opts{inlined};
	_croak "Need to supply hashref of values"
		unless exists $opts{values};

	$opts{parent} = PositiveOrZeroInt;

	for my $key ( keys %{ $opts{values} } ) {
		_croak "Not an all-caps name in a bitfield: $key"
			unless $key =~ /^[A-Z][A-Z0-9]*(_[A-Z0-9]+)*/
	}
	my $ALL = 0;
	my %already = ();
	for my $value ( values %{ $opts{values} } ) {
		_croak "Not a positive power of 2 in a bitfield: $value"
			unless is_PositiveOrZeroInt( $value ) && _is_power_of_two( $value );
		_croak "Duplicate value in a bitfield: $value"
			if $already{$value}++;
		$ALL |= ( 0 + $value );
	}
	$opts{ALL} = $ALL;

	$opts{constraint} = sub {
		not shift() & ~$ALL;
	};

	if ( defined $opts{coercion}
	and !ref $opts{coercion}
	and 1 eq $opts{coercion} ) {
		delete $opts{coercion};
		$opts{_build_coercion} = sub {
			require Types::Standard;
			my $c = shift;
			my $t = $c->type_constraint;
			$c->add_type_coercions(
				Types::Standard::Str(),
				$t->_stringy_coercion,
			);
		};
	} #/ if ( defined $opts{coercion...})

	return $proto->SUPER::new( %opts );
} #/ sub new

sub new_combined {
	my ( $self, $other, $swap ) = @_;

	Scalar::Util::blessed( $self )
		&& $self->isa( __PACKAGE__ )
		&& Scalar::Util::blessed( $other )
		&& $other->isa( __PACKAGE__ )
		or _croak( "Bad overloaded operation" );

	( $other, $self ) = ( $self, $other ) if $swap;

	for my $k ( keys %{ $self->values } ) {
		_croak "Conflicting value: $k"
			if exists $other->values->{$k};
	}

	my %all_values = ( %{ $self->values }, %{ $other->values } );
	return ref( $self )->new(
		display_name => sprintf( '%s+%s', "$self", "$other" ),
		values       => \%all_values,
		( $self->has_coercion || $other->has_coercion )
			? ( coercion => 1 )
			: (),
	);
}

sub values {
	$_[0]{values};
}

sub _lockdown {
	my ( $self, $callback ) = @_;
	$callback->( $self->{values} );
}

sub exportables {
	my ( $self, $base_name ) = @_;
	if ( not $self->is_anon ) {
		$base_name ||= $self->name;
	}

	my $exportables = $self->SUPER::exportables( $base_name );

	require Eval::TypeTiny;
	require B;

	for my $key ( keys %{ $self->values } ) {
		my $value = $self->values->{$key};
		push @$exportables, {
			name => uc( sprintf '%s_%s', $base_name, $key ),
			tags => [ 'constants' ],
			code => Eval::TypeTiny::eval_closure(
				source      => sprintf( 'sub () { %d }', $value ),
				environment => {},
			),
		};
	}

	my $weak = $self;
	require Scalar::Util;
	Scalar::Util::weaken( $weak );
	push @$exportables, {
		name => sprintf( '%s_to_Str', $base_name ),
		tags => [ 'from' ],
		code => sub { $weak->to_string( @_ ) },
	};

	return $exportables;
}

sub constant_names {
	my $self = shift;
	return map { $_->{name} }
		grep { my $tags = $_->{tags}; grep $_ eq 'constants', @$tags; }
		@{ $self->exportables || [] };
}

sub can_be_inlined {
	!!1;
}

sub inline_check {
	my ( $self, $var ) = @_;

	return sprintf(
		'( %s and not %s & ~%d )',
		PositiveOrZeroInt->inline_check( $var ),
		$var,
		$self->{ALL},
	);
}

sub _stringy_coercion {
	my ( $self, $varname ) = @_;
	$varname ||= '$_';
	my %vals = %{ $self->values };
	my $pfx  = uc( "$self" );
	my $pfxl = length $pfx;
	my $hash = sprintf(
		'( %s )',
		join(
			q{, },
			map sprintf( '%s => %d', B::perlstring($_), $vals{$_} ),
			sort keys %vals,
		),
	);
	return qq{do { my \$bits = 0; my \%lookup = $hash; for my \$tok ( grep /\\w/, split /[\\s|+]+/, uc( $varname ) ) { if ( substr( \$tok, 0, $pfxl) eq "$pfx" ) { \$tok = substr( \$tok, $pfxl ); \$tok =~ s/^_//; } if ( exists \$lookup{\$tok} ) { \$bits |= \$lookup{\$tok}; next; } require Carp; Carp::carp("Unknown token: \$tok"); } \$bits; }};
}

sub from_string {
	my ( $self, $str ) = @_;
	$self->{from_string} ||= eval_closure(
		environment => {},
		source      => sprintf( 'sub { my $STR = shift; %s }', $self->_stringy_coercion( '$STR' ) ),
	);
	$self->{from_string}->( $str );
}

sub to_string {
	my ( $self, $int ) = @_;
	$self->check( $int ) or return undef;
	my %values = %{ $self->values };
	$self->{all_names} ||= [ sort { $values{$a} <=> $values{$b} } keys %values ];
	$int += 0;
	my @names;
	for my $n ( @{ $self->{all_names} } ) {
		push @names, $n if $int & $values{$n};
	}
	return join q{|}, @names;
}

sub AUTOLOAD {
	our $AUTOLOAD;
	my $self = shift;
	my ( $m ) = ( $AUTOLOAD =~ /::(\w+)$/ );
	return if $m eq 'DESTROY';
	if ( ref $self and exists $self->{values}{$m} ) {
		return 0 + $self->{values}{$m};
	}
	local $Type::Tiny::AUTOLOAD = $AUTOLOAD;
	return $self->SUPER::AUTOLOAD( @_ );
}

sub can {
	my ( $self, $m ) = ( shift, @_ );
	if ( ref $self and exists $self->{values}{$m} ) {
		return sub () { 0 + $self->{values}{$m} };
	}
	return $self->SUPER::can( @_ );
}

1;

__END__