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   = '0.72';
  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 module is currently only use internally by L<Moose::Util::TypeConstraints>.
  78 It can be used to create your own private type constraint registry as well, but
  79 the details of that are currently left as an exercise to the reader. (One hint:
  80 You can use the 'parent_registry' feature to connect your private version with the
  81 base Moose registry and base Moose types will automagically be found too).
  82
  83 =head1 METHODS
  84
  85 =over 4
  86
  87 =item B<meta>
  88
  89 =item B<new>
  90
  91 =item B<get_parent_registry>
  92
  93 =item B<set_parent_registry ($registry)>
  94
  95 =item B<has_parent_registry>
  96
  97 =item B<type_constraints>
  98
  99 =item B<has_type_constraint ($type_name)>
 100
 101 =item B<get_type_constraint ($type_name)>
 102
 103 Returns a type constraint object from the registry by name. Will return
 104 false if the supplied type name cannot be found.
 105
 106 =item B<add_type_constraint ($type)>
 107
 108 Adds a type constraint object to the registry. Will throw an exception if
 109 no type is supplied, or the supplied object does not inherit from
 110 L<Moose::Meta::TypeConstraint>
 111
 112 =item B<find_type_constraint ($type_name)>
 113
 114 =back
 115
 116 =head1 BUGS
 117
 118 All complex software has bugs lurking in it, and this module is no
 119 exception. If you find a bug please either email me, or add the bug
 120 to cpan-RT.
 121
 122 =head1 AUTHOR
 123
 124 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 125
 126 =head1 COPYRIGHT AND LICENSE
 127
 128 Copyright 2006-2009 by Infinity Interactive, Inc.
 129
 130 L<http://www.iinteractive.com>
 131
 132 This library is free software; you can redistribute it and/or modify
 133 it under the same terms as Perl itself.
 134
 135 =cut