{
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'
;
}
}
{
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'
;
}
}
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'
);