local-lib5/lib/perl5/Parse/Method/Signatures/TypeConstraint.pm

   1 package Parse::Method::Signatures::TypeConstraint;
   2
   3 use Carp qw/croak carp/;
   4 use Moose;
   5 use MooseX::Types::Util qw/has_available_type_export/;
   6 use MooseX::Types::Moose qw/Str HashRef CodeRef ClassName/;
   7 use Parse::Method::Signatures::Types qw/TypeConstraint/;
   8
   9 use namespace::clean -except => 'meta';
  10
  11 has ppi => (
  12   is       => 'ro',
  13   isa      => 'PPI::Element',
  14   required => 1,
  15   handles => {
  16     'to_string' => 'content'
  17   }
  18 );
  19
  20 has tc => (
  21     is => 'ro',
  22     isa => TypeConstraint,
  23     lazy => 1,
  24     builder => '_build_tc',
  25 );
  26
  27 has from_namespace => (
  28     is => 'ro',
  29     isa => ClassName,
  30     predicate => 'has_from_namespace'
  31 );
  32
  33 has tc_callback => (
  34     is       => 'ro',
  35     isa      => CodeRef,
  36     default  => sub { \&find_registered_constraint },
  37 );
  38
  39 sub find_registered_constraint {
  40     my ($self, $name) = @_;
  41
  42     my $type;
  43     if ($self->has_from_namespace) {
  44         my $pkg = $self->from_namespace;
  45
  46         if ($type = has_available_type_export($pkg, $name)) {
  47             croak "The type '$name' was found in $pkg " .
  48                   "but it hasn't yet been defined. Perhaps you need to move the " .
  49                   "definition into a type library or a BEGIN block.\n"
  50                 if $type && $type->isa('MooseX::Types::UndefinedType');
  51         }
  52         else {
  53             my $meta  = Class::MOP::class_of($pkg) || Class::MOP::Class->initialize($pkg);
  54             my $func  = $meta->get_package_symbol('&' . $name);
  55             my $proto = prototype $func if $func;
  56
  57             $name = $func->()
  58                 if $func && defined $proto && !length $proto;
  59         }
  60     }
  61
  62     my $registry = Moose::Util::TypeConstraints->get_type_constraint_registry;
  63     return $type || $registry->find_type_constraint($name) || $name;
  64 }
  65
  66
  67 sub _build_tc {
  68     my ($self) = @_;
  69     my $tc = $self->_walk_data($self->ppi);
  70
  71     # This makes the error appear from the right place
  72     local $Carp::Internal{'Class::MOP::Method::Generated'} = 1
  73       unless exists $Carp::Internal{'Class::MOP::Method::Generated'};
  74
  75     croak "'@{[$self->ppi]}' could not be parsed to a type constraint - maybe you need to "
  76         . "pre-declare the type with class_type"
  77       unless blessed $tc;
  78     return $tc;
  79 }
  80
  81 sub _walk_data {
  82     my ($self, $data) = @_;
  83
  84     my $res = $self->_union_node($data)
  85            || $self->_params_node($data)
  86            || $self->_str_node($data)
  87            || $self->_leaf($data)
  88       or confess 'failed to visit tc';
  89     return $res->();
  90 }
  91
  92 sub _leaf {
  93     my ($self, $data) = @_;
  94
  95     sub { $self->_invoke_callback($data->content) };
  96 }
  97
  98 sub _union_node {
  99     my ($self, $data) = @_;
 100     return unless $data->isa('PPI::Statement::Expression::TCUnion');
 101
 102     my @types = map { $self->_walk_data($_) } $data->children;
 103     sub {
 104       scalar @types == 1 ? @types
 105         : Moose::Meta::TypeConstraint::Union->new(type_constraints => \@types)
 106     };
 107 }
 108
 109 sub _params_node {
 110     my ($self, $data) = @_;
 111     return unless $data->isa('PPI::Statement::Expression::TCParams');
 112
 113     my @params = map { $self->_walk_data($_) } @{$data->params};
 114     my $type = $self->_invoke_callback($data->type);
 115     sub { $type->parameterize(@params) }
 116 }
 117
 118
 119 sub _str_node {
 120     my ($self, $data) = @_;
 121     return unless $data->isa('PPI::Token::StringifiedWord')
 122                || $data->isa('PPI::Token::Number')
 123                || $data->isa('PPI::Token::Quote');
 124
 125     sub {
 126       $data->isa('PPI::Token::Number')
 127           ? $data->content
 128           : $data->string
 129     };
 130 }
 131
 132 sub _invoke_callback {
 133     my $self = shift;
 134     $self->tc_callback->($self, @_);
 135 }
 136
 137 __PACKAGE__->meta->make_immutable;
 138
 139 1;
 140
 141 __END__
 142
 143 =head1 NAME
 144
 145 Parse::Method::Signatures::TypeConstraint - turn parsed TC data into Moose TC object
 146
 147 =head1 DESCRIPTION
 148
 149 Class used to turn PPI elements into L<Moose::Meta::TypeConstraint> objects.
 150
 151 =head1 ATTRIBUTES
 152
 153 =head2 tc
 154
 155 =over
 156
 157 B<Lazy Build.>
 158
 159 =back
 160
 161 The L<Moose::Meta::TypeConstraint> object for this type constraint, built when
 162 requested. L</tc_callback> will be called for each individual component type in
 163 turn.
 164
 165 =head2 tc_callback
 166
 167 =over
 168
 169 B<Type:> CodeRef
 170
 171 B<Default:> L</find_registered_constraint>
 172
 173 =back
 174
 175 Callback used to turn type names into type objects. See
 176 L<Parse::Method::Signatures/type_constraint_callback> for more details and an
 177 example.
 178
 179 =head2 from_namespace
 180
 181 =over
 182
 183 B<Type:> ClassName
 184
 185 =back
 186
 187 If provided, then the default C<tc_callback> will search for L<MooseX::Types>
 188 in this package.
 189
 190 =head1 METHODS
 191
 192 =head2 find_registered_constraint
 193
 194 Will search for an imported L<MooseX::Types> in L</from_namespace> (if
 195 provided). Failing that it will ask the L<Moose::Meta::TypeConstraint::Registry>
 196 for a type with the given name.
 197
 198 If all else fails, it will simple return the type as a string, so that Moose's
 199 auto-vivification of classnames to type will work.
 200
 201 =head2 to_string
 202
 203 String representation of the type constraint, approximately as parsed.
 204
 205 =head1 SEE ALSO
 206
 207 L<Parse::Method::Signatures>, L<MooseX::Types>, L<MooseX::Types::Util>.
 208
 209 =head1 AUTHORS
 210
 211 Florian Ragwitz <rafl@debian.org>.
 212
 213 Ash Berlin <ash@cpan.org>.
 214
 215 =head1 LICENSE
 216
 217 Licensed under the same terms as Perl itself.
 218