1 package Moose::Meta::TypeConstraint::Class;
7 use Scalar::Util 'blessed';
8 use Moose::Util::TypeConstraints ();
10 our $VERSION = '0.72';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Moose::Meta::TypeConstraint';
16 __PACKAGE__->meta->add_attribute('class' => (
21 my ( $class, %args ) = @_;
23 $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
24 my $self = $class->_new(\%args);
26 $self->_create_hand_optimized_type_constraint;
27 $self->compile_type_constraint();
32 sub _create_hand_optimized_type_constraint {
34 my $class = $self->class;
35 $self->hand_optimized_type_constraint(
37 blessed( $_[0] ) && $_[0]->isa($class)
47 # FIXME find_type_constraint might find a TC named after the class but that isn't really it
48 # I did this anyway since it's a convention that preceded TypeConstraint::Class, and it should DWIM
49 # if anybody thinks this problematic please discuss on IRC.
50 # a possible fix is to add by attr indexing to the type registry to find types of a certain property
51 # regardless of their name
52 Moose::Util::TypeConstraints::find_type_constraint($_)
54 __PACKAGE__->new( class => $_, name => "__ANON__" )
55 } $self->class->meta->superclasses,
60 my ( $self, $type_or_name ) = @_;
62 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
64 return unless defined $other;
65 return unless $other->isa(__PACKAGE__);
67 return $self->class eq $other->class;
71 my ($self, $type_or_name) = @_;
73 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
75 ($self->equals($type) || $self->is_subtype_of($type_or_name));
79 my ($self, $type_or_name_or_class ) = @_;
81 if ( not ref $type_or_name_or_class ) {
83 return 1 if $self->class->isa( $type_or_name_or_class );
86 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class);
88 return unless defined $type;
90 if ( $type->isa(__PACKAGE__) ) {
91 # if $type_or_name_or_class isn't a class, it might be the TC name of another ::Class type
92 # or it could also just be a type object in this branch
93 return $self->class->isa( $type->class );
95 # the only other thing we are a subtype of is Object
96 $self->SUPER::is_subtype_of($type);
100 # This is a bit counter-intuitive, but a child type of a Class type
101 # constraint is not itself a Class type constraint (it has no class
102 # attribute). This whole create_child_type thing needs some changing
103 # though, probably making MMC->new a factory or something.
104 sub create_child_type {
105 my ($self, @args) = @_;
106 return Moose::Meta::TypeConstraint->new(@args, parent => $self);
117 Moose::Meta::TypeConstraint::Class - Class/TypeConstraint parallel hierarchy
121 This class represents type constraints for a class.
125 C<Moose::Meta::TypeConstraint::Class> is a subclass of
126 L<Moose::Meta::TypeConstraint>.
132 =item B<< Moose::Meta::TypeConstraint::Class->new(%options) >>
134 This creates a new class type constraint based on the given
137 It takes the same options as its parent, with two exceptions. First,
138 it requires an additional option, C<class>, which is name of the
139 constraint's class. Second, it automatically sets the parent to the
142 The constructor also overrides the hand optimized type constraint with
143 one it creates internally.
145 =item B<< $constraint->class >>
147 Returns the class name associated with the constraint.
149 =item B<< $constraint->parents >>
151 Returns all the type's parent types, corresponding to its parent
154 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
156 If the given type is also a class type, then this checks that the
157 type's class is a subclass of the other type's class.
159 Otherwise it falls back to the implementation in
160 L<Moose::Meta::TypeConstraint>.
162 =item B<< $constraint->create_child_type(%options) >>
164 This returns a new L<Moose::Meta::TypeConstraint> object with the type
167 Note that it does I<not> return a
168 C<Moose::Meta::TypeConstraint::Class> object!
174 All complex software has bugs lurking in it, and this module is no
175 exception. If you find a bug please either email me, or add the bug
180 Yuval Kogman E<lt>nothingmuch@cpan.orgE<gt>
182 =head1 COPYRIGHT AND LICENSE
184 Copyright 2006-2009 by Infinity Interactive, Inc.
186 L<http://www.iinteractive.com>
188 This library is free software; you can redistribute it and/or modify
189 it under the same terms as Perl itself.