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         ArrayRefOfPositiveInt ArrayRefOfAtLeastThreeNegativeInts
  60         LotsOfInnerConstraints StrOrArrayRef
  61     )];
  62
  63   # import builtin types
  64   use MouseX::Types::Mouse 'Int';
  65
  66   # type definition.
  67   subtype PositiveInt,
  68       as Int,
  69       where { $_ > 0 },
  70       message { "Int is not larger than 0" };
  71
  72   subtype NegativeInt,
  73       as Int,
  74       where { $_ < 0 },
  75       message { "Int is not smaller than 0" };
  76
  77   # type coercion
  78   coerce PositiveInt,
  79       from Int,
  80           via { 1 };
  81
  82   # with parameterized constraints.
  83
  84   subtype ArrayRefOfPositiveInt,
  85     as ArrayRef[PositiveInt];
  86
  87   subtype ArrayRefOfAtLeastThreeNegativeInts,
  88     as ArrayRef[NegativeInt],
  89     where { scalar(@$_) > 2 };
  90
  91   subtype LotsOfInnerConstraints,
  92     as ArrayRef[ArrayRef[HashRef[Int]]];
  93
  94   # with TypeConstraint Unions
  95
  96   subtype StrOrArrayRef,
  97     as Str|ArrayRef;
  98
  99   1;
 100
 101 =head2 Usage
 102
 103   package Foo;
 104   use Mouse;
 105   use MyLibrary qw( PositiveInt NegativeInt );
 106
 107   # use the exported constants as type names
 108   has 'bar',
 109       isa    => PositiveInt,
 110       is     => 'rw';
 111   has 'baz',
 112       isa    => NegativeInt,
 113       is     => 'rw';
 114
 115   sub quux {
 116       my ($self, $value);
 117
 118       # test the value
 119       print "positive\n" if is_PositiveInt($value);
 120       print "negative\n" if is_NegativeInt($value);
 121
 122       # coerce the value, NegativeInt doesn't have a coercion
 123       # helper, since it didn't define any coercions.
 124       $value = to_PositiveInt($value) or die "Cannot coerce";
 125   }
 126
 127   1;
 128
 129 =cut