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