lib/MouseX/Types.pm

   1 package MouseX::Types;
   2 use strict;
   3 use warnings;
   4
   5 require Mouse::Util::TypeConstraints;
   6 use MouseX::Types::TypeDecorator;
   7
   8 sub import {
   9     my $class  = shift;
  10     my %args   = @_;
  11     my $caller = caller(0);
  12
  13     no strict 'refs';
  14     *{"$caller\::import"} = sub { my $pkg = caller(0); _import($caller, $pkg, @_) };
  15     push @{"$caller\::ISA"}, 'MouseX::Types::Base';
  16
  17     if (defined $args{'-declare'} && ref($args{'-declare'}) eq 'ARRAY') {
  18         my $storage = $caller->type_storage($caller);
  19         for my $name (@{ $args{'-declare'} }) {
  20             my $obj = $storage->{$name} = "$caller\::$name";
  21             *{"$caller\::$name"} = sub () { $obj };
  22         }
  23     }
  24
  25     return Mouse::Util::TypeConstraints->import( callee => $caller );
  26 }
  27
  28 sub _import {
  29     my($type_class, $pkg, @types) = @_;
  30     no strict 'refs';
  31     for my $name (@types) {
  32         my $obj = $type_class->type_storage->{$name};
  33         $obj = $type_class->type_storage->{$name} = MouseX::Types::TypeDecorator->new($obj)
  34             unless ref($obj);
  35         *{"$pkg\::$name"} = sub () { $obj };
  36     }
  37 }
  38
  39 {
  40     package MouseX::Types::Base;
  41     my %storage;
  42     sub type_storage {
  43         $storage{$_[0]} ||= +{}
  44     }
  45 }
  46
  47 1;
  48
  49 =head1 NAME
  50
  51 MouseX::Types - Organise your Mouse types in libraries
  52
  53 =head1 SYNOPSIS
  54
  55 =head2 Library Definition
  56
  57   package MyLibrary;
  58
  59   # predeclare our own types
  60   use MouseX::Types
  61     -declare => [qw(
  62         PositiveInt NegativeInt
  63     )];
  64
  65   # import builtin types
  66   use MouseX::Types::Mouse 'Int';
  67
  68   # type definition.
  69   subtype PositiveInt,
  70       as Int,
  71       where { $_ > 0 },
  72       message { "Int is not larger than 0" };
  73
  74   subtype NegativeInt,
  75       as Int,
  76       where { $_ < 0 },
  77       message { "Int is not smaller than 0" };
  78
  79   # type coercion
  80   coerce PositiveInt,
  81       from Int,
  82           via { 1 };
  83
  84   1;
  85
  86 =head2 Usage
  87
  88   package Foo;
  89   use Mouse;
  90   use MyLibrary qw( PositiveInt NegativeInt );
  91
  92   # use the exported constants as type names
  93   has 'bar',
  94       isa    => PositiveInt,
  95       is     => 'rw';
  96   has 'baz',
  97       isa    => NegativeInt,
  98       is     => 'rw';
  99
 100   sub quux {
 101       my ($self, $value);
 102
 103       # test the value
 104       print "positive\n" if is_PositiveInt($value);
 105       print "negative\n" if is_NegativeInt($value);
 106
 107       # coerce the value, NegativeInt doesn't have a coercion
 108       # helper, since it didn't define any coercions.
 109       $value = to_PositiveInt($value) or die "Cannot coerce";
 110   }
 111
 112   1;
 113
 114 =cut