lib/MooseX/Types/Base.pm

   1 package MooseX::Types::Base;
   2
   3 =head1 NAME
   4
   5 MooseX::Types::Base - Type library base class
   6
   7 =cut
   8
   9 #use warnings;
  10 #use strict;
  11
  12 use Sub::Install                    qw( install_sub );
  13 use Carp                            qw( croak );
  14 use MooseX::Types::Util             qw( filter_tags );
  15 use Moose::Util::TypeConstraints;
  16 use Moose;
  17
  18 use namespace::clean -except => [qw( meta )];
  19
  20 =head1 DESCRIPTION
  21
  22 You normally won't need to interact with this class by yourself. It is
  23 merely a collection of functionality that type libraries need to
  24 interact with moose and the rest of the L<MooseX::Types> module.
  25
  26 =cut
  27
  28 my $UndefMsg = q{Unable to find type '%s' in library '%s'};
  29
  30 =head1 METHODS
  31
  32 =cut
  33
  34 =head2 import
  35
  36 Provides the import mechanism for your library. See
  37 L<MooseX::Types/"LIBRARY USAGE"> for syntax details on this.
  38
  39 =cut
  40
  41 sub import {
  42     my ($class, @args) = @_;
  43
  44     # separate tags from types and possible options
  45     my ($options) = grep { ref $_ eq 'HASH' } @args;
  46     my ($tags, $types)
  47       = filter_tags
  48         grep { ref $_ ne 'HASH' }
  49         @args;
  50     my $callee = ($options && $options->{ -into } || scalar(caller));
  51
  52     # :all replaces types with full list
  53     @$types = $class->type_names if $tags->{all};
  54
  55   TYPE:
  56     # export all requested types
  57     for my $type (@$types) {
  58         $class->export_type_into(
  59             $callee,
  60             $type,
  61             sprintf($UndefMsg, $type, $class),
  62             ($options ? %$options : ()),
  63         );
  64     }
  65     return 1;
  66 }
  67
  68 =head2 export_type_into
  69
  70 Exports one specific type into a target package.
  71
  72 =cut
  73
  74 sub export_type_into {
  75     my ($class, $target, $type, $undef_msg, %args) = @_;
  76
  77     # the real type name and its type object
  78     my $full = $class->get_type($type);
  79     my $tobj = find_type_constraint($full);
  80
  81     # a possible wrapper around library functionality
  82     my $wrap = $args{ -wrapper } || 'MooseX::Types';
  83
  84     # install Type name constant
  85     install_sub({
  86         code => $wrap->type_export_generator($type, $full),
  87         into => $target,
  88         as   => $type,
  89     });
  90
  91     # install is_Type test function
  92     install_sub({
  93         code => $wrap->check_export_generator($type, $full, $undef_msg),
  94         into => $target,
  95         as   => "is_$type",
  96     });
  97
  98     # only install to_Type coercion handler if type can coerce
  99     # or if we want to provide them anyway, e.g. declarations
 100     if ($args{ -full } or $tobj->has_coercion) {
 101
 102         # install to_Type coercion handler
 103         install_sub({
 104             code => $wrap->coercion_export_generator($type, $full, $undef_msg),
 105             into => $target,
 106             as   => "to_$type",
 107         });
 108     }
 109
 110     return 1;
 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 =head1 SEE ALSO
 188
 189 L<MooseX::Types::Moose>
 190
 191 =head1 AUTHOR AND COPYRIGHT
 192
 193 Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
 194 the C<#moose> cabal on C<irc.perl.org>.
 195
 196 =head1 LICENSE
 197
 198 This program is free software; you can redistribute it and/or modify
 199 it under the same terms as perl itself.
 200
 201 =cut
 202
 203 1;