lib/Moose/Cookbook/Basics/Recipe4.pod

   1 package Moose::Cookbook::Basics::Recipe4;
   2
   3 # ABSTRACT: Subtypes, and modeling a simple B<Company> class hierarchy
   4
   5 __END__
   6
   7
   8 =pod
   9
  10 =begin testing-SETUP
  11
  12 use Test::Requires {
  13     'Locale::US'     => '0',
  14     'Regexp::Common' => '0',
  15 };
  16
  17 =end testing-SETUP
  18
  19 =head1 SYNOPSIS
  20
  21   package Address;
  22   use Moose;
  23   use Moose::Util::TypeConstraints;
  24
  25   use Locale::US;
  26   use Regexp::Common 'zip';
  27
  28   my $STATES = Locale::US->new;
  29   subtype 'USState'
  30       => as Str
  31       => where {
  32              (    exists $STATES->{code2state}{ uc($_) }
  33                || exists $STATES->{state2code}{ uc($_) } );
  34          };
  35
  36   subtype 'USZipCode'
  37       => as Value
  38       => where {
  39              /^$RE{zip}{US}{-extended => 'allow'}$/;
  40          };
  41
  42   has 'street'   => ( is => 'rw', isa => 'Str' );
  43   has 'city'     => ( is => 'rw', isa => 'Str' );
  44   has 'state'    => ( is => 'rw', isa => 'USState' );
  45   has 'zip_code' => ( is => 'rw', isa => 'USZipCode' );
  46
  47   package Company;
  48   use Moose;
  49   use Moose::Util::TypeConstraints;
  50
  51   has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
  52   has 'address'   => ( is => 'rw', isa => 'Address' );
  53   has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );
  54
  55   sub BUILD {
  56       my ( $self, $params ) = @_;
  57       foreach my $employee ( @{ $self->employees || [] } ) {
  58           $employee->employer($self);
  59       }
  60   }
  61
  62   after 'employees' => sub {
  63       my ( $self, $employees ) = @_;
  64       foreach my $employee ( @{ $employees || [] } ) {
  65           $employee->employer($self);
  66       }
  67   };
  68
  69   package Person;
  70   use Moose;
  71
  72   has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 );
  73   has 'last_name'  => ( is => 'rw', isa => 'Str', required => 1 );
  74   has 'middle_initial' => (
  75       is        => 'rw', isa => 'Str',
  76       predicate => 'has_middle_initial'
  77   );
  78   has 'address' => ( is => 'rw', isa => 'Address' );
  79
  80   sub full_name {
  81       my $self = shift;
  82       return $self->first_name
  83           . (
  84           $self->has_middle_initial
  85           ? ' ' . $self->middle_initial . '. '
  86           : ' '
  87           ) . $self->last_name;
  88   }
  89
  90   package Employee;
  91   use Moose;
  92
  93   extends 'Person';
  94
  95   has 'title'    => ( is => 'rw', isa => 'Str',     required => 1 );
  96   has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 );
  97
  98   override 'full_name' => sub {
  99       my $self = shift;
 100       super() . ', ' . $self->title;
 101   };
 102
 103 =head1 DESCRIPTION
 104
 105 This recipe introduces the C<subtype> sugar function from
 106 L<Moose::Util::TypeConstraints>. The C<subtype> function lets you
 107 declaratively create type constraints without building an entire
 108 class.
 109
 110 In the recipe we also make use of L<Locale::US> and L<Regexp::Common>
 111 to build constraints, showing how constraints can make use of existing
 112 CPAN tools for data validation.
 113
 114 Finally, we introduce the C<required> attribute option.
 115
 116 In the C<Address> class we define two subtypes. The first uses the
 117 L<Locale::US> module to check the validity of a state. It accepts
 118 either a state abbreviation of full name.
 119
 120 A state will be passed in as a string, so we make our C<USState> type
 121 a subtype of Moose's builtin C<Str> type. This is done using the C<as>
 122 sugar. The actual constraint is defined using C<where>. This function
 123 accepts a single subroutine reference. That subroutine will be called
 124 with the value to be checked in C<$_> (1). It is expected to return a
 125 true or false value indicating whether the value is valid for the
 126 type.
 127
 128 We can now use the C<USState> type just like Moose's builtin types:
 129
 130   has 'state'    => ( is => 'rw', isa => 'USState' );
 131
 132 When the C<state> attribute is set, the value is checked against the
 133 C<USState> constraint. If the value is not valid, an exception will be
 134 thrown.
 135
 136 The next C<subtype>, C<USZipCode>, uses
 137 L<Regexp::Common>. L<Regexp::Common> includes a regex for validating
 138 US zip codes. We use this constraint for the C<zip_code> attribute.
 139
 140   subtype 'USZipCode'
 141       => as Value
 142       => where {
 143              /^$RE{zip}{US}{-extended => 'allow'}$/;
 144          };
 145
 146 Using a subtype instead of requiring a class for each type greatly
 147 simplifies the code. We don't really need a class for these types, as
 148 they're just strings, but we do want to ensure that they're valid.
 149
 150 The type constraints we created are reusable. Type constraints are
 151 stored by name in a global registry, which means that we can refer to
 152 them in other classes. Because the registry is global, we do recommend
 153 that you use some sort of namespacing in real applications,
 154 like C<MyApp::Type::USState> (just as you would do with class names).
 155
 156 These two subtypes allow us to define a simple C<Address> class.
 157
 158 Then we define our C<Company> class, which has an address. As we saw
 159 in earlier recipes, Moose automatically creates a type constraint for
 160 each our classes, so we can use that for the C<Company> class's
 161 C<address> attribute:
 162
 163   has 'address'   => ( is => 'rw', isa => 'Address' );
 164
 165 A company also needs a name:
 166
 167   has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
 168
 169 This introduces a new attribute option, C<required>. If an attribute
 170 is required, then it must be passed to the class's constructor, or an
 171 exception will be thrown. It's important to understand that a
 172 C<required> attribute can still be false or C<undef>, if its type
 173 constraint allows that.
 174
 175 The next attribute, C<employees>, uses a I<parameterized> type
 176 constraint:
 177
 178   has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );
 179
 180 This constraint says that C<employees> must be an array reference
 181 where each element of the array is an C<Employee> object. It's worth
 182 noting that an I<empty> array reference also satisfies this
 183 constraint.
 184
 185 Parameterizable type constraints (or "container types"), such as
 186 C<ArrayRef[`a]>, can be made more specific with a type parameter. In
 187 fact, we can arbitrarily nest these types, producing something like
 188 C<HashRef[ArrayRef[Int]]>. However, you can also just use the type by
 189 itself, so C<ArrayRef> is legal. (2)
 190
 191 If you jump down to the definition of the C<Employee> class, you will
 192 see that it has an C<employer> attribute.
 193
 194 When we set the C<employees> for a C<Company> we want to make sure
 195 that each of these employee objects refers back to the right
 196 C<Company> in its C<employer> attribute.
 197
 198 To do that, we need to hook into object construction. Moose lets us do
 199 this by writing a C<BUILD> method in our class. When your class
 200 defines a C<BUILD> method, it will be called immediately after
 201 object construction, but before the object is returned to the caller
 202 (3). Note that all C<BUILD> methods in your class hierarchy will be
 203 called automatically; there is no need to (and you should not) call
 204 the superclass C<BUILD> method.
 205
 206 The C<Company> class uses the C<BUILD> method to ensure that each
 207 employee of a company has the proper C<Company> object in its
 208 C<employer> attribute:
 209
 210   sub BUILD {
 211       my ( $self, $params ) = @_;
 212       foreach my $employee ( @{ $self->employees || [] } ) {
 213           $employee->employer($self);
 214       }
 215   }
 216
 217 The C<BUILD> method is executed after type constraints are checked, so it is
 218 safe to assume that if C<< $self->employees >> has a value, it will be an
 219 array reference, and that the elements of that array reference will be
 220 C<Employee> objects.
 221
 222 We also want to make sure that whenever the C<employees> attribute for
 223 a C<Company> is changed, we also update the C<employer> for each
 224 employee.
 225
 226 To do this we can use an C<after> modifier:
 227
 228   after 'employees' => sub {
 229       my ( $self, $employees ) = @_;
 230       foreach my $employee ( @{ $employees || [] } ) {
 231           $employee->employer($self);
 232       }
 233   };
 234
 235 Again, as with the C<BUILD> method, we know that the type constraint check has
 236 already happened, so we know that if C<$employees> is defined it will contain
 237 an array reference of C<Employee> objects.
 238
 239 The B<Person> class does not really demonstrate anything new. It has several
 240 C<required> attributes. It also has a C<predicate> method, which we
 241 first used in L<recipe 3|Moose::Cookbook::Basics::Recipe3>.
 242
 243 The only new feature in the C<Employee> class is the C<override>
 244 method modifier:
 245
 246   override 'full_name' => sub {
 247       my $self = shift;
 248       super() . ', ' . $self->title;
 249   };
 250
 251 This is just a sugary alternative to Perl's built in C<SUPER::>
 252 feature. However, there is one difference. You cannot pass any
 253 arguments to C<super>. Instead, Moose simply passes the same
 254 parameters that were passed to the method.
 255
 256 A more detailed example of usage can be found in
 257 F<t/recipes/moose_cookbook_basics_recipe4.t>.
 258
 259 =head1 CONCLUSION
 260
 261 This recipe was intentionally longer and more complex. It illustrates
 262 how Moose classes can be used together with type constraints, as well
 263 as the density of information that you can get out of a small amount
 264 of typing when using Moose.
 265
 266 This recipe also introduced the C<subtype> function, the C<required>
 267 attribute, and the C<override> method modifier.
 268
 269 We will revisit type constraints in future recipes, and cover type
 270 coercion as well.
 271
 272 =head1 FOOTNOTES
 273
 274 =over 4
 275
 276 =item (1)
 277
 278 The value being checked is also passed as the first argument to
 279 the C<where> block, so it can be accessed as C<$_[0]>.
 280
 281 =item (2)
 282
 283 Note that C<ArrayRef[]> will not work. Moose will not parse this as a
 284 container type, and instead you will have a new type named
 285 "ArrayRef[]", which doesn't make any sense.
 286
 287 =item (3)
 288
 289 The C<BUILD> method is actually called by C<< Moose::Object->new >>. It climbs
 290 the object inheritance graph and calls any C<BUILD> methods it finds in the
 291 correct order.
 292
 293 =back
 294
 295 =begin testing
 296
 297 {
 298     package Company;
 299
 300     sub get_employee_count { scalar @{(shift)->employees} }
 301 }
 302
 303 use Scalar::Util 'isweak';
 304
 305 my $ii;
 306 is(
 307     exception {
 308         $ii = Company->new(
 309             {
 310                 name    => 'Infinity Interactive',
 311                 address => Address->new(
 312                     street   => '565 Plandome Rd., Suite 307',
 313                     city     => 'Manhasset',
 314                     state    => 'NY',
 315                     zip_code => '11030'
 316                 ),
 317                 employees => [
 318                     Employee->new(
 319                         first_name => 'Jeremy',
 320                         last_name  => 'Shao',
 321                         title      => 'President / Senior Consultant',
 322                         address    => Address->new(
 323                             city => 'Manhasset', state => 'NY'
 324                         )
 325                     ),
 326                     Employee->new(
 327                         first_name => 'Tommy',
 328                         last_name  => 'Lee',
 329                         title      => 'Vice President / Senior Developer',
 330                         address =>
 331                             Address->new( city => 'New York', state => 'NY' )
 332                     ),
 333                     Employee->new(
 334                         first_name     => 'Stevan',
 335                         middle_initial => 'C',
 336                         last_name      => 'Little',
 337                         title          => 'Senior Developer',
 338                         address =>
 339                             Address->new( city => 'Madison', state => 'CT' )
 340                     ),
 341                 ]
 342             }
 343         );
 344     },
 345     undef,
 346     '... created the entire company successfully'
 347 );
 348
 349 isa_ok( $ii, 'Company' );
 350
 351 is( $ii->name, 'Infinity Interactive',
 352     '... got the right name for the company' );
 353
 354 isa_ok( $ii->address, 'Address' );
 355 is( $ii->address->street, '565 Plandome Rd., Suite 307',
 356     '... got the right street address' );
 357 is( $ii->address->city,     'Manhasset', '... got the right city' );
 358 is( $ii->address->state,    'NY',        '... got the right state' );
 359 is( $ii->address->zip_code, 11030,       '... got the zip code' );
 360
 361 is( $ii->get_employee_count, 3, '... got the right employee count' );
 362
 363 # employee #1
 364
 365 isa_ok( $ii->employees->[0], 'Employee' );
 366 isa_ok( $ii->employees->[0], 'Person' );
 367
 368 is( $ii->employees->[0]->first_name, 'Jeremy',
 369     '... got the right first name' );
 370 is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' );
 371 ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' );
 372 is( $ii->employees->[0]->middle_initial, undef,
 373     '... got the right middle initial value' );
 374 is( $ii->employees->[0]->full_name,
 375     'Jeremy Shao, President / Senior Consultant',
 376     '... got the right full name' );
 377 is( $ii->employees->[0]->title, 'President / Senior Consultant',
 378     '... got the right title' );
 379 is( $ii->employees->[0]->employer, $ii, '... got the right company' );
 380 ok( isweak( $ii->employees->[0]->{employer} ),
 381     '... the company is a weak-ref' );
 382
 383 isa_ok( $ii->employees->[0]->address, 'Address' );
 384 is( $ii->employees->[0]->address->city, 'Manhasset',
 385     '... got the right city' );
 386 is( $ii->employees->[0]->address->state, 'NY', '... got the right state' );
 387
 388 # employee #2
 389
 390 isa_ok( $ii->employees->[1], 'Employee' );
 391 isa_ok( $ii->employees->[1], 'Person' );
 392
 393 is( $ii->employees->[1]->first_name, 'Tommy',
 394     '... got the right first name' );
 395 is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' );
 396 ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' );
 397 is( $ii->employees->[1]->middle_initial, undef,
 398     '... got the right middle initial value' );
 399 is( $ii->employees->[1]->full_name,
 400     'Tommy Lee, Vice President / Senior Developer',
 401     '... got the right full name' );
 402 is( $ii->employees->[1]->title, 'Vice President / Senior Developer',
 403     '... got the right title' );
 404 is( $ii->employees->[1]->employer, $ii, '... got the right company' );
 405 ok( isweak( $ii->employees->[1]->{employer} ),
 406     '... the company is a weak-ref' );
 407
 408 isa_ok( $ii->employees->[1]->address, 'Address' );
 409 is( $ii->employees->[1]->address->city, 'New York',
 410     '... got the right city' );
 411 is( $ii->employees->[1]->address->state, 'NY', '... got the right state' );
 412
 413 # employee #3
 414
 415 isa_ok( $ii->employees->[2], 'Employee' );
 416 isa_ok( $ii->employees->[2], 'Person' );
 417
 418 is( $ii->employees->[2]->first_name, 'Stevan',
 419     '... got the right first name' );
 420 is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' );
 421 ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' );
 422 is( $ii->employees->[2]->middle_initial, 'C',
 423     '... got the right middle initial value' );
 424 is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer',
 425     '... got the right full name' );
 426 is( $ii->employees->[2]->title, 'Senior Developer',
 427     '... got the right title' );
 428 is( $ii->employees->[2]->employer, $ii, '... got the right company' );
 429 ok( isweak( $ii->employees->[2]->{employer} ),
 430     '... the company is a weak-ref' );
 431
 432 isa_ok( $ii->employees->[2]->address, 'Address' );
 433 is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' );
 434 is( $ii->employees->[2]->address->state, 'CT', '... got the right state' );
 435
 436 # create new company
 437
 438 my $new_company
 439     = Company->new( name => 'Infinity Interactive International' );
 440 isa_ok( $new_company, 'Company' );
 441
 442 my $ii_employees = $ii->employees;
 443 foreach my $employee (@$ii_employees) {
 444     is( $employee->employer, $ii, '... has the ii company' );
 445 }
 446
 447 $new_company->employees($ii_employees);
 448
 449 foreach my $employee ( @{ $new_company->employees } ) {
 450     is( $employee->employer, $new_company,
 451         '... has the different company now' );
 452 }
 453
 454 ## check some error conditions for the subtypes
 455
 456 isnt(
 457     exception {
 458         Address->new( street => {} ),;
 459     },
 460     undef,
 461     '... we die correctly with bad args'
 462 );
 463
 464 isnt(
 465     exception {
 466         Address->new( city => {} ),;
 467     },
 468     undef,
 469     '... we die correctly with bad args'
 470 );
 471
 472 isnt(
 473     exception {
 474         Address->new( state => 'British Columbia' ),;
 475     },
 476     undef,
 477     '... we die correctly with bad args'
 478 );
 479
 480 is(
 481     exception {
 482         Address->new( state => 'Connecticut' ),;
 483     },
 484     undef,
 485     '... we live correctly with good args'
 486 );
 487
 488 isnt(
 489     exception {
 490         Address->new( zip_code => 'AF5J6$' ),;
 491     },
 492     undef,
 493     '... we die correctly with bad args'
 494 );
 495
 496 is(
 497     exception {
 498         Address->new( zip_code => '06443' ),;
 499     },
 500     undef,
 501     '... we live correctly with good args'
 502 );
 503
 504 isnt(
 505     exception {
 506         Company->new(),;
 507     },
 508     undef,
 509     '... we die correctly without good args'
 510 );
 511
 512 is(
 513     exception {
 514         Company->new( name => 'Foo' ),;
 515     },
 516     undef,
 517     '... we live correctly without good args'
 518 );
 519
 520 isnt(
 521     exception {
 522         Company->new( name => 'Foo', employees => [ Person->new ] ),;
 523     },
 524     undef,
 525     '... we die correctly with good args'
 526 );
 527
 528 is(
 529     exception {
 530         Company->new( name => 'Foo', employees => [] ),;
 531     },
 532     undef,
 533     '... we live correctly with good args'
 534 );
 535
 536 =end testing
 537
 538 =cut