use Sub::Name 'subname';
use Carp 'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util qw(blessed refaddr);
our $VERSION = '0.12';
our $AUTHORITY = 'cpan:STEVAN';
sub equals {
my ( $self, $type_or_name ) = @_;
- my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return 1 if refaddr($self) == refaddr($other);
+
+ if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
+ return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
+ }
+
+ return unless $self->constraint == $other->constraint;
+
+ if ( $self->has_parent ) {
+ return unless $other->has_parent;
+ return unless $self->parent->equals( $other->parent );
+ } else {
+ return if $other->has_parent;
+ }
- # this is so utterly broken
- # any anon type constraint equals any other, because their names are both '__ANON__'
- # I think the correct implementation is:
- # refaddr == refaddr
- # ||
- # constraint_coderef == constraint_coderef && parent->equals(parent)
- # but we need tests first
- # the Enum constraint can compare it's elements in a subclass
- # refaddr eq will DWIM for all registered types
- # the Class tc will already do the right thing even if the name is different
- $self->name eq $type->name;
+ return 1;
}
sub is_a_type_of {
my $self = $class->meta->new_object(%args);
- $self->compile_type_constraint()
- unless $self->_has_compiled_type_constraint;
+ $self->_create_hand_optimized_type_constraint;
+
+ $self->compile_type_constraint();
return $self;
}
+sub _create_hand_optimized_type_constraint {
+ my $self = shift;
+ my $class = $self->class;
+ $self->hand_optimized_type_constraint(sub { blessed( $_[0] ) && $_[0]->isa($class) });
+}
+
sub parents {
my $self = shift;
return (
);
}
-sub hand_optimized_type_constraint {
- my $self = shift;
- my $class = $self->class;
- sub { blessed( $_[0] ) && $_[0]->isa($class) }
-}
-
-sub has_hand_optimized_type_constraint { 1 }
-
sub equals {
my ( $self, $type_or_name ) = @_;
- my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
- if ( $type->isa(__PACKAGE__) ) {
- return $self->class eq $type->class;
- } else {
- $self->SUPER::equals($type);
- }
+ return unless $other->isa(__PACKAGE__);
+
+ return $self->class eq $other->class;
}
sub is_a_type_of {
--- /dev/null
+#!/usr/bin/perl
+
+package Moose::Meta::TypeConstraint::Enum;
+
+use strict;
+use warnings;
+use metaclass;
+
+our $VERSION = '0.06';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeConstraint';
+
+__PACKAGE__->meta->add_attribute('values' => (
+ accessor => 'values',
+));
+
+sub new {
+ my ( $class, %args ) = @_;
+
+ $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str');
+
+ my $self = $class->meta->new_object(%args);
+
+ $self->compile_type_constraint()
+ unless $self->_has_compiled_type_constraint;
+
+ return $self;
+}
+
+sub equals {
+ my ( $self, $type_or_name ) = @_;
+
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return unless $other->isa(__PACKAGE__);
+
+ my @self_values = sort @{ $self->values };
+ my @other_values = sort @{ $other->values };
+
+ return unless @self_values == @other_values;
+
+ while ( @self_values ) {
+ my $value = shift @self_values;
+ my $other_value = shift @other_values;
+
+ return unless $value eq $other_value;
+ }
+
+ return 1;
+}
+
+sub constraint {
+ my $self = shift;
+
+ my %values = map { $_ => undef } @{ $self->values };
+
+ return sub { exists $values{$_[0]} };
+}
+
+sub _compile_hand_optimized_type_constraint {
+ my $self = shift;
+
+ my %values = map { $_ => undef } @{ $self->values };
+
+ sub { defined($_[0]) && !ref($_[0]) && exists $values{$_[0]} };
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeConstraint::Enum - Type constraint for enumerated values.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<equals>
+
+=item B<constraint>
+
+=item B<values>
+
+=back
+
+=cut
+
+
predicate => 'has_type_parameter',
));
+sub equals {
+ my ( $self, $type_or_name ) = @_;
+
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return unless $other->isa(__PACKAGE__);
+
+ return (
+ $self->type_parameter->equals( $other->type_parameter )
+ and
+ $self->parent->equals( $other->parent )
+ );
+}
+
sub compile_type_constraint {
my $self = shift;
=item B<meta>
+=item B<equals>
+
=back
=head1 BUGS
return $self;
}
+sub equals {
+ my ( $self, $type_or_name ) = @_;
+
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+ return unless $other->isa(__PACKAGE__);
+
+ my @self_constraints = @{ $self->type_constraints };
+ my @other_constraints = @{ $other->type_constraints };
+
+ return unless @self_constraints == @other_constraints;
+
+ # FIXME presort type constraints for efficiency?
+ constraint: foreach my $constraint ( @self_constraints ) {
+ for ( my $i = 0; $i < @other_constraints; $i++ ) {
+ if ( $constraint->equals($other_constraints[$i]) ) {
+ splice @other_constraints, $i, 1;
+ next constraint;
+ }
+ }
+ }
+
+ return @other_constraints == 0;
+}
+
+sub parents {
+ my $self = shift;
+ $self->type_constraints;
+}
+
sub validate {
my ($self, $value) = @_;
my $message;
=item B<type_constraints>
+=item B<parents>
+
=item B<constraint>
=item B<includes_type>
+=item B<equals>
+
=back
=head2 Overriden methods
sub create_type_constraint_union (@);
sub create_parameterized_type_constraint ($);
sub create_class_type_constraint ($;$);
+sub create_enum_type_constraint ($$);
#sub create_class_type_constraint ($);
# dah sugah!
use Moose::Meta::TypeConstraint::Union;
use Moose::Meta::TypeConstraint::Parameterized;
use Moose::Meta::TypeConstraint::Parameterizable;
+use Moose::Meta::TypeConstraint::Enum;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
use Moose::Meta::TypeConstraint::Registry;
$message = $_[0]->{message} if exists $_[0]->{message};
}
+ # FIXME allow a different name too, and potentially handle anon
Moose::Meta::TypeConstraint::Class->new(
name => $class,
($message ? (message => $message) : ())
my $constraint = shift;
confess "can't register an unnamed type constraint" unless defined $constraint->name;
$REGISTRY->add_type_constraint($constraint);
+ return $constraint;
}
# type constructors
(scalar @values >= 2)
|| confess "You must have at least two values to enumerate through";
my %valid = map { $_ => 1 } @values;
- _create_type_constraint(
- $type_name,
- 'Str',
- sub { $valid{$_} }
+
+ register_type_constraint(
+ create_enum_type_constraint(
+ $type_name,
+ \@values,
+ )
+ );
+}
+
+sub create_enum_type_constraint ($$) {
+ my ( $type_name, $values ) = @_;
+
+ Moose::Meta::TypeConstraint::Enum->new(
+ name => $type_name || '__ANON__',
+ values => $values,
);
}
optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
constraint_generator => sub {
my $type_parameter = shift;
+ my $check = $type_parameter->_compiled_type_constraint;
return sub {
foreach my $x (@$_) {
- ($type_parameter->check($x)) || return
+ ($check->($x)) || return
} 1;
}
}
optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
constraint_generator => sub {
my $type_parameter = shift;
+ my $check = $type_parameter->_compiled_type_constraint;
return sub {
foreach my $x (values %$_) {
- ($type_parameter->check($x)) || return
+ ($check->($x)) || return
} 1;
}
}
constraint => sub { 1 },
constraint_generator => sub {
my $type_parameter = shift;
+ my $check = $type_parameter->_compiled_type_constraint;
return sub {
- return 1 if not(defined($_)) || $type_parameter->check($_);
+ return 1 if not(defined($_)) || $check->($_);
return;
}
}
Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
object for that class name.
+=item B<create_enum_type_constraint ($name, $values)>
+
=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
This will attempt to find or create a type constraint given the a C<$type_name>.
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More tests => 33;
use Test::Exception;
BEGIN {
ok($Str_or_Undef->check(undef), '... (Str | Undef) can accept an Undef value');
ok($Str_or_Undef->check('String'), '... (Str | Undef) can accept a String value');
+ok($Str_or_Undef->is_a_type_of($Str), "subtype of Str");
+ok($Str_or_Undef->is_a_type_of($Undef), "subtype of Undef");
+
+ok( !$Str_or_Undef->equals($Str), "not equal to Str" );
+ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" );
+ok( $Str_or_Undef->equals(Moose::Meta::TypeConstraint::Union->new(type_constraints => [ $Str, $Undef ])), "equal to clone" );
+ok( $Str_or_Undef->equals(Moose::Meta::TypeConstraint::Union->new(type_constraints => [ $Undef, $Str ])), "equal to reversed clone" );
+
# another ....
my $ArrayRef = find_type_constraint('ArrayRef');
plan tests => @valid_letters + @invalid_letters
+ @valid_languages + @invalid_languages
+ @valid_metacharacters + @invalid_metacharacters
- + @valid_languages + 3;
+ + @valid_languages + 6;
Moose::Util::TypeConstraints->export_type_constraints_as_functions();
ok($anon_enum->check($_), "'$_' is a language") for @valid_languages;
-
+ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" );
+ok( $anon_enum->equals( $anon_enum ), "equals itself" );
+ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" );
use strict;
use warnings;
-use Test::More tests => 18;
+use Test::More tests => 21;
use Test::Exception;
BEGIN {
ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly');
+
+ ok( $t->equals($t), "equals to self" );
+ ok( !$t->equals( $t->parent ), "not equal to parent" );
+ ok( $t->parent->equals( $t->parent ), "parent equals to self" );
}
lives_ok {
use strict;
use warnings;
-use Test::More tests => 21;
+use Test::More tests => 28;
use Test::Exception;
BEGIN {
ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
+
+ ok( $t->equals($t), "equals to self" );
+ ok( !$t->equals($t->parent), "not equal to parent" );
}
my $hoi = Moose::Util::TypeConstraints::find_or_create_type_constraint('AlphaKeyHash[Int]');
ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly');
ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly');
+ok( $hoi->equals($hoi), "equals to self" );
+ok( !$hoi->equals($hoi->parent), "equals to self" );
+ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" );
+ok( $hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
+ok( !$hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" );
+
my $th = Moose::Util::TypeConstraints::find_or_create_type_constraint('Trihash[Bool]');
ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly');
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 19;
use Test::Exception;
BEGIN {
isa_ok($type, 'Moose::Meta::TypeConstraint');
isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized');
+ok( $type->equals($type), "equals self" );
+ok( !$type->equals($type->parent), "not equal to parent" );
+ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" );
+ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" );
+ok( $type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
+ok( !$type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" );
+ok( !$type->equals( Moose::Util::TypeConstraints::find_or_create_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" );
+
ok($type->check(10), '... checked type correctly (pass)');
ok($type->check(undef), '... checked type correctly (pass)');
ok(!$type->check('Hello World'), '... checked type correctly (fail)');
projects / gitmo/Moose.git / commitdiff