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 |
5439cf97 |
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 | |
5439cf97 |
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 |