lib/Moose/Cookbook/Basics/Recipe4.pod

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