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::Clan                      qw( ^MooseX::Types );
  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         or croak "No fully qualified type name stored for '$type'";
  80     my $tobj = find_type_constraint($full);
  81
  82     # a possible wrapper around library functionality
  83     my $wrap = $args{ -wrapper } || 'MooseX::Types';
  84
  85     # install Type name constant
  86     install_sub({
  87         code => $wrap->type_export_generator($type, $full),
  88         into => $target,
  89         as   => $type,
  90     });
  91
  92     # install is_Type test function
  93     install_sub({
  94         code => $wrap->check_export_generator($type, $full, $undef_msg),
  95         into => $target,
  96         as   => "is_$type",
  97     });
  98
  99     # only install to_Type coercion handler if type can coerce
 100     # or if we want to provide them anyway, e.g. declarations
 101     if ($args{ -full } or $tobj and $tobj->has_coercion) {
 102
 103         # install to_Type coercion handler
 104         install_sub({
 105             code => $wrap->coercion_export_generator($type, $full, $undef_msg),
 106             into => $target,
 107             as   => "to_$type",
 108         });
 109     }
 110
 111     return 1;
 112 }
 113
 114 =head2 get_type
 115
 116 This returns a type from the library's store by its name.
 117
 118 =cut
 119
 120 sub get_type {
 121     my ($class, $type) = @_;
 122
 123     # useful message if the type couldn't be found
 124     croak "Unknown type '$type' in library '$class'"
 125         unless $class->has_type($type);
 126
 127     # return real name of the type
 128     return $class->type_storage->{ $type };
 129 }
 130
 131 =head2 type_names
 132
 133 Returns a list of all known types by their name.
 134
 135 =cut
 136
 137 sub type_names {
 138     my ($class) = @_;
 139
 140     # return short names of all stored types
 141     return keys %{ $class->type_storage };
 142 }
 143
 144 =head2 add_type
 145
 146 Adds a new type to the library.
 147
 148 =cut
 149
 150 sub add_type {
 151     my ($class, $type) = @_;
 152
 153     # store type with library prefix as real name
 154     $class->type_storage->{ $type } = "${class}::${type}";
 155 }
 156
 157 =head2 has_type
 158
 159 Returns true or false depending on if this library knows a type by that
 160 name.
 161
 162 =cut
 163
 164 sub has_type {
 165     my ($class, $type) = @_;
 166
 167     # check if we stored a type under that name
 168     return ! ! $class->type_storage->{ $type };
 169 }
 170
 171 =head2 type_storage
 172
 173 Returns the library's type storage hash reference. You shouldn't use this
 174 method directly unless you know what you are doing. It is not an internal
 175 method because overriding it makes virtual libraries very easy.
 176
 177 =cut
 178
 179 sub type_storage {
 180     my ($class) = @_;
 181
 182     # return a reference to the storage in ourself
 183     {   no strict 'refs';
 184         return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' };
 185     }
 186 }
 187
 188 =head1 SEE ALSO
 189
 190 L<MooseX::Types::Moose>
 191
 192 =head1 AUTHOR AND COPYRIGHT
 193
 194 Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
 195 the C<#moose> cabal on C<irc.perl.org>.
 196
 197 =head1 LICENSE
 198
 199 This program is free software; you can redistribute it and/or modify
 200 it under the same terms as perl itself.
 201
 202 =cut
 203
 204 1;