lib/Moose/Cookbook/Basics/Company_Subtypes.pod

   1 package Moose::Cookbook::Basics::Company_Subtypes;
   2
   3 # ABSTRACT: Demonstrates the use of subtypes and how to model classes related to companies, people, employees, etc.
   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 by the constructor
 210 immediately after object construction, but before the object is returned
 211 to the caller. Note that all C<BUILD> methods in your class hierarchy
 212 will be called automatically; there is no need to (and you should not)
 213 call 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<Moose::Cookbook::Basics::BinaryTree_AttributeFeatures>.
 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 =back
 301
 302 =begin testing
 303
 304 {
 305     package Company;
 306
 307     sub get_employee_count { scalar @{(shift)->employees} }
 308 }
 309
 310 use Scalar::Util 'isweak';
 311
 312 my $ii;
 313 is(
 314     exception {
 315         $ii = Company->new(
 316             {
 317                 name    => 'Infinity Interactive',
 318                 address => Address->new(
 319                     street   => '565 Plandome Rd., Suite 307',
 320                     city     => 'Manhasset',
 321                     state    => 'NY',
 322                     zip_code => '11030'
 323                 ),
 324                 employees => [
 325                     Employee->new(
 326                         first_name => 'Jeremy',
 327                         last_name  => 'Shao',
 328                         title      => 'President / Senior Consultant',
 329                         address    => Address->new(
 330                             city => 'Manhasset', state => 'NY'
 331                         )
 332                     ),
 333                     Employee->new(
 334                         first_name => 'Tommy',
 335                         last_name  => 'Lee',
 336                         title      => 'Vice President / Senior Developer',
 337                         address =>
 338                             Address->new( city => 'New York', state => 'NY' )
 339                     ),
 340                     Employee->new(
 341                         first_name     => 'Stevan',
 342                         middle_initial => 'C',
 343                         last_name      => 'Little',
 344                         title          => 'Senior Developer',
 345                         address =>
 346                             Address->new( city => 'Madison', state => 'CT' )
 347                     ),
 348                 ]
 349             }
 350         );
 351     },
 352     undef,
 353     '... created the entire company successfully'
 354 );
 355
 356 isa_ok( $ii, 'Company' );
 357
 358 is( $ii->name, 'Infinity Interactive',
 359     '... got the right name for the company' );
 360
 361 isa_ok( $ii->address, 'Address' );
 362 is( $ii->address->street, '565 Plandome Rd., Suite 307',
 363     '... got the right street address' );
 364 is( $ii->address->city,     'Manhasset', '... got the right city' );
 365 is( $ii->address->state,    'NY',        '... got the right state' );
 366 is( $ii->address->zip_code, 11030,       '... got the zip code' );
 367
 368 is( $ii->get_employee_count, 3, '... got the right employee count' );
 369
 370 # employee #1
 371
 372 isa_ok( $ii->employees->[0], 'Employee' );
 373 isa_ok( $ii->employees->[0], 'Person' );
 374
 375 is( $ii->employees->[0]->first_name, 'Jeremy',
 376     '... got the right first name' );
 377 is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' );
 378 ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' );
 379 is( $ii->employees->[0]->middle_initial, undef,
 380     '... got the right middle initial value' );
 381 is( $ii->employees->[0]->full_name,
 382     'Jeremy Shao, President / Senior Consultant',
 383     '... got the right full name' );
 384 is( $ii->employees->[0]->title, 'President / Senior Consultant',
 385     '... got the right title' );
 386 is( $ii->employees->[0]->employer, $ii, '... got the right company' );
 387 ok( isweak( $ii->employees->[0]->{employer} ),
 388     '... the company is a weak-ref' );
 389
 390 isa_ok( $ii->employees->[0]->address, 'Address' );
 391 is( $ii->employees->[0]->address->city, 'Manhasset',
 392     '... got the right city' );
 393 is( $ii->employees->[0]->address->state, 'NY', '... got the right state' );
 394
 395 # employee #2
 396
 397 isa_ok( $ii->employees->[1], 'Employee' );
 398 isa_ok( $ii->employees->[1], 'Person' );
 399
 400 is( $ii->employees->[1]->first_name, 'Tommy',
 401     '... got the right first name' );
 402 is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' );
 403 ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' );
 404 is( $ii->employees->[1]->middle_initial, undef,
 405     '... got the right middle initial value' );
 406 is( $ii->employees->[1]->full_name,
 407     'Tommy Lee, Vice President / Senior Developer',
 408     '... got the right full name' );
 409 is( $ii->employees->[1]->title, 'Vice President / Senior Developer',
 410     '... got the right title' );
 411 is( $ii->employees->[1]->employer, $ii, '... got the right company' );
 412 ok( isweak( $ii->employees->[1]->{employer} ),
 413     '... the company is a weak-ref' );
 414
 415 isa_ok( $ii->employees->[1]->address, 'Address' );
 416 is( $ii->employees->[1]->address->city, 'New York',
 417     '... got the right city' );
 418 is( $ii->employees->[1]->address->state, 'NY', '... got the right state' );
 419
 420 # employee #3
 421
 422 isa_ok( $ii->employees->[2], 'Employee' );
 423 isa_ok( $ii->employees->[2], 'Person' );
 424
 425 is( $ii->employees->[2]->first_name, 'Stevan',
 426     '... got the right first name' );
 427 is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' );
 428 ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' );
 429 is( $ii->employees->[2]->middle_initial, 'C',
 430     '... got the right middle initial value' );
 431 is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer',
 432     '... got the right full name' );
 433 is( $ii->employees->[2]->title, 'Senior Developer',
 434     '... got the right title' );
 435 is( $ii->employees->[2]->employer, $ii, '... got the right company' );
 436 ok( isweak( $ii->employees->[2]->{employer} ),
 437     '... the company is a weak-ref' );
 438
 439 isa_ok( $ii->employees->[2]->address, 'Address' );
 440 is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' );
 441 is( $ii->employees->[2]->address->state, 'CT', '... got the right state' );
 442
 443 # create new company
 444
 445 my $new_company
 446     = Company->new( name => 'Infinity Interactive International' );
 447 isa_ok( $new_company, 'Company' );
 448
 449 my $ii_employees = $ii->employees;
 450 foreach my $employee (@$ii_employees) {
 451     is( $employee->employer, $ii, '... has the ii company' );
 452 }
 453
 454 $new_company->employees($ii_employees);
 455
 456 foreach my $employee ( @{ $new_company->employees } ) {
 457     is( $employee->employer, $new_company,
 458         '... has the different company now' );
 459 }
 460
 461 ## check some error conditions for the subtypes
 462
 463 isnt(
 464     exception {
 465         Address->new( street => {} ),;
 466     },
 467     undef,
 468     '... we die correctly with bad args'
 469 );
 470
 471 isnt(
 472     exception {
 473         Address->new( city => {} ),;
 474     },
 475     undef,
 476     '... we die correctly with bad args'
 477 );
 478
 479 isnt(
 480     exception {
 481         Address->new( state => 'British Columbia' ),;
 482     },
 483     undef,
 484     '... we die correctly with bad args'
 485 );
 486
 487 is(
 488     exception {
 489         Address->new( state => 'Connecticut' ),;
 490     },
 491     undef,
 492     '... we live correctly with good args'
 493 );
 494
 495 isnt(
 496     exception {
 497         Address->new( zip_code => 'AF5J6$' ),;
 498     },
 499     undef,
 500     '... we die correctly with bad args'
 501 );
 502
 503 is(
 504     exception {
 505         Address->new( zip_code => '06443' ),;
 506     },
 507     undef,
 508     '... we live correctly with good args'
 509 );
 510
 511 isnt(
 512     exception {
 513         Company->new(),;
 514     },
 515     undef,
 516     '... we die correctly without good args'
 517 );
 518
 519 is(
 520     exception {
 521         Company->new( name => 'Foo' ),;
 522     },
 523     undef,
 524     '... we live correctly without good args'
 525 );
 526
 527 isnt(
 528     exception {
 529         Company->new( name => 'Foo', employees => [ Person->new ] ),;
 530     },
 531     undef,
 532     '... we die correctly with good args'
 533 );
 534
 535 is(
 536     exception {
 537         Company->new( name => 'Foo', employees => [] ),;
 538     },
 539     undef,
 540     '... we live correctly with good args'
 541 );
 542
 543 =end testing
 544
 545 =cut