1use Test::More 'no_plan';
2
3package MyBase;
4use Class::Std;
5{
6    my %name : ATTR( :init_arg<name>    :get<name>             );
7    my %rank : ATTR( init_arg => 'rank' :get<rank> :set<rank>  );
8    my %snum : ATTR( :init_arg('snum')  :get<snum>             );
9    my %priv : ATTR;
10    my %def  : ATTR( :default<MyBase::def> :get<default>       );
11    my %dval : ATTR( :default('dval') :get<dval>               );
12
13    sub BUILD {
14        my ($self, $ident, $arg_ref) = @_;
15
16        ::is ref $arg_ref, 'HASH'  => 'Args passed to MyBase::BUILD in hash-ref';
17        ::is ident $self, $ident   => 'Identity correct in MyBase::BUILD';
18
19        $priv{$ident} = $arg_ref->{priv};
20        ::is $priv{$ident}, 'MyBase::priv'  => 'MyBase priv arg unpacked correctly';
21
22        $snum{$ident} = $arg_ref->{snum} . '!';
23        ::is $snum{$ident}, 'MyBase::snum!'  => 'MyBase snum arg unpacked correctly';
24    }
25
26    sub DEMOLISH {
27        my ($self, $ident) = @_;
28
29        ::is ident $self, $ident   => 'Identity correct in MyBase::DEMOLISH'
30    }
31
32    sub verify :CUMULATIVE {
33        my ($self) = @_;
34        my $ident = ident $self;
35
36        ::is $name{$ident}, 'MyBase::name'    => 'MyBase::name initialized';
37        ::is $rank{$ident}, 'MyBase::rank'    => 'MyBase::rank initialized';
38        ::is $snum{$ident}, 'MyBase::snum!'   => 'MyBase::snum initialized';
39        ::is $priv{$ident}, 'MyBase::priv'    => 'MyBase::name initialized';
40        ::is $def{$ident},  'MyBase::def'     => 'MyBase::def initialized';
41    }
42}
43
44package Der;
45use Class::Std;
46use base qw( MyBase );
47{
48    my %name : ATTR( :init_arg<name>                );
49    my %rank : ATTR( init_arg => 'rank'             );
50    my %snum : ATTR( :init_arg('snum')  :get<snum> );
51    my %priv : ATTR( :init_arg<priv>    :get<priv> );
52    my %def  : ATTR( :init_arg<def> :default<default def> :get<default>  );
53
54    sub BUILD {
55        my ($self, $ident, $arg_ref) = @_;
56
57        ::is ref $arg_ref, 'HASH'  => 'Args passed to Der::BUILD in hash-ref';
58        ::is ident $self, $ident   => 'Identity correct in Der::BUILD';
59    }
60
61    sub DEMOLISH {
62        my ($self, $ident) = @_;
63
64        ::is ident $self, $ident   => 'Identity correct in Der::DEMOLISH'
65    }
66
67    sub verify :CUMULATIVE {
68        my ($self) = @_;
69        my $ident = ident $self;
70
71        ::is $name{$ident}, 'MyBase::name'   => 'Der::name initialized';
72        ::is $rank{$ident}, 'generic rank'   => 'Der::rank initialized';
73        ::is $snum{$ident}, 'Der::snum'      => 'Der::snum initialized';
74        ::is $priv{$ident}, 'Der::priv'      => 'Der::name initialized';
75        ::is $def{$ident},  'Der::def'       => 'Der::def initialized';
76    }
77}
78
79package main;
80
81my $obj = MyBase->new({
82    name => 'MyBase::name',
83    snum => 'MyBase::snum',
84    rank => 'generic rank',
85    priv => 'generic priv',
86    MyBase => {
87        rank => 'MyBase::rank',
88        priv => 'MyBase::priv',
89    }
90});
91
92$obj->verify();
93
94my $derobj = Der->new({
95    name => 'MyBase::name',
96    snum => 'MyBase::snum',
97    rank => 'generic rank',
98    priv => 'generic priv',
99    MyBase => {
100        rank => 'MyBase::rank',
101        priv => 'MyBase::priv',
102    },
103    Der => {
104        snum => 'Der::snum',
105        priv => 'Der::priv',
106        def  => 'Der::def',
107    },
108});
109
110$derobj->verify();
111
112is $derobj->get_name(), 'MyBase::name'  => 'Der name read accessor';
113is $derobj->get_rank(), 'MyBase::rank'  => 'Der rank read accessor';
114is $derobj->get_snum(), 'Der::snum'     => 'Der rank read accessor';
115is $derobj->get_priv(), 'Der::priv'     => 'Der priv read accessor';
116
117$derobj->set_rank('new rank');
118is $derobj->get_rank(), 'new rank'      => 'Der rank write accessor';
119
120eval { $derobj->setname('new name') };
121ok $@ =~ m/\ACan't locate object method "setname" via package "Der"/
122                                        => 'Read only name attribute';
123
124my $der2 = Der->new({
125    name => 'MyBase::name',
126    snum => 'MyBase::snum',
127    rank => 'generic rank',
128    priv => 'generic priv',
129    MyBase => {
130        rank => 'MyBase::rank',
131        priv => 'MyBase::priv',
132    },
133    Der => {
134        snum => 0,
135        priv => 'Der::priv',
136    },
137});
138is( $der2->get_snum(), 0, 'false values allowable as attribute parameters' );
139
140is( $der2->get_dval, 'dval', 'default values evaled correctly' );
141