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 use Carp         'confess'; # FIXME Moose->throw_error
  10
  11 our $VERSION   = '0.66';
  12 $VERSION = eval $VERSION;
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use base 'Class::MOP::Object';
  16
  17 __PACKAGE__->meta->add_attribute('parent_registry' => (
  18     reader    => 'get_parent_registry',
  19     writer    => 'set_parent_registry',
  20     predicate => 'has_parent_registry',
  21 ));
  22
  23 __PACKAGE__->meta->add_attribute('type_constraints' => (
  24     reader  => 'type_constraints',
  25     default => sub { {} }
  26 ));
  27
  28 sub new {
  29     my $class = shift;
  30     my $self  = $class->_new(@_);
  31     return $self;
  32 }
  33
  34 sub has_type_constraint {
  35     my ($self, $type_name) = @_;
  36     ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0
  37 }
  38
  39 sub get_type_constraint {
  40     my ($self, $type_name) = @_;
  41     return unless defined $type_name;
  42     $self->type_constraints->{$type_name}
  43 }
  44
  45 sub add_type_constraint {
  46     my ($self, $type) = @_;
  47     confess("No type supplied / type is not a valid type constraint")
  48         unless ($type && blessed $type && $type->isa('Moose::Meta::TypeConstraint'));
  49     $self->type_constraints->{$type->name} = $type;
  50 }
  51
  52 sub find_type_constraint {
  53     my ($self, $type_name) = @_;
  54     return $self->get_type_constraint($type_name)
  55         if $self->has_type_constraint($type_name);
  56     return $self->get_parent_registry->find_type_constraint($type_name)
  57         if $self->has_parent_registry;
  58     return;
  59 }
  60
  61 1;
  62
  63 __END__
  64
  65
  66 =pod
  67
  68 =head1 NAME
  69
  70 Moose::Meta::TypeConstraint::Registry - registry for type constraints
  71
  72 =head1 DESCRIPTION
  73
  74 This module is currently only use internally by L<Moose::Util::TypeConstraints>.
  75 It can be used to create your own private type constraint registry as well, but
  76 the details of that are currently left as an exercise to the reader. (One hint:
  77 You can use the 'parent_registry' feature to connect your private version with the
  78 base Moose registry and base Moose types will automagically be found too).
  79
  80 =head1 METHODS
  81
  82 =over 4
  83
  84 =item B<meta>
  85
  86 =item B<new>
  87
  88 =item B<get_parent_registry>
  89
  90 =item B<set_parent_registry ($registry)>
  91
  92 =item B<has_parent_registry>
  93
  94 =item B<type_constraints>
  95
  96 =item B<has_type_constraint ($type_name)>
  97
  98 =item B<get_type_constraint ($type_name)>
  99
 100 Returns a type constraint object from the registry by name. Will return
 101 false if the supplied type name cannot be found.
 102
 103 =item B<add_type_constraint ($type)>
 104
 105 Adds a type constraint object to the registry. Will throw an exception if
 106 no type is supplied, or the supplied object does not inherit from
 107 L<Moose::Meta::TypeConstraint>
 108
 109 =item B<find_type_constraint ($type_name)>
 110
 111 =back
 112
 113 =head1 BUGS
 114
 115 All complex software has bugs lurking in it, and this module is no
 116 exception. If you find a bug please either email me, or add the bug
 117 to cpan-RT.
 118
 119 =head1 AUTHOR
 120
 121 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 122
 123 =head1 COPYRIGHT AND LICENSE
 124
 125 Copyright 2006-2009 by Infinity Interactive, Inc.
 126
 127 L<http://www.iinteractive.com>
 128
 129 This library is free software; you can redistribute it and/or modify
 130 it under the same terms as Perl itself.
 131
 132 =cut