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 { $wrapper->type_export_generator($type_short, $type_full) };
  71
  72         # the check helper
  73         push @{ $ex_spec{exports} },
  74             "is_${type_short}",
  75             sub { $wrapper->check_export_generator($type_short, $type_full, $undef_msg) };
  76
  77         # only export coercion helper if full (for libraries) or coercion is defined
  78         next TYPE
  79             unless $options->{ -full }
  80             or ($type_cons and $type_cons->has_coercion);
  81         push @{ $ex_spec{exports} },
  82             "to_${type_short}",
  83             sub { $wrapper->coercion_export_generator($type_short, $type_full, $undef_msg) };
  84         $ex_util{ $type_short }{to}++;  # shortcut to remember this exists
  85     }
  86
  87     # create S:E exporter and increase export level unless specified explicitly
  88     my $exporter = build_exporter \%ex_spec;
  89     $options->{into_level}++
  90         unless $options->{into};
  91
  92     # remember requested symbols to determine what helpers to auto-export
  93     my %was_requested =
  94         map  { ($_ => 1) }
  95         grep { not ref }
  96         @args;
  97
  98     # determine which additional symbols (helpers) to export along
  99     my %add;
 100   EXPORT:
 101     for my $type (grep { exists $was_requested{ $_ } } @types) {
 102         $add{ "is_$type" }++
 103             unless $was_requested{ "is_$type" };
 104         next EXPORT
 105             unless exists $ex_util{ $type }{to};
 106         $add{ "to_$type" }++
 107             unless $was_requested{ "to_$type" };
 108     }
 109
 110     # and on to the real exporter
 111     my @new_args = (@args, keys %add);
 112     return $class->$exporter(@new_args);
 113 }
 114
 115 =head2 get_type
 116
 117 This returns a type from the library's store by its name.
 118
 119 =cut
 120
 121 sub get_type {
 122     my ($class, $type) = @_;
 123
 124     # useful message if the type couldn't be found
 125     croak "Unknown type '$type' in library '$class'"
 126         unless $class->has_type($type);
 127
 128     # return real name of the type
 129     return $class->type_storage->{ $type };
 130 }
 131
 132 =head2 type_names
 133
 134 Returns a list of all known types by their name.
 135
 136 =cut
 137
 138 sub type_names {
 139     my ($class) = @_;
 140
 141     # return short names of all stored types
 142     return keys %{ $class->type_storage };
 143 }
 144
 145 =head2 add_type
 146
 147 Adds a new type to the library.
 148
 149 =cut
 150
 151 sub add_type {
 152     my ($class, $type) = @_;
 153
 154     # store type with library prefix as real name
 155     $class->type_storage->{ $type } = "${class}::${type}";
 156 }
 157
 158 =head2 has_type
 159
 160 Returns true or false depending on if this library knows a type by that
 161 name.
 162
 163 =cut
 164
 165 sub has_type {
 166     my ($class, $type) = @_;
 167
 168     # check if we stored a type under that name
 169     return ! ! $class->type_storage->{ $type };
 170 }
 171
 172 =head2 type_storage
 173
 174 Returns the library's type storage hash reference. You shouldn't use this
 175 method directly unless you know what you are doing. It is not an internal
 176 method because overriding it makes virtual libraries very easy.
 177
 178 =cut
 179
 180 sub type_storage {
 181     my ($class) = @_;
 182
 183     # return a reference to the storage in ourself
 184     {   no strict 'refs';
 185         return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' };
 186     }
 187 }
 188
 189 =head1 SEE ALSO
 190
 191 L<MooseX::Types::Moose>
 192
 193 =head1 AUTHOR AND COPYRIGHT
 194
 195 Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
 196 the C<#moose> cabal on C<irc.perl.org>.
 197
 198 =head1 LICENSE
 199
 200 This program is free software; you can redistribute it and/or modify
 201 it under the same terms as perl itself.
 202
 203 =cut
 204
 205 1;