lib/MouseX/Types.pm

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