local-lib5/lib/perl5/MooseX/Types/Base.pm

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