lib/MooseX/Types/Base.pm

   1 package MooseX::Types::Base;
   2 our $VERSION = "0.26";
   3 use Moose;
   4
   5 =head1 NAME
   6
   7 MooseX::Types::Base - Type library base class
   8
   9 =cut
  10
  11 use Carp::Clan                      qw( ^MooseX::Types );
  12 use MooseX::Types::Util             qw( filter_tags );
  13 use Sub::Exporter                   qw( build_exporter );
  14 use Moose::Util::TypeConstraints;
  15
  16 use namespace::clean -except => [qw( meta )];
  17
  18 =head1 DESCRIPTION
  19
  20 You normally won't need to interact with this class by yourself. It is
  21 merely a collection of functionality that type libraries need to
  22 interact with moose and the rest of the L<MooseX::Types> module.
  23
  24 =cut
  25
  26 my $UndefMsg = q{Unable to find type '%s' in library '%s'};
  27
  28 =head1 METHODS
  29
  30 =cut
  31
  32 =head2 import
  33
  34 Provides the import mechanism for your library. See
  35 L<MooseX::Types/"LIBRARY USAGE"> for syntax details on this.
  36
  37 =cut
  38
  39 sub import {
  40     my ($class, @args) = @_;
  41
  42     # filter or create options hash for S:E
  43     my $options = (@args and (ref($args[0]) eq 'HASH')) ? $args[0] : undef;
  44     unless ($options) {
  45         $options = {foo => 23};
  46         unshift @args, $options;
  47     }
  48
  49     # all types known to us
  50     my @types = $class->type_names;
  51
  52     # determine the wrapper, -into is supported for compatibility reasons
  53     my $wrapper = $options->{ -wrapper } || 'MooseX::Types';
  54     $args[0]->{into} = $options->{ -into }
  55         if exists $options->{ -into };
  56
  57     my (%ex_spec, %ex_util);
  58   TYPE:
  59     for my $type_short (@types) {
  60
  61         # find type name and object, create undefined message
  62         my $type_full = $class->get_type($type_short)
  63             or croak "No fully qualified type name stored for '$type_short'";
  64         my $type_cons = find_type_constraint($type_full);
  65         my $undef_msg = sprintf($UndefMsg, $type_short, $class);
  66
  67         # the type itself
  68         push @{ $ex_spec{exports} },
  69             $type_short,
  70             sub {
  71                 bless $wrapper->type_export_generator($type_short, $type_full),
  72                     'MooseX::Types::EXPORTED_TYPE_CONSTRAINT';
  73             };
  74
  75         # the check helper
  76         push @{ $ex_spec{exports} },
  77             "is_${type_short}",
  78             sub { $wrapper->check_export_generator($type_short, $type_full, $undef_msg) };
  79
  80         # only export coercion helper if full (for libraries) or coercion is defined
  81         next TYPE
  82             unless $options->{ -full }
  83             or ($type_cons and $type_cons->has_coercion);
  84         push @{ $ex_spec{exports} },
  85             "to_${type_short}",
  86             sub { $wrapper->coercion_export_generator($type_short, $type_full, $undef_msg) };
  87         $ex_util{ $type_short }{to}++;  # shortcut to remember this exists
  88     }
  89
  90     # create S:E exporter and increase export level unless specified explicitly
  91     my $exporter = build_exporter \%ex_spec;
  92     $options->{into_level}++
  93         unless $options->{into};
  94
  95     # remember requested symbols to determine what helpers to auto-export
  96     my %was_requested =
  97         map  { ($_ => 1) }
  98         grep { not ref }
  99         @args;
 100
 101     # determine which additional symbols (helpers) to export along
 102     my %add;
 103   EXPORT:
 104     for my $type (grep { exists $was_requested{ $_ } } @types) {
 105         $add{ "is_$type" }++
 106             unless $was_requested{ "is_$type" };
 107         next EXPORT
 108             unless exists $ex_util{ $type }{to};
 109         $add{ "to_$type" }++
 110             unless $was_requested{ "to_$type" };
 111     }
 112
 113     # and on to the real exporter
 114     my @new_args = (@args, keys %add);
 115     return $class->$exporter(@new_args);
 116 }
 117
 118 =head2 get_type
 119
 120 This returns a type from the library's store by its name.
 121
 122 =cut
 123
 124 sub get_type {
 125     my ($class, $type) = @_;
 126
 127     # useful message if the type couldn't be found
 128     croak "Unknown type '$type' in library '$class'"
 129         unless $class->has_type($type);
 130
 131     # return real name of the type
 132     return $class->type_storage->{ $type };
 133 }
 134
 135 =head2 type_names
 136
 137 Returns a list of all known types by their name.
 138
 139 =cut
 140
 141 sub type_names {
 142     my ($class) = @_;
 143
 144     # return short names of all stored types
 145     return keys %{ $class->type_storage };
 146 }
 147
 148 =head2 add_type
 149
 150 Adds a new type to the library.
 151
 152 =cut
 153
 154 sub add_type {
 155     my ($class, $type) = @_;
 156
 157     # store type with library prefix as real name
 158     $class->type_storage->{ $type } = "${class}::${type}";
 159 }
 160
 161 =head2 has_type
 162
 163 Returns true or false depending on if this library knows a type by that
 164 name.
 165
 166 =cut
 167
 168 sub has_type {
 169     my ($class, $type) = @_;
 170
 171     # check if we stored a type under that name
 172     return ! ! $class->type_storage->{ $type };
 173 }
 174
 175 =head2 type_storage
 176
 177 Returns the library's type storage hash reference. You shouldn't use this
 178 method directly unless you know what you are doing. It is not an internal
 179 method because overriding it makes virtual libraries very easy.
 180
 181 =cut
 182
 183 sub type_storage {
 184     my ($class) = @_;
 185
 186     # return a reference to the storage in ourself
 187     {   no strict 'refs';
 188         return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' };
 189     }
 190 }
 191
 192 =head2 registered_class_types
 193
 194 Returns the class types registered within this library. Don't use directly.
 195
 196 =cut
 197
 198 sub registered_class_types {
 199     my ($class) = @_;
 200
 201     {
 202         no strict 'refs';
 203         return \%{ $class . '::__MOOSEX_TYPELIBRARY_CLASS_TYPES' };
 204     }
 205 }
 206
 207 =head2 register_class_type
 208
 209 Register a C<class_type> for use in this library by class name.
 210
 211 =cut
 212
 213 sub register_class_type {
 214     my ($class, $type) = @_;
 215
 216     croak "Not a class_type"
 217         unless $type->isa('Moose::Meta::TypeConstraint::Class');
 218
 219     $class->registered_class_types->{$type->class} = $type;
 220 }
 221
 222 =head2 get_registered_class_type
 223
 224 Get a C<class_type> registered in this library by name.
 225
 226 =cut
 227
 228 sub get_registered_class_type {
 229     my ($class, $name) = @_;
 230
 231     $class->registered_class_types->{$name};
 232 }
 233
 234 =head2 registered_role_types
 235
 236 Returns the role types registered within this library. Don't use directly.
 237
 238 =cut
 239
 240 sub registered_role_types {
 241     my ($class) = @_;
 242
 243     {
 244         no strict 'refs';
 245         return \%{ $class . '::__MOOSEX_TYPELIBRARY_ROLE_TYPES' };
 246     }
 247 }
 248
 249 =head2 register_role_type
 250
 251 Register a C<role_type> for use in this library by role name.
 252
 253 =cut
 254
 255 sub register_role_type {
 256     my ($class, $type) = @_;
 257
 258     croak "Not a role_type"
 259         unless $type->isa('Moose::Meta::TypeConstraint::Role');
 260
 261     $class->registered_role_types->{$type->role} = $type;
 262 }
 263
 264 =head2 get_registered_role_type
 265
 266 Get a C<role_type> registered in this library by role name.
 267
 268 =cut
 269
 270 sub get_registered_role_type {
 271     my ($class, $name) = @_;
 272
 273     $class->registered_role_types->{$name};
 274 }
 275
 276 =head1 SEE ALSO
 277
 278 L<MooseX::Types::Moose>
 279
 280 =head1 AUTHOR
 281
 282 See L<MooseX::Types/AUTHOR>.
 283
 284 =head1 LICENSE
 285
 286 This program is free software; you can redistribute it and/or modify
 287 it under the same terms as perl itself.
 288
 289 =cut
 290
 291 1;