package Perl6::MetaModel;
use strict;
use warnings;
use Carp 'confess';
our $VERSION = '2.00';
sub import {
# load the meta-model ..
require Perl6::MetaModel::Genesis;
# export &class
no strict 'refs';
my $pkg = caller;
*{"${pkg}::class"} = \&class;
*{"${pkg}::role"} = \&role;
*{"${pkg}::__"} = \&__;
}
sub _ {
my $attr = shift;
($::SELF != $::CLASS)
|| confess 'You cannot change an attribute in $::CLASS using this function';
($::CLASS->find_attribute_spec($attr))
|| confess "Attribute ($attr) is not a valid attribute for $::SELF";
::opaque_instance_attr($::SELF => $attr) = shift if @_;
::opaque_instance_attr($::SELF => $attr);
}
sub __ {
my $attr = shift;
$::CLASS->STORE($attr => shift) if @_;
$::CLASS->FETCH($attr);
}
sub class {
my ($full_name, $body) = @_;
# support generic classes here ...
if (defined($body) && defined($_[2]) && ref($body) && ref($body) =~ 'ARRAY') {
my ($body, @param_names) = ($_[2], @{$_[1]});
my ($name, $version, $authority) = split '-' => $full_name;
return sub {
confess "No parameters passed, looking for { " . (join ", " => @param_names) . " }"
unless @_;
my %params = @_;
return _build_class($name, $version, $authority, sub { $body->(%params) });
};
}
# support anon-classes here ....
if (!defined($body) && ref($full_name) && ref($full_name) =~ /HASH|CODE/) {
return _build_class('', undef, undef, $full_name);
}
my ($name, $version, $authority) = split '-' => $full_name;
my $new_class = _build_class($name, $version, $authority, $body);
$::{'*'}->STORE('::' . $new_class->name => $new_class);
return $new_class;
}
sub role {
my ($full_name, $body) = @_;
# support anon-role here
if (!defined($body) && ref($full_name) && ref($full_name) =~ /HASH|CODE/) {
return _build_role(undef, undef, undef, $full_name);
}
my ($name, $version, $authority) = split '-' => $full_name;
my $new_role = _build_role($name, $version, $authority, $body);
$::{'*'}->STORE('::' . $new_role->name => $new_role);
return $new_role;
}
sub _build_class {
my ($name, $version, $authority, $body) = @_;
my $metaclass = $::Class;
$metaclass = $body->{metaclass}
if ref($body) eq 'HASH' && exists $body->{metaclass};
my $new_class = $metaclass->new();
$new_class->name($name) if defined $name;
$new_class->version($version) if defined $version;
$new_class->authority($authority) if defined $authority;
if (ref($body) eq 'CODE') {
local $::CLASS = $new_class;
$body->();
}
elsif (ref($body) eq 'HASH') {
$new_class->superclasses($body->{is}) if exists $body->{is};
$new_class->roles($body->{does}) if exists $body->{does};
if ($body->{attributes}) {
foreach my $attribute_name (@{$body->{attributes}}) {
$new_class->add_attribute($attribute_name => ::make_attribute($attribute_name));
}
}
if ($body->{class_attributes}) {
foreach my $attr_name (@{$body->{class_attributes}}) {
$new_class->STORE($attr_name => ($attr_name =~ /^@/ ? [] : $attr_name =~ /^%/ ? {} : undef));
}
}
if ($body->{methods}) {
foreach my $method_name (keys %{$body->{methods}}) {
if ($method_name =~ /^_/) {
$new_class->add_method($method_name => ::make_private_method(
$body->{methods}->{$method_name}
));
}
else {
$new_class->add_method($method_name => ::make_method(
$body->{methods}->{$method_name}
));
}
}
}
if ($body->{submethods}) {
foreach my $method_name (keys %{$body->{submethods}}) {
$new_class->add_method($method_name => ::make_submethod(
$body->{submethods}->{$method_name}
));
}
}
if ($body->{class_methods}) {
foreach my $method_name (keys %{$body->{class_methods}}) {
if ($method_name =~ /^_/) {
# we just add a private method in here...
# there is no real distinction between the
# private class method or the private instance
# method, maybe there should be, but I am not sure
$new_class->add_singleton_method($method_name => ::make_private_method(
$body->{class_methods}->{$method_name}
));
}
else {
$new_class->add_singleton_method($method_name => ::make_method(
$body->{class_methods}->{$method_name}
));
}
}
}
}
$new_class->resolve; # if $body->{does};
return $new_class;
}
sub _build_role {
my ($name, $version, $authority, $body) = @_;
my $new_role = $::Role->new();
$new_role->name($name) if defined $name;
$new_role->version($version) if defined $version;
$new_role->authority($authority) if defined $authority;
if (ref($body) eq 'CODE') {
local $::ROLE = $new_role;
$body->();
}
elsif (ref($body) eq 'HASH') {
$new_role->roles($body->{does}) if exists $body->{does};
if ($body->{attributes}) {
foreach my $attribute_name (@{$body->{attributes}}) {
$new_role->add_attribute($attribute_name => ::make_attribute($attribute_name));
}
}
if ($body->{methods}) {
foreach my $method_name (keys %{$body->{methods}}) {
if ($method_name =~ /^_/) {
$new_role->add_method($method_name => ::make_private_method(
$body->{methods}->{$method_name}
));
}
else {
$new_role->add_method($method_name => ::make_method(
$body->{methods}->{$method_name}
));
}
}
}
if ($body->{submethods}) {
foreach my $method_name (keys %{$body->{submethods}}) {
$new_role->add_method($method_name => ::make_submethod(
$body->{submethods}->{$method_name}
));
}
}
if ($body->{class_methods}) {
foreach my $method_name (keys %{$body->{class_methods}}) {
if ($method_name =~ /^_/) {
# we just add a private method in here...
# there is no real distinction between the
# private class method or the private instance
# method, maybe there should be, but I am not sure
$new_role->add_method($method_name => ::make_private_method(
$body->{class_methods}->{$method_name}
));
}
else {
$new_role->add_method($method_name => ::make_class_method(
$body->{class_methods}->{$method_name}
));
}
}
}
}
return $new_role;
}
1;
__END__
=pod
=head1 NAME
Perl6::MetaModel - The Perl 6 Object Meta Model
=head1 SYNOPSIS
# more Macro-ish form (less typing for you)
class 'Foo-0.0.1-cpan:STEVAN' => {
is => [ $::Object ],
class_methods => {
foo => sub { "Hello from foo" },
bar => sub { "Hello from bar" },
}
};
# class-is-a-closure form (more typing
# for you, but more control)
class 'Foo-0.0.1-cpan:STEVAN' => sub {
$::CLASS->superclasses([ $::Object ]);
foreach my $name (qw(foo bar)) {
$::CLASS->add_method($name => ::make_class_method(sub { "Hello from $name" }, $::CLASS));
}
};
=head1 DESCRIPTION
=head1 SEE ALSO
=head1 AUTHOR
Stevan Little E<gt>stevan@iinteractive.comE<lt>
=cut