lib/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 Data::Dump                      qw( dump );
  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 =head1 SEE ALSO
 193
 194 L<MooseX::Types::Moose>
 195
 196 =head1 AUTHOR AND COPYRIGHT
 197
 198 Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
 199 the C<#moose> cabal on C<irc.perl.org>.
 200
 201 =head1 LICENSE
 202
 203 This program is free software; you can redistribute it and/or modify
 204 it under the same terms as perl itself.
 205
 206 =cut
 207
 208 1;