Commit | Line | Data |
471c4f09 |
1 | |
2 | =pod |
3 | |
4 | =head1 NAME |
5 | |
6 | Moose::Cookbook::Recipe4 |
7 | |
8 | =head1 SYNOPSIS |
9 | |
10 | package Address; |
11 | use strict; |
12 | use warnings; |
13 | use Moose; |
14 | |
15 | use Locale::US; |
16 | use Regexp::Common 'zip'; |
17 | |
18 | my $STATES = Locale::US->new; |
19 | |
20 | subtype USState |
21 | => as Str |
22 | => where { |
172e0738 |
23 | (exists $STATES->{code2state}{uc($_)} || |
24 | exists $STATES->{state2code}{uc($_)}) |
471c4f09 |
25 | }; |
26 | |
27 | subtype USZipCode |
28 | => as Value |
29 | => where { |
30 | /^$RE{zip}{US}{-extended => 'allow'}$/ |
31 | }; |
32 | |
33 | has 'street' => (is => 'rw', isa => 'Str'); |
34 | has 'city' => (is => 'rw', isa => 'Str'); |
35 | has 'state' => (is => 'rw', isa => 'USState'); |
36 | has 'zip_code' => (is => 'rw', isa => 'USZipCode'); |
37 | |
38 | package Company; |
39 | use strict; |
40 | use warnings; |
41 | use Moose; |
42 | |
7c6cacb4 |
43 | has 'name' => (is => 'rw', isa => 'Str', required => 1); |
471c4f09 |
44 | has 'address' => (is => 'rw', isa => 'Address'); |
45 | has 'employees' => (is => 'rw', isa => subtype ArrayRef => where { |
46 | ($_->isa('Employee') || return) for @$_; 1 |
47 | }); |
48 | |
49 | sub BUILD { |
50 | my ($self, $params) = @_; |
51 | if ($params->{employees}) { |
52 | foreach my $employee (@{$params->{employees}}) { |
53 | $employee->company($self); |
54 | } |
55 | } |
56 | } |
57 | |
58 | sub get_employee_count { scalar @{(shift)->employees} } |
59 | |
60 | package Person; |
61 | use strict; |
62 | use warnings; |
63 | use Moose; |
64 | |
7c6cacb4 |
65 | has 'first_name' => (is => 'rw', isa => 'Str', required => 1); |
66 | has 'last_name' => (is => 'rw', isa => 'Str', required => 1); |
172e0738 |
67 | has 'middle_initial' => (is => 'rw', isa => 'Str', |
68 | predicate => 'has_middle_initial'); |
471c4f09 |
69 | has 'address' => (is => 'rw', isa => 'Address'); |
70 | |
71 | sub full_name { |
72 | my $self = shift; |
73 | return $self->first_name . |
172e0738 |
74 | ($self->has_middle_initial ? |
75 | ' ' . $self->middle_initial . '. ' |
76 | : |
77 | ' ') . |
471c4f09 |
78 | $self->last_name; |
79 | } |
80 | |
81 | package Employee; |
82 | use strict; |
83 | use warnings; |
84 | use Moose; |
85 | |
86 | extends 'Person'; |
87 | |
7c6cacb4 |
88 | has 'title' => (is => 'rw', isa => 'Str', required => 1); |
471c4f09 |
89 | has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1); |
90 | |
91 | override 'full_name' => sub { |
92 | my $self = shift; |
93 | super() . ', ' . $self->title |
94 | }; |
7c6cacb4 |
95 | |
471c4f09 |
96 | =head1 DESCRIPTION |
97 | |
172e0738 |
98 | In this recipe we introduce the C<subtype> keyword, and show |
99 | how that can be useful for specifying specific type constraints |
100 | without having to build an entire class to represent them. We |
101 | will also show how this feature can be used to leverage the |
102 | usefulness of CPAN modules. In addition to this, we will also |
103 | introduce another attribute option as well. |
104 | |
105 | Lets first get into the C<subtype> features. In the B<Address> |
106 | class we have defined two subtypes. The first C<subtype> uses |
107 | the L<Locale::US> module, which provides two hashes which can be |
108 | used to do existence checks for state names and their two letter |
109 | state codes. It is a very simple, and very useful module, and |
110 | perfect to use in a C<subtype> constraint. |
111 | |
112 | my $STATES = Locale::US->new; |
113 | subtype USState |
114 | => as Str |
115 | => where { |
116 | (exists $STATES->{code2state}{uc($_)} || |
117 | exists $STATES->{state2code}{uc($_)}) |
118 | }; |
119 | |
120 | Because we know that states will be passed to us as strings, we |
121 | can make C<USState> a subtype of the built-in type constraint |
122 | C<Str>. This will assure that anything which is a C<USState> will |
123 | also pass as a C<Str>. Next, we create a constraint specializer |
124 | using the C<where> keyword. The value being checked against in |
125 | the C<where> clause can be found in the C<$_> variable (1). Our |
126 | constraint specializer will then look to see if the string given |
127 | is either a state name or a state code. If the string meets this |
128 | criteria, then the constraint will pass, otherwise it will fail. |
129 | We can now use this as we would any built-in constraint, like so: |
130 | |
131 | has 'state' => (is => 'rw', isa => 'USState'); |
132 | |
133 | The C<state> accessor will now check all values against the |
134 | C<USState> constraint, thereby only allowing valid state names or |
135 | state codes to be stored in the C<state> slot. |
136 | |
137 | The next C<subtype>, does pretty much the same thing using the |
138 | L<Regexp::Common> module, and constrainting the C<zip_code> slot. |
139 | |
140 | subtype USZipCode |
141 | => as Value |
142 | => where { |
143 | /^$RE{zip}{US}{-extended => 'allow'}$/ |
144 | }; |
145 | |
146 | Using subtypes can save a lot of un-needed abstraction by not |
147 | requiring you to create many small classes for these relatively |
148 | simple values. It also allows you to define these constraints |
149 | and share them among many different classes (avoiding unneeded |
150 | duplication) because type constraints are stored by string in a |
151 | global registry and always accessible to C<has>. |
152 | |
153 | With these two subtypes and some attributes, we pretty much define |
154 | as much as we need for a basic B<Address> class. Next we define |
155 | a basic B<Company> class, which itself has an address. As we saw in |
156 | earlier recipes, we can use the C<Address> type constraint that |
157 | Moose automatically created for us. |
158 | |
159 | has 'address' => (is => 'rw', isa => 'Address'); |
160 | |
161 | A company also needs a name, so we define that too. |
162 | |
163 | has 'name' => (is => 'rw', isa => 'Str', required => 1); |
164 | |
165 | Here we introduce another attribute option, the C<required> option. |
166 | This option tells Moose that C<name> is a required parameter in |
167 | the B<Company> constructor, and that the C<name> accessor cannot |
168 | accept an undefined value for the slot. The result is that C<name> |
169 | should always have a value. |
170 | |
171 | =head1 FOOTNOTES |
172 | |
173 | =over 4 |
174 | |
175 | =item (1) |
176 | |
177 | The value being checked is also passed as the first argument to |
178 | the C<where> block as well, so it can also be accessed as C<$_[0]> |
179 | as well. |
180 | |
181 | =back |
182 | |
471c4f09 |
183 | =head1 AUTHOR |
184 | |
185 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
186 | |
187 | =head1 COPYRIGHT AND LICENSE |
188 | |
189 | Copyright 2006 by Infinity Interactive, Inc. |
190 | |
191 | L<http://www.iinteractive.com> |
192 | |
193 | This library is free software; you can redistribute it and/or modify |
194 | it under the same terms as Perl itself. |
195 | |
196 | =cut |