From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

# if you execute this script directly it say's
# Looks like you planned 47 tests but only ran 44.
# because the destructos / DEMOLISH methods won't be
# executed
use Test::More tests => 45;
eval q{
package MyBase;
use Class::Std::Fast;
{
my %name : ATTR( :init_arg<name> :get<name> );
my %rank : ATTR( init_arg => 'rank' :get<rank> :set<rank> );
my %snum : ATTR( :init_arg('snum') :get<snum> );
my %priv : ATTR;
my %def : ATTR( :default<MyBase::def> :get<default> );
my %dval : ATTR( :default('dval') :get<dval> );
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';
}
sub rest : RESTRICTED {
::ok 1, 'Accessed restricted';
}
Class::Std::Fast::initialize;
}
package Der;
use base qw( MyBase );
{
my %name : ATTR( :init_arg<name> );
my %rank : ATTR( init_arg => 'rank' );
my %snum : ATTR( :init_arg('snum') :get<snum> );
my %priv : ATTR( :init_arg<priv> :get<priv> );
my %def : ATTR( :init_arg<def> :default<default def> :get<default> );
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';
$self->rest();
}
Class::Std::Fast::initialize;
}
};
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' );
print "# DONE - now comes the cleanup...\n";