lib/MooseX/TypeLibrary/Base.pm

   1 package MooseX::TypeLibrary::Base;
   2
   3 =head1 NAME
   4
   5 MooseX::TypeLibrary::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::TypeLibrary::Util       qw( filter_tags );
  15 use Moose::Util::TypeConstraints;
  16 use namespace::clean;
  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::TypeLibrary> 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::TypeLibrary/"LIBRARY USAGE"> for syntax details on this.
  36
  37 =cut
  38
  39 sub import {
  40     my ($class, @orig_types) = @_;
  41
  42     # separate tags from types
  43     my ($tags, $types) = filter_tags @orig_types;
  44
  45     # :all replaces types with full list
  46     @$types = $class->type_names if $tags->{all};
  47
  48   TYPE:
  49     # export all requested types
  50     for my $type (@$types) {
  51         $class->export_type_into(
  52             scalar(caller),
  53             $type,
  54             sprintf($UndefMsg, $type, $class),
  55         );
  56     }
  57     return 1;
  58 }
  59
  60 =head2 export_type_into
  61
  62 Exports one specific type into a target package.
  63
  64 =cut
  65
  66 sub export_type_into {
  67     my ($class, $target, $type, $undef_msg, %args) = @_;
  68
  69     # the real type name and its type object
  70     my $full = $class->get_type($type);
  71     my $tobj = find_type_constraint($full);
  72     ### Exporting: $full
  73
  74     # install Type name constant
  75     install_sub({
  76         code => MooseX::TypeLibrary->type_export_generator($type, $full),
  77         into => $target,
  78         as   => $type,
  79     });
  80
  81     # install is_Type test function
  82     install_sub({
  83         code => MooseX::TypeLibrary
  84                     ->check_export_generator($type, $full, $undef_msg),
  85         into => $target,
  86         as   => "is_$type",
  87     });
  88
  89     # only install to_Type coercion handler if type can coerce
  90     # or if we want to provide them anyway, e.g. declarations
  91     if ($args{ -full } or $tobj->has_coercion) {
  92
  93         # install to_Type coercion handler
  94         install_sub({
  95             code => MooseX::TypeLibrary->coercion_export_generator(
  96                         $type, $full, $undef_msg ),
  97             into => $target,
  98             as   => "to_$type",
  99         });
 100     }
 101
 102     return 1;
 103 }
 104
 105 =head2 get_type
 106
 107 This returns a type from the library's store by its name.
 108
 109 =cut
 110
 111 sub get_type {
 112     my ($class, $type) = @_;
 113
 114     # useful message if the type couldn't be found
 115     croak "Unknown type '$type' in library '$class'"
 116         unless $class->has_type($type);
 117
 118     # return real name of the type
 119     return $class->type_storage->{ $type };
 120 }
 121
 122 =head2 type_names
 123
 124 Returns a list of all known types by their name.
 125
 126 =cut
 127
 128 sub type_names {
 129     my ($class) = @_;
 130
 131     # return short names of all stored types
 132     return keys %{ $class->type_storage };
 133 }
 134
 135 =head2 add_type
 136
 137 Adds a new type to the library.
 138
 139 =cut
 140
 141 sub add_type {
 142     my ($class, $type) = @_;
 143
 144     # store type with library prefix as real name
 145     $class->type_storage->{ $type } = "${class}::${type}";
 146 }
 147
 148 =head2 has_type
 149
 150 Returns true or false depending on if this library knows a type by that
 151 name.
 152
 153 =cut
 154
 155 sub has_type {
 156     my ($class, $type) = @_;
 157
 158     # check if we stored a type under that name
 159     return ! ! $class->type_storage->{ $type };
 160 }
 161
 162 =head2 type_storage
 163
 164 Returns the library's type storage hash reference. You shouldn't use this
 165 method directly unless you know what you are doing. It is not an internal
 166 method because overriding it makes virtual libraries very easy.
 167
 168 =cut
 169
 170 sub type_storage {
 171     my ($class) = @_;
 172
 173     # return a reference to the storage in ourself
 174     {   no strict 'refs';
 175         return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' };
 176     }
 177 }
 178
 179 =head1 SEE ALSO
 180
 181 L<MooseX::TypeLibrary::Moose>
 182
 183 =head1 AUTHOR AND COPYRIGHT
 184
 185 Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
 186 the C<#moose> cabal on C<irc.perl.org>.
 187
 188 =head1 LICENSE
 189
 190 This program is free software; you can redistribute it and/or modify
 191 it under the same terms as perl itself.
 192
 193 =cut
 194
 195 1;