lib/Moose/Meta/TypeConstraint/Registry.pm

   1
   2 package Moose::Meta::TypeConstraint::Registry;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Scalar::Util 'blessed';
   9
  10 our $VERSION   = '1.14';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Object';
  15
  16 __PACKAGE__->meta->add_attribute('parent_registry' => (
  17     reader    => 'get_parent_registry',
  18     writer    => 'set_parent_registry',
  19     predicate => 'has_parent_registry',
  20 ));
  21
  22 __PACKAGE__->meta->add_attribute('type_constraints' => (
  23     reader  => 'type_constraints',
  24     default => sub { {} }
  25 ));
  26
  27 sub new {
  28     my $class = shift;
  29     my $self  = $class->_new(@_);
  30     return $self;
  31 }
  32
  33 sub has_type_constraint {
  34     my ($self, $type_name) = @_;
  35     ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0
  36 }
  37
  38 sub get_type_constraint {
  39     my ($self, $type_name) = @_;
  40     return unless defined $type_name;
  41     $self->type_constraints->{$type_name}
  42 }
  43
  44 sub add_type_constraint {
  45     my ($self, $type) = @_;
  46
  47     unless ( $type && blessed $type && $type->isa('Moose::Meta::TypeConstraint') ) {
  48         require Moose;
  49         Moose->throw_error("No type supplied / type is not a valid type constraint");
  50     }
  51
  52     $self->type_constraints->{$type->name} = $type;
  53 }
  54
  55 sub find_type_constraint {
  56     my ($self, $type_name) = @_;
  57     return $self->get_type_constraint($type_name)
  58         if $self->has_type_constraint($type_name);
  59     return $self->get_parent_registry->find_type_constraint($type_name)
  60         if $self->has_parent_registry;
  61     return;
  62 }
  63
  64 1;
  65
  66 __END__
  67
  68
  69 =pod
  70
  71 =head1 NAME
  72
  73 Moose::Meta::TypeConstraint::Registry - registry for type constraints
  74
  75 =head1 DESCRIPTION
  76
  77 This class is a registry that maps type constraint names to
  78 L<Moose::Meta::TypeConstraint> objects.
  79
  80 Currently, it is only used internally by
  81 L<Moose::Util::TypeConstraints>, which creates a single global
  82 registry.
  83
  84 =head1 INHERITANCE
  85
  86 C<Moose::Meta::TypeConstraint::Registry> is a subclass of
  87 L<Class::MOP::Object>.
  88
  89 =head1 METHODS
  90
  91 =over 4
  92
  93 =item B<< Moose::Meta::TypeConstraint::Registry->new(%options) >>
  94
  95 This creates a new registry object based on the provided C<%options>:
  96
  97 =over 8
  98
  99 =item * parent_registry
 100
 101 This is an optional L<Moose::Meta::TypeConstraint::Registry>
 102 object.
 103
 104 =item * type_constraints
 105
 106 This is hash reference of type names to type objects. This is
 107 optional. Constraints can be added to the registry after it is
 108 created.
 109
 110 =back
 111
 112 =item B<< $registry->get_parent_registry >>
 113
 114 Returns the registry's parent registry, if it has one.
 115
 116 =item B<< $registry->has_parent_registry >>
 117
 118 Returns true if the registry has a parent.
 119
 120 =item B<< $registry->set_parent_registry($registry) >>
 121
 122 Sets the parent registry.
 123
 124 =item B<< $registry->get_type_constraint($type_name) >>
 125
 126 This returns the L<Moose::Meta::TypeConstraint> object from the
 127 registry for the given name, if one exists.
 128
 129 =item B<< $registry->has_type_constraint($type_name) >>
 130
 131 Returns true if the registry has a type of the given name.
 132
 133 =item B<< $registry->add_type_constraint($type) >>
 134
 135 Adds a new L<Moose::Meta::TypeConstraint> object to the registry.
 136
 137 =item B<< $registry->find_type_constraint($type_name) >>
 138
 139 This method looks in the current registry for the named type. If the
 140 type is not found, then this method will look in the registry's
 141 parent, if it has one.
 142
 143 =back
 144
 145 =head1 BUGS
 146
 147 See L<Moose/BUGS> for details on reporting bugs.
 148
 149 =head1 AUTHOR
 150
 151 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 152
 153 =head1 COPYRIGHT AND LICENSE
 154
 155 Copyright 2006-2010 by Infinity Interactive, Inc.
 156
 157 L<http://www.iinteractive.com>
 158
 159 This library is free software; you can redistribute it and/or modify
 160 it under the same terms as Perl itself.
 161
 162 =cut