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