my
$madness
=
'Object::Lvalue'
;
my
@base_methodz
=
qw
(
new
construct
initialize
shallow
clone
DESTROY
cleanup
class_attr
attributes
verbose
);
require_ok
$madness
;
my
$initialize
=
sub
{
my
$obj
=
shift
;
$obj
->
$_
=
shift
for
$obj
->attributes;
$obj
};
my
@classdefz
=
(
[
foo
=>
''
=>
qw( bar bletch blort )
]
, [
bim
=>
foo
=>
qw( bam )
]
, [
fee
=>
bim
=>
qw( fie foe fum )
]
);
my
%class2attrz
= ();
note
"Class meta:\n"
, explain \
@classdefz
;
for
(
@classdefz
)
{
local
$" =
' '
;
state
$obj
=
'$obj'
;
state
$ISA
=
'@ISA'
;
state
$init
=
'&$initialize'
;
my
(
$class
,
$base
,
@pkg_attrz
) =
@$_
;
note
"Install: $class ($base) => @pkg_attrz"
;
my
$pkg
=
<<"PKG";
package $class;
use v5.34;
BEGIN { our $ISA = qw( $base ) }
use $madness qw( @pkg_attrz );
sub initialize { $init }
1
PKG
note
"$pkg"
;
eval
qq|$pkg|
// BAIL_OUT
"Failed prepare: $class, $@"
;
my
$class_attrz
=
$class2attrz
{
$class
} = {};
$class_attrz
->{ class_attr } = \
@pkg_attrz
;
$class_attrz
->{ attributes } =
[
uniq
map
{
do
{
$class2attrz
{
$_
}{ class_attr } || [] }->@*
}
$class
->mro::get_linear_isa->@*
];
}
note
"Attr meta:\n"
, explain \
%class2attrz
;
for
(
@classdefz
)
{
my
(
$class
) =
$_
->[0];
while
(
my
(
$method
,
$expect
)
=
each
$class2attrz
{
$class
}->%*
)
{
my
$found
=
$class
->
$method
;
my
$attrs
=
join
' '
=>
@$found
;
is_deeply
$found
,
$expect
,
"$class $method => $attrs"
or diag
"Mismatched $method:\n"
,
,
"Expect:\n"
, explain
$expect
,
"Found:\n"
, explain
$found
;
}
}
pass
'Survived'
;
done_testing;