package Mouse::Meta::TypeConstraint;
use strict;
use warnings;
-use overload '""' => sub { shift->{name} }, # stringify to tc name
- fallback => 1;
+
+use overload
+ '""' => sub { shift->{name} }, # stringify to tc name
+ fallback => 1;
+
+use Carp qw(confess);
+use Scalar::Util qw(blessed reftype);
+
+use Mouse::Util qw(:meta);
+
+my $null_check = sub { 1 };
sub new {
- my $class = shift;
- my %args = @_;
- my $name = $args{name} || '__ANON__';
+ my($class, %args) = @_;
+
+ $args{name} = '__ANON__' if !defined $args{name};
+
+ my $check = $args{_compiled_type_constraint} || $args{constraint};
- my $check = $args{_compiled_type_constraint} or Carp::croak("missing _compiled_type_constraint");
- if (ref $check eq 'Mouse::Meta::TypeConstraint') {
+ if(blessed($check)){
+ Carp::cluck("'constraint' must be a CODE reference");
$check = $check->{_compiled_type_constraint};
}
- bless +{ name => $name, _compiled_type_constraint => $check }, $class;
+ if(defined($check) && ref($check) ne 'CODE'){
+ confess("Type constraint for $args{name} is not a CODE reference");
+ }
+
+ my $self = bless \%args, $class;
+ $self->{_compiled_type_constraint} ||= $self->_compile();
+
+ return $self;
+}
+
+sub create_child_type{
+ my $self = shift;
+ # XXX: FIXME
+ return ref($self)->new(
+ %{$self}, # pass the inherit parent attributes
+ _compiled_type_constraint => undef, # ... other than compiled type constraint
+ @_, # ... and args
+ parent => $self # ... and the parent
+ );
}
-sub name { shift->{name} }
+sub name { $_[0]->{name} }
+sub parent { $_[0]->{parent} }
+sub message { $_[0]->{message} }
sub check {
my $self = shift;
$self->{_compiled_type_constraint}->(@_);
}
+sub validate {
+ my ($self, $value) = @_;
+ if ($self->{_compiled_type_constraint}->($value)) {
+ return undef;
+ }
+ else {
+ $self->get_message($value);
+ }
+}
+
+sub assert_valid {
+ my ($self, $value) = @_;
+
+ my $error = $self->validate($value);
+ return 1 if ! defined $error;
+
+ confess($error);
+}
+
+sub get_message {
+ my ($self, $value) = @_;
+ if ( my $msg = $self->message ) {
+ local $_ = $value;
+ return $msg->($value);
+ }
+ else {
+ $value = ( defined $value ? overload::StrVal($value) : 'undef' );
+ return
+ "Validation failed for '"
+ . $self->name
+ . "' failed with value $value";
+ }
+}
+
+sub is_a_type_of{
+ my($self, $other) = @_;
+
+ # ->is_a_type_of('__ANON__') is always false
+ return 0 if !blessed($other) && $other eq '__ANON__';
+
+ (my $other_name = $other) =~ s/\s+//g;
+
+ return 1 if $self->name eq $other_name;
+
+ if(exists $self->{type_constraints}){ # union
+ foreach my $type(@{$self->{type_constraints}}){
+ return 1 if $type->name eq $other_name;
+ }
+ }
+
+ for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
+ return 1 if $parent->name eq $other_name;
+ }
+
+ return 0;
+}
+
+sub _compile{
+ my($self) = @_;
+
+ # add parents first
+ my @checks;
+ for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
+ if($parent->{constraint}){
+ push @checks, $parent->{constraint};
+ }
+ elsif($parent->{_compiled_type_constraint} && $parent->{_compiled_type_constraint} != $null_check){
+ # hand-optimized constraint
+ push @checks, $parent->{_compiled_type_constraint};
+ last;
+ }
+ }
+ # then add child
+ if($self->{constraint}){
+ push @checks, $self->{constraint};
+ }
+
+ if(@checks == 0){
+ return $null_check;
+ }
+ elsif(@checks == 1){
+ my $c = $checks[0];
+ return sub{
+ my(@args) = @_;
+ local $_ = $args[0];
+ return $c->(@args);
+ };
+ }
+ else{
+ return sub{
+ my(@args) = @_;
+ local $_ = $args[0];
+ foreach my $c(@checks){
+ return undef if !$c->(@args);
+ }
+ return 1;
+ };
+ }
+}
+
1;
__END__
=head1 NAME
-Mouse::Meta::TypeConstraint - The Mouse Type Constraint Metaclass
+Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass
=head1 DESCRIPTION
=back
+=head1 SEE ALSO
+
+L<Moose::Meta::TypeConstraint>
+
=cut