lib/MooseX/Types/Base.pm

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