1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
package CD;
use Moose;
use Moose::Util::TypeConstraints;
has 'title' => ( is => 'rw', isa => 'Str' );
has 'artist' => ( is => 'rw', isa => 'CD::Artist' );
has 'publishdate' => ( is => 'rw', isa => 'Time::Piece' );
# we need proper generics! this is silly
subtype "Array of CD::Song"
=> as ArrayRef
=> where {
(blessed($_) && $_->isa('CD::Song') || return) for @$_; 1
};
has 'songs' => ( is => 'rw', isa => 'Array of CD::Song' );
package CD::Compilation;
use Moose;
extends 'CD';
package CD::Song;
use Moose;
has 'name' => ( is => 'rw', isa => 'Str' );
package CD::Artist;
use Moose;
use Set::Object;
has 'name' => ( is => 'rw', isa => 'Str' );
has 'popularity' => ( is => 'rw', isa => 'Str' );
use Moose::Util::TypeConstraints;
subtype "Set of CD"
=> as Set::Object
=> where {
($_->isa('CD') || return) for $_->members; 1
};
has 'cds' => ( is => 'rw', isa => 'Set of CD' );
package CD::Person;
use Moose;
use Moose::Util::TypeConstraints;
extends 'CD::Artist';
enum "Gender" => qw(Male Female Asexual Hemaphrodite);
has 'gender' => ( is => 'rw', isa => "Gender" );
has 'haircolor' => ( is => 'rw', isa => "Str" );
has 'birthdate' => ( is => 'rw', isa => 'Time::Piece' );
package CD::Band;
use Moose;
use Moose::Util::TypeConstraints;
extents 'CD::Artist';
subtype "Set of CD::Person"
=> as Set::Object
=> where {
($_->isa('CD::Artist') || return) for $_->members; 1
};
has 'members' => ( is => 'rw', isa => 'Set of CD::Person' );
has 'creationdate' => ( is => 'rw', isa => 'Time::Piece' );
has 'enddate' => ( is => 'rw', isa => 'Time::Piece' );
sub CD::addone { $CD::c++ }
sub CD::delone { --$CD::c }
# for running tests, we keep a count of objects created
BEGIN {
for my $package ( qw(CD CD::Song CD::Artist CD::Person CD::Band) ) {
eval " package $package;
before 'new' => \&CD::addone;
after 'DESTROY' => \&CD::delone;";
}
}
# This dispatching isn't necessary because we use inheritance
# # Dispatch "band" accessors if it's a band
# for my $accessor (qw(members creationdate breakupdate)) {
# *$accessor = sub {
# my $self = shift;
# return $self->band->$accessor(@_) if $self->band
# };
# }
# # And dispatch "person" accessors if it's a person
# for my $accessor (qw(gender haircolor birthdate)) {
# *$accessor = sub {
# my $self = shift;
# return $self->person->$accessor(@_) if $self->person
# };
# }
1;
|
