Initial implementation for bitfield types

lib/Type/Tiny/Bitfield.pm

@@ -0,0 +1,146 @@
+package Type::Tiny::Bitfield;
+
+use 5.008001;
+use strict;
+use warnings;
+
+BEGIN {
+	$Type::Tiny::Bitfield::AUTHORITY = 'cpan:TOBYINK';
+	$Type::Tiny::Bitfield::VERSION   = '2.002001';
+}
+
+$Type::Tiny::Bitfield::VERSION =~ tr/_//d;
+
+sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
+
+use Exporter::Tiny 1.004001 ();
+use Type::Tiny ();
+our @ISA = qw( Type::Tiny Exporter::Tiny );
+
+sub _is_power_of_two { not $_[0] & $_[0]-1 }
+
+sub _exporter_fail {
+	my ( $class, $type_name, $values, $globals ) = @_;
+	my $caller = $globals->{into};
+	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};
+
+	require Types::Common::Numeric;
+	$opts{parent} = Types::Common::Numeric::PositiveOrZeroInt();
+
+	my $ALL = 0;
+	my %already = ();
+	for my $value ( values %{ $opts{values} } ) {
+		_croak "Not a positive power of 2 in a bitfield: $value"
+			unless _is_power_of_two $value;
+		_croak "Duplicate value in a bitfield: $value"
+			if $already{$value}++;
+		$ALL |= ( 0 + $value );
+	}
+	$opts{ALL} = $ALL;
+
+	# TODO: ensure all keys in $opt{values} are caps
+
+	$opts{constraint} = sub {
+		not shift() & ~$ALL;
+	};
+
+	# TODO: coercion
+
+	return $proto->SUPER::new( %opts );
+} #/ sub new
+
+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 => {},
+			),
+		};
+	}
+
+	return $exportables;
+}
+
+sub can_be_inlined {
+	!!1;
+}
+
+sub inline_check {
+	my ( $self, $var ) = @_;
+
+	return sprintf(
+		'( %s and not %s & ~%d )',
+		Types::Common::Numeric::PositiveOrZeroInt()->inline_check( $var ),
+		$var,
+		$self->{ALL},
+	);
+}
+
+sub AUTOLOAD {
+	my $self = shift;
+	my ( $m ) = ( our $AUTOLOAD =~ /::(\w+)$/ );
+	return if $m eq 'DESTROY';
+	if ( ref $self and exists $self->{values}{$m} ) {
+		return $self->{values}{$m};
+	}
+	return $self->SUPER::AUTOLOAD( @_ );
+}
+
+sub can {
+	my ( $self, $m ) = ( shift, @_ );
+	if ( ref $self and exists $self->{values}{$m} ) {
+		return sub () { $self->{values}{$m} };
+	}
+	return $self->SUPER::can( @_ );
+}
+
+1;

t/20-modules/Type-Tiny-Bitfield/basic.t

@@ -0,0 +1,53 @@
+use strict;
+use warnings;
+use Test::More;
+
+use Type::Tiny::Bitfield LineStyle => {
+	RED    => 1,
+	BLUE   => 2,
+	GREEN  => 4,
+	DOTTED => 64,
+};
+
+is ( LINESTYLE_RED,  1, 'LINESTYLE_RED' );
+is ( LINESTYLE_BLUE,  2, 'LINESTYLE_BLUE' );
+is ( LINESTYLE_GREEN,  4, 'LINESTYLE_GREEN' );
+is ( LINESTYLE_DOTTED, 64, 'LINESTYLE_DOTTED' );
+
+is ( LineStyle->RED,  1, 'LineStyle->RED' );
+is ( LineStyle->BLUE,  2, 'LineStyle->BLUE' );
+is ( LineStyle->GREEN,  4, 'LineStyle->GREEN' );
+is ( LineStyle->DOTTED, 64, 'LineStyle->DOTTED' );
+
+ok( is_LineStyle( LINESTYLE_RED ), 'is_LineStyle( LINESTYLE_RED )' );
+
+my $RedDottedLine = LINESTYLE_RED | LINESTYLE_DOTTED;
+
+is( $RedDottedLine, 65 );
+ok( is_LineStyle( $RedDottedLine ) );
+
+ok( !is_LineStyle( 'RED' ) );
+ok( !is_LineStyle( -4 ) );
+
+ok(  is_LineStyle( $_ ),  "is_LineStyle($_)" ) for 0, 1, 2, 3, 4, 5, 6, 7, 64, 65, 66, 67, 68, 69, 70, 71;
+ok( !is_LineStyle( $_ ), "!is_LineStyle($_)" ) for 8, 9, 10, 11, 12, 13, 14, 15, 62, 63, 72;
+
+{
+	local $@;
+	ok !eval q{
+		use Type::Tiny::Bitfield Abcdef => {
+			RED    => 1,
+			BLUE   => 2,
+			GREEN  => 3,
+			DOTTED => 4,
+		};
+		1;
+	};
+	like $@, qr/^Not a positive power of 2/, 'error message';
+};
+
+ok( LineStyle->can_be_inlined, 'can be inlined' );
+
+note LineStyle->inline_check( '$VALUE' );
+
+done_testing;