Commit | Line | Data |
5439cf97 |
1 | package MouseX::Types; |
2 | use strict; |
3 | use warnings; |
4 | |
5 | require Mouse::TypeRegistry; |
6da1e936 |
6 | use MouseX::Types::TypeDecorator; |
5439cf97 |
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'} }) { |
6da1e936 |
20 | my $obj = $storage->{$name} = "$caller\::$name"; |
21 | *{"$caller\::$name"} = sub () { $obj }; |
5439cf97 |
22 | } |
23 | } |
24 | |
25 | return Mouse::TypeRegistry->import( callee => $caller ); |
26 | } |
27 | |
28 | sub _import { |
29 | my($type_class, $pkg, @types) = @_; |
30 | no strict 'refs'; |
31 | for my $name (@types) { |
6da1e936 |
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 }; |
5439cf97 |
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 | |
1d6d25f1 |
51 | MouseX::Types - Organise your Mouse types in libraries |
5439cf97 |
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 |
5439cf97 |
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 | |
5439cf97 |
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 |