our
$VERSION
=
'1.234'
;
my
%STATIC
= (
new
=>
sub
{
my
(
$pkg
,
$arg
) =
@_
;
my
$class
=
bless
$arg
=>
$pkg
;
},
);
my
%UNIVERSAL
= (
new
=>
sub
{
bless
{
__class__
=>
$_
[0] } =>
$_
[0]->instance_class, },
name
=>
sub
{
$_
[0]->{name} },
base
=>
sub
{
$_
[0]->{base} },
new_subclass
=>
sub
{
my
(
$class
,
$arg
) =
@_
;
my
$pkg
=
ref
$class
;
my
$new
= {
%$arg
,
base
=>
$class
};
bless
$new
=>
$pkg
;
},
instance_class
=>
sub
{
'Instance'
},
class_methods
=>
sub
{
$_
[0]->{class_methods} },
instance_methods
=>
sub
{
$_
[0]->{instance_methods} },
derives_from
=>
sub
{
my
(
$self
,
$super
) =
@_
;
return
unless
(
ref
$self
)->UNIVERSAL::isa(__PACKAGE__);
my
$curr
=
$self
;
while
(
$curr
) {
return
1
if
$curr
==
$super
;
$curr
=
$curr
->base;
}
return
;
},
);
my
(
$invocant
,
$method_name
,
$args
) =
@_
;
my
$curr
=
$invocant
;
my
$code
;
unless
(
ref
$invocant
) {
die
"no metaclass method $method_name on $invocant"
unless
$code
=
$STATIC
{
$method_name
};
return
$code
->(
$invocant
,
@$args
);
}
while
(
$curr
) {
my
$methods
=
$curr
->{class_methods};
$code
=
$methods
->{
$method_name
},
last
if
exists
$methods
->{
$method_name
};
$curr
=
$curr
->{base};
}
Carp::confess(
"no class method $method_name on $invocant->{name}"
)
unless
$code
||=
$UNIVERSAL
{
$method_name
};
$code
->(
$invocant
,
@$args
);
};
1;