lib/MooseX/TypeLibrary/Base.pm

   1 package MooseX::TypeLibrary::Base;
   2 use warnings;
   3 use strict;
   4
   5 #use Smart::Comments;
   6 use Sub::Install    qw( install_sub );
   7 use Carp            qw( croak );
   8 use Moose::Util::TypeConstraints;
   9 use namespace::clean;
  10
  11 my $UndefMsg = q{Unable to find type '%s' in library '%s'};
  12
  13 sub import {
  14     my ($class, @types) = @_;
  15
  16     # flatten out tags
  17     @types = map { $_ eq ':all' ? $class->type_names : $_ } @types;
  18
  19   TYPE:
  20     # export all requested types
  21     for my $type (@types) {
  22         $class->export_type_into(
  23             scalar(caller), $type, sprintf $UndefMsg, $type, $class );
  24     }
  25     return 1;
  26 }
  27
  28 sub export_type_into {
  29     my ($class, $target, $type, $undef_msg, %args) = @_;
  30
  31     # the real type name and its type object
  32     my $full = $class->get_type($type);
  33     my $tobj = find_type_constraint($full);
  34     ### Exporting: $full
  35
  36     # install Type name constant
  37     install_sub({
  38         code => MooseX::TypeLibrary->type_export_generator($type, $full),
  39         into => $target,
  40         as   => $type,
  41     });
  42
  43     # install is_Type test function
  44     install_sub({
  45         code => MooseX::TypeLibrary
  46                     ->check_export_generator($type, $full, $undef_msg),
  47         into => $target,
  48         as   => "is_$type",
  49     });
  50
  51     # only install to_Type coercion handler if type can coerce
  52     return 1 unless $args{ -full } or $tobj->has_coercion;
  53
  54     # install to_Type coercion handler
  55     install_sub({
  56         code => MooseX::TypeLibrary
  57                     ->coercion_export_generator($type, $full, $undef_msg),
  58         into => $target,
  59         as   => "to_$type",
  60     });
  61
  62     return 1;
  63 }
  64
  65 sub get_type {
  66     my ($class, $type) = @_;
  67
  68     # useful message if the type couldn't be found
  69     croak "Unknown type '$type' in library '$class'"
  70         unless $class->has_type($type);
  71
  72     # return real name of the type
  73     return $class->type_storage->{ $type };
  74 }
  75
  76 sub type_names {
  77     my ($class) = @_;
  78
  79     # return short names of all stored types
  80     return keys %{ $class->type_storage };
  81 }
  82
  83 sub add_type {
  84     my ($class, $type) = @_;
  85
  86     # store type with library prefix as real name
  87     $class->type_storage->{ $type } = "${class}::${type}";
  88 }
  89
  90 sub has_type {
  91     my ($class, $type) = @_;
  92
  93     # check if we stored a type under that name
  94     return ! ! $class->type_storage->{ $type };
  95 }
  96
  97 sub type_storage {
  98     my ($class) = @_;
  99
 100     # return a reference to the storage in ourself
 101     {   no strict 'refs';
 102         return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' };
 103     }
 104 }
 105
 106 1;