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