use Test::More 'no_plan'; package MyBase; use Class::Std; { my %name : ATTR( :init_arg :get ); my %rank : ATTR( init_arg => 'rank' :get :set ); my %snum : ATTR( :init_arg('snum') :get ); my %priv : ATTR; my %def : ATTR( :default :get ); my %dval : ATTR( :default('dval') :get ); sub BUILD { my ($self, $ident, $arg_ref) = @_; ::is ref $arg_ref, 'HASH' => 'Args passed to MyBase::BUILD in hash-ref'; ::is ident $self, $ident => 'Identity correct in MyBase::BUILD'; $priv{$ident} = $arg_ref->{priv}; ::is $priv{$ident}, 'MyBase::priv' => 'MyBase priv arg unpacked correctly'; $snum{$ident} = $arg_ref->{snum} . '!'; ::is $snum{$ident}, 'MyBase::snum!' => 'MyBase snum arg unpacked correctly'; } sub DEMOLISH { my ($self, $ident) = @_; ::is ident $self, $ident => 'Identity correct in MyBase::DEMOLISH' } sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'MyBase::name initialized'; ::is $rank{$ident}, 'MyBase::rank' => 'MyBase::rank initialized'; ::is $snum{$ident}, 'MyBase::snum!' => 'MyBase::snum initialized'; ::is $priv{$ident}, 'MyBase::priv' => 'MyBase::name initialized'; ::is $def{$ident}, 'MyBase::def' => 'MyBase::def initialized'; } } package Der; use Class::Std; use base qw( MyBase ); { my %name : ATTR( :init_arg ); my %rank : ATTR( init_arg => 'rank' ); my %snum : ATTR( :init_arg('snum') :get ); my %priv : ATTR( :init_arg :get ); my %def : ATTR( :init_arg :default :get ); sub BUILD { my ($self, $ident, $arg_ref) = @_; ::is ref $arg_ref, 'HASH' => 'Args passed to Der::BUILD in hash-ref'; ::is ident $self, $ident => 'Identity correct in Der::BUILD'; } sub DEMOLISH { my ($self, $ident) = @_; ::is ident $self, $ident => 'Identity correct in Der::DEMOLISH' } sub verify :CUMULATIVE { my ($self) = @_; my $ident = ident $self; ::is $name{$ident}, 'MyBase::name' => 'Der::name initialized'; ::is $rank{$ident}, 'generic rank' => 'Der::rank initialized'; ::is $snum{$ident}, 'Der::snum' => 'Der::snum initialized'; ::is $priv{$ident}, 'Der::priv' => 'Der::name initialized'; ::is $def{$ident}, 'Der::def' => 'Der::def initialized'; } } package main; my $obj = MyBase->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', } }); $obj->verify(); my $derobj = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', }, Der => { snum => 'Der::snum', priv => 'Der::priv', def => 'Der::def', }, }); $derobj->verify(); is $derobj->get_name(), 'MyBase::name' => 'Der name read accessor'; is $derobj->get_rank(), 'MyBase::rank' => 'Der rank read accessor'; is $derobj->get_snum(), 'Der::snum' => 'Der rank read accessor'; is $derobj->get_priv(), 'Der::priv' => 'Der priv read accessor'; $derobj->set_rank('new rank'); is $derobj->get_rank(), 'new rank' => 'Der rank write accessor'; eval { $derobj->setname('new name') }; ok $@ =~ m/\ACan't locate object method "setname" via package "Der"/ => 'Read only name attribute'; my $der2 = Der->new({ name => 'MyBase::name', snum => 'MyBase::snum', rank => 'generic rank', priv => 'generic priv', MyBase => { rank => 'MyBase::rank', priv => 'MyBase::priv', }, Der => { snum => 0, priv => 'Der::priv', }, }); is( $der2->get_snum(), 0, 'false values allowable as attribute parameters' ); is( $der2->get_dval, 'dval', 'default values evaled correctly' );