In this example we are going to use a regular Perl class as a type constraint. In the Moose version of the series we used a DateTime object as a type constraint. Classes as constraints in Moose

Implementing it in core Perl is quite similar to the previous cases. For example when we had accessor with type constraint.

examples/oop/person03/lib/Person.pm

package Person;
use strict;
use warnings;

use Scalar::Util qw(blessed);

sub new {
    my ($class, %args) = @_;

    my $self = \%args;

    bless $self, $class;

    return $self;
}

sub name {
    my ($self, $value) = @_;
    if (@_ == 2) {
        $self->{name} = $value;
    }

    return $self->{name};
}

sub birthday {
    my ($self, $value) = @_;
    if (@_ == 2) {
       die qq{Attribute (birthday) does not pass the type constraint because:} .
           qq{Validation failed for 'DateTime' with value 1988 at accessor}
            if not blessed $value or not $value->isa('DateTime') ;
        $self->{birthday} = $value;
    }

    return $self->{birthday};
}

1;

In the birthday setter/getter we add a die ... if not ... construct.

First we check if the given parameter is a blessed reference, that is if it is an instance of anything. Then we check if it is a instance of DateTime using the appropriately named isa method from the UNIVERSAL package. We need to have this 2-step checking as the isa method calling would throw an exception if the variable $value did not contain an object.

The blessed function comes from the Scalar::Util module.

Script

Sample script to use the module:

examples/oop/person03/script/person.pl

use strict;
use warnings;
use v5.10;

use Person;
use DateTime;

my $student = Person->new( name => 'Foo' );

$student->birthday( DateTime->new( year => 1988, month => 4, day => 17) );

say $student->birthday;

$student->birthday(1988);

Test

Test to verify the module and the birthday setter:

examples/oop/person03/t/01-name.t

use strict;
use warnings;
use v5.10;

use DateTime;

use Test::More tests => 7;
use Test::Exception;

use Person;

my $p = Person->new;
isa_ok($p, 'Person');

is($p->name('Foo'), 'Foo', 'setter');
is($p->name, 'Foo', 'getter');

isa_ok(
  $p->birthday( DateTime->new( year => 1988, month => 4, day => 17) ),
  'DateTime');

my $d = $p->birthday;
isa_ok($d, 'DateTime');
is($d->year, 1988, 'year is correct');

my $default_err =
  qr{Attribute \(birthday\) does not pass the type constraint because:};
my $homemade_err =
  qr{Validation failed for 'DateTime' with value 1988};

throws_ok { $p->birthday( 1988 ) }
   qr{$default_err $homemade_err}, 'Year as birthday';