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