#!/usr/bin/perl
use strict;
use warnings;
use Perl6::MetaModel::Gnosis;
use constant BOOTSTRAPPED_COMPLETE => 8;
# ... this constructs the rest of the ::Class
# the result of this file is the (demiurge)
$::Class->add_method('new' => ::make_method(sub {
my ($class, %params) = @_;
return $class->bless(undef, %params);
}));
$::Class->add_method('bless' => ::make_method(sub {
my ($class, $canidate, %params) = @_;
$canidate ||= 'P6opaque'; # opaque is our default
my $self = $class->CREATE(repr => $canidate, %params);
$self->BUILDALL(%params);
return $self;
}));
$::Class->add_method('CREATE' => ::make_method(sub {
my ($class, %params) = @_;
($params{repr} eq 'P6opaque')
|| confess "Sorry, No other types other than 'P6opaque' are currently supported";
# this just gathers all the
# attributes that were defined
# for the instances.
my %attrs;
my $dispatcher = $class->dispatcher(':descendant');
while (my $c = ::WALKCLASS($dispatcher)) {
foreach my $attr ($c->get_attribute_list()) {
my $attr_obj = $c->get_attribute($attr);
$attrs{$attr} = ::instantiate_attribute_container($attr_obj);
}
}
# this is our P6opaque data structure
# it's nothing special, but it works :)
my $self = ::create_opaque_instance(\$class, %attrs);
# and now return it ...
return $self;
}));
$::Class->add_method('BUILDALL' => ::make_method(sub {
my ($self, %params) = @_;
my $dispatcher = ::opaque_instance_class($self)->dispatcher(':descendant');
while (my $method = ::WALKMETH($dispatcher, 'BUILD')) {
$method->($Perl6::Submethod::FORCE, $self, %params);
}
}));
$::Class->add_method('BUILD' => ::make_submethod(sub {
my ($self, %params) = @_;
foreach my $key (keys %params) {
# XXX -
# The default BUILD method should accept
# params which are not included in the
# attributes. It will do nothing with them
# but it will allow them to exist.
# - (see t_oo/submethods.t)
::opaque_instance_attr($self => $key) = $params{$key}
# NOTE:
# this is an ugly way to do this, ideally
# we would peek into the instance structure
# itself and see if we had the spot, and
# otherwise ignore it ... but this will do
if ::opaque_instance_class($self)->find_attribute_spec($key);
}
if (::opaque_instance_id($self) > BOOTSTRAPPED_COMPLETE &&
$self->class->class->class != $::EigenClass &&
$self->class != $::EigenClass ) {
#my $class = $self->class;
#warn "class: $class => self: $self => class-class: " . ::opaque_instance_class($class);
my $eigenclass = $::EigenClass->new('$:name' => 'EigenClass[' . ($self->name || $params{'$:name'} || 'anon') . ']');
if (@{$self->superclasses}) {
$eigenclass->superclasses([ map { $_->class } @{$self->superclasses} ]);
}
else {
$eigenclass->superclasses([ $self->class ]);
}
::opaque_instance_change_class($self, $eigenclass);
#warn "class: $class => self: $self => class-class: " . ::opaque_instance_class($class);
}
}));
# NOTE: This needs to be here to keep the Eigenclass name in sync
$::Class->add_method('name' => ::make_method(sub {
my ($self, $name) = @_;
if ($name) {
::opaque_instance_attr($self->class => '$:name') = 'EigenClass[' . $name . ']'
if $self->class->class == $::EigenClass ||
$self->class == $::EigenClass;
::opaque_instance_attr($self => '$:name') = $name;
}
::opaque_instance_attr($self => '$:name');
}));
$::Class->add_method('DESTROYALL' => ::make_method(sub {
my ($self) = @_;
my $dispatcher = ::opaque_instance_class($self)->dispatcher(':ascendant');
while (my $method = ::WALKMETH($dispatcher, 'DESTROY')) {
$method->($Perl6::Submethod::FORCE, $self);
}
}));
$::Class->add_method('isa' => ::make_method(sub {
my ($self, $class_name) = @_;
return undef unless $class_name;
my $dispatcher = $self->dispatcher(':canonical');
while (my $next = $dispatcher->()) {
#warn 'Hello there ... looking for ' . $class_name . ' => ' . $next->name;
return 1 if $class_name eq $next->name;
}
# if we are not a class of something
# maybe they are asking of we are an
# instance of something,.. so we pass
# it back up to our class
return ::opaque_instance_class($self)->isa($class_name)
# however, we need to not do this
# for $::Class as that presents a
# meta-circularity issue, and it
# loops endlessly
unless $self == $::Class;
return 0;
}));
$::Class->add_method('can' => ::make_method(sub {
my ($self, $label) = @_;
return undef unless $label;
return ::WALKMETH(::opaque_instance_class($self)->dispatcher(':canonical'), $label);
}));
$::Class->add_method('id' => ::make_method(sub { ::opaque_instance_id($::SELF) }));
$::Class->add_method('class' => ::make_method(sub { ::opaque_instance_class($::SELF) }));
$::Class->add_method('superclasses' => ::make_method(sub {
my ($self, $superclasses) = @_;
if (defined $superclasses) {
confess "You must pass the superclasses in an ARRAY ref"
unless ref($superclasses) eq 'ARRAY';
foreach my $super (@{$superclasses}) {
$super->add_subclass($self);
}
# XXX -
# we should check that none of the classes passed to us
# are also subclasses of us, this is circular inheritance
# and not allowed.
::opaque_instance_attr($self => '@:superclasses') = $superclasses;
# clear the MRO now
::opaque_instance_attr($self => '@:MRO') = [];
# and recalculate it ..
$self->MRO();
# the eigenclasses now
if (::opaque_instance_id($self) > BOOTSTRAPPED_COMPLETE &&
::opaque_instance_class($self) != $::EigenClass ) {
#warn "hello from superclasses for $self";
::opaque_instance_attr(::opaque_instance_class($self) => '@:superclasses') = [
map { ::opaque_instance_class($_) } @{$superclasses}
];
::opaque_instance_attr(::opaque_instance_class($self) => '@:MRO') = [];
::opaque_instance_class($self)->MRO();
}
}
::opaque_instance_attr($self => '@:superclasses');
}));
$::Class->add_method('subclasses' => ::make_method(sub {
::opaque_instance_attr($::SELF => '@:subclasses');
}));
$::Class->add_method('add_subclass' => ::make_method(sub {
my ($self, $subclass) = @_;
push @{::opaque_instance_attr($self => '@:subclasses')} => $subclass;
}));
$::Class->add_method('_merge' => ::make_private_method(sub {
my ($self, @seqs) = @_;
my @res;
while (1) {
# remove all empty seqences
my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
# return the list if we have no more no-empty sequences
return @res if not @nonemptyseqs;
my $cand; # a canidate ..
foreach my $seq (@nonemptyseqs) {
$cand = $seq->[0]; # get the head of the list
my $nothead;
foreach my $sub_seq (@nonemptyseqs) {
# XXX - this is instead of the python "in"
my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
# NOTE:
# jump out as soon as we find one matching
# there is no reason not too. However, if
# we find one, then just remove the '&& last'
$nothead++ && last if exists $in_tail{$cand};
}
last unless $nothead; # leave the loop with our canidate ...
$cand = undef; # otherwise, reject it ...
}
confess "Inconsistent hierarchy" if not $cand;
push @res => $cand;
# now loop through our non-empties and pop
# off the head if it matches our canidate
foreach my $seq (@nonemptyseqs) {
shift @{$seq} if $seq->[0] eq $cand;
}
}
}));
$::Class->add_method('MRO' => ::make_method(sub {
my $self = shift;
unless (@{::opaque_instance_attr($self => '@:MRO')}) {
::opaque_instance_attr($self => '@:MRO') = [
$self->_merge(
[ $self ], # the class we are linearizing
(map { [ $_->MRO() ] } @{$self->superclasses}), # the MRO of all the superclasses
[ @{$self->superclasses} ] # a list of all the superclasses
)
];
}
return @{::opaque_instance_attr($self => '@:MRO')};
}));
$::Class->add_method('dispatcher' => ::make_method(sub {
my ($self, $order) = @_;
$order = ':ascendant' # C3 is the canonical order
if not(defined($order)) || $order eq ':canonical';
my $dispatcher;
if ($order eq ':preorder') {
$dispatcher = $self->_make_preorder_dispatcher();
}
elsif ($order eq ':breadth') {
$dispatcher = $self->_make_breadth_dispatcher();
}
elsif ($order eq ':descendant') {
$dispatcher = $self->_make_descendant_dispatcher();
}
elsif ($order eq ':ascendant') {
$dispatcher = $self->_make_ascendant_dispatcher();
}
else {
confess 'Unsupported dispatch order ($order)'
}
return $dispatcher;
}));
$::Class->add_method('_make_dispatcher_iterator' => ::make_private_method(sub {
my (undef, @values) = @_;
my $counter = 0;
return sub { return $counter if @_; $values[$counter++] };
}));
$::Class->add_method('_make_preorder_dispatcher' => ::make_private_method(sub {
my @stack = $::SELF->_make_dispatcher_iterator($::SELF);
return sub {
TOP: {
if (defined $stack[-1]) {
# get the iterator on the top of the stack
# get the current value out of the iterator
my $current_class = $stack[-1]->();
# if current is null then ...
if (not defined $current_class) {
# that iterator is exhausted and we
# need to pop it off the stack ...
pop @stack;
# now go back to the top and start over
redo TOP;
}
else {
push @stack => $::SELF->_make_dispatcher_iterator(@{$current_class->superclasses})
if $current_class->superclasses;
}
return $current_class;
}
return undef;
}
};
}));
$::Class->add_method('_make_breadth_dispatcher' => ::make_private_method(sub {
my @stack = $::SELF->_make_dispatcher_iterator($::SELF);
return sub {
TOP:
if (scalar(@stack) != -0) {
# get the iterator on the top of the stack
# get the current value out of the iterator
my $current_class = $stack[0]->();
# if current is null then ...
if (not defined $current_class) {
# that iterator is exhausted and we
# need to pop it off the stack ...
shift @stack;
# now go back to the top and start over
goto TOP;
}
else {
push @stack => $::SELF->_make_dispatcher_iterator(@{$current_class->superclasses})
if $current_class->superclasses;
}
return $current_class;
}
return undef;
};
}));
$::Class->add_method('_make_descendant_dispatcher' => ::make_private_method(sub {
my @MRO = $::SELF->MRO();
return $::SELF->_make_dispatcher_iterator(reverse @MRO);
}));
$::Class->add_method('_make_ascendant_dispatcher' => ::make_private_method(sub {
my @MRO = $::SELF->MRO();
return $::SELF->_make_dispatcher_iterator(@MRO);
}));
$::Class->add_method('is_a' => ::make_method(sub {
my ($self, $class) = @_;
return 0 unless defined $class;
return 1 if ::opaque_instance_id($self) == ::opaque_instance_id($class);
my $dispatcher = $self->dispatcher(':canonical');
while (my $next = $dispatcher->()) {
return 1 if ::opaque_instance_id($next) eq ::opaque_instance_id($class);
}
return 0;
}));
$::Class->add_method('add_singleton_method' => ::make_method(sub {
my ($self, $label, $method) = @_;
# warn "hello from (CLASS) already eigened : $self";
::bind_method_to_class($method, $self);
$self->class->add_method($label, $method);
}));
$::Class->add_method('_get_method_table' => ::make_private_method(sub {
my ($self, $params) = @_;
# default to instance ...
$params->{for} = 'instance' if not exists $params->{for};
my $method_table;
if (lc($params->{for}) eq 'instance' ||
lc($params->{for}) eq 'submethod') {
return ::opaque_instance_attr($self => '%:methods');
}
elsif (lc($params->{for}) eq 'class') {
return ::opaque_instance_attr($self => '%:class_methods');
}
elsif (lc($params->{for}) eq 'private') {
return ::opaque_instance_attr($self => '%:private_methods');
}
else {
confess "There is no " . $params->{for} . " method table";
}
}));
$::Class->add_method('has_method' => ::make_method(sub {
my ($self, $label, %params) = @_;
$self->get_method($label, %params) ? 1 : 0;
}));
$::Class->add_method('get_method' => ::make_method(sub {
my ($self, $label, %params) = @_;
confess "You must provide a method label"
unless defined $label;
my $method_table = $self->_get_method_table(\%params);
return $method_table->{$label};
}));
$::Class->add_method('get_method_list' => ::make_method(sub {
my ($self, %params) = @_;
my $table = $self->_get_method_table(\%params);
return keys %{$table};
}));
$::Class->add_method('remove_method' => ::make_method(sub {
my ($self, $label, %params) = @_;
confess "You must provide a method label"
unless defined $label;
my $method_table = $self->_get_method_table(\%params);
delete $method_table->{$label};
}));
$::Class->add_method('add_attribute' => ::make_method(sub {
my ($self, $label, $attribute) = @_;
(defined $label && defined $attribute && blessed($attribute))
|| confess "InsufficientArguments : you must provide an attribute and a label";
#$self->_create_accessor($attribute);
if (blessed($attribute) eq 'Perl6::Attribute') {
::opaque_instance_attr($self => '%:attributes')->{$label} = $attribute;
}
else {
confess "I do not recognize the attribute type ($attribute)";
}
}));
$::Class->add_method('_get_attribute_table' => ::make_private_method(sub {
my ($self, $params) = @_;
# default to instance ...
$params->{for} = 'instance' if not exists $params->{for};
my $method_table;
if (lc($params->{for}) eq 'instance') {
return ::opaque_instance_attr($self => '%:attributes');
}
else {
confess "There is no " . $params->{for} . " attribute table";
}
}));
$::Class->add_method('get_attribute' => ::make_method(sub {
my ($self, $label, %params) = @_;
(defined $label)
|| confess "InsufficientArguments : you must provide a label";
my $table = $self->_get_attribute_table(\%params);
return $table->{$label};
}));
$::Class->add_method('has_attribute' => ::make_method(sub {
my ($self, $label, %params) = @_;
return $self->get_attribute($label, %params) ? 1 : 0;
}));
$::Class->add_method('get_attribute_list' => ::make_method(sub {
my ($self, %params) = @_;
my $table = $self->_get_attribute_table(\%params);
return keys %{$table};
}));
# "spec" here means "whatever annotation went with this attribute when it's declared"
$::Class->add_method('find_attribute_spec' => ::make_method(sub {
my ($self, $label, %params) = @_;
# go in BUILD order
my $dispatcher = $self->dispatcher(':descendant');
while (my $next = $dispatcher->()) {
return $next->get_attribute($label, %params)
if $next->has_attribute($label, %params)
}
return undef;
}));
# now add the $::Class attributes
$::Class->add_attribute('@:MRO' => ::make_attribute('@:MRO'));
$::Class->add_attribute('@:superclasses' => ::make_attribute('@:superclasses'));
$::Class->add_attribute('@:subclasses' => ::make_attribute('@:subclasses'));
$::Class->add_attribute('%:private_methods' => ::make_attribute('%:private_methods'));
$::Class->add_attribute('%:attributes' => ::make_attribute('%:attributes'));
$::Class->add_attribute('%:methods' => ::make_attribute('%:methods'));
$::Class->add_attribute('%:class_methods' => ::make_attribute('%:class_methods'));
## Now we make Class conform to the Package interface
$::Class->add_method('FETCH' => ::make_method(sub {
my ($self, $label) = @_;
(defined $label && $label)
|| confess "Cannot FETCH at (" . ($label || 'undef') . ")";
if ($label =~ /^\&(.*)$/) {
# check for instance method
return $self->has_method($1, for => 'instance') ?
$self->get_method($1, for => 'instance')
:
# check for class method
$self->class->has_method($1) ?
$self->class->get_method($1)
:
# if all else fails, maybe it is
# a sub, so we just grab it from
# the namespoace stash
::opaque_instance_attr($self => '%:namespace')->{$label};
}
# XXX -
# this reg-exp is probably not correct ...
elsif ($label =~ /^.(\.|\:).*$/) {
# check for instance attribute
return $self->has_attribute($label, for => 'instance') ?
$self->get_attribute($label, for => 'instance')
:
# class attributes are really just package
# variables with an "our" scope... so we
# just grab it from the namespoace stash
::opaque_instance_attr($self => '%:namespace')->{$label};
}
else {
# XXX -
# we need to duplicate the ::Package code here
# because calling next_METHOD here can be
# problematic since ::Class does not dispatch
# in the same way other classes do (this should
# be fixed at some point though, becuase it is
# actually wrong)
::opaque_instance_attr($self => '%:namespace')->{$label};
}
}));
$::Class->add_method('STORE' => ::make_method(sub {
my ($self, $label, $value) = @_;
(defined $label && $label)
|| confess "Cannot STORE at (" . ($label || 'undef') . ")";
# only store method objects,.. regular subs go in the namespace
if ($label =~ /^\&(.*)$/ && (blessed($value) && $value->isa('Perl6::Method'))) {
return $self->add_singleton_method($1, $value) if $value->isa('Perl6::ClassMethod');
return $self->add_method($1, $value);
}
# XXX -
# this reg-exp is probably not correct ...
elsif ($label =~ /^.(\.|\:).*$/ && (blessed($value) && $value->isa('Perl6::Attribute'))) {
# only store instance attributes with the meta model,
# class attributes are just package scoped "our" variables
# so they are added to the Package normally
return $self->add_attribute($label, $value);
}
else {
# XXX -
# we need to duplicate the ::Package code here
# because calling next_METHOD here can be
# problematic since ::Class does not dispatch
# in the same way other classes do (this should
# be fixed at some point though, becuase it is
# actually wrong)
if ($label =~ /^\&/ && ref($value) eq 'CODE') {
$value = ::wrap_package_sub($value, $self);
}
::opaque_instance_attr($self => '%:namespace')->{$label} = $value;
}
}));
1;
__END__
=pod
=head1 NAME
metamorph
=head1 DESCRIPTION
=head1 AUTHORS
Stevan Little E<lt>stevan@iinteractive.comE<gt>
=cut