Commit | Line | Data |
5439cf97 |
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 |