[mm] Implement superclasses

sorear · Sep 19, 2010 · a7ff91c · a7ff91c
1 parent c73de8d
commit a7ff91c
Showing 1 changed file with 43 additions and 10 deletions.
diff --git a/src/Metamodel.pm b/src/Metamodel.pm
@@ -67,6 +67,11 @@ our $global;
         die "method $name defined in a lowly package";
     }
 
+    sub add_super {
+        my ($self, $super) = @_;
+        die "superclass $super->name defined in a lowly package";
+    }
+
     no Moose;
     __PACKAGE__->meta->make_immutable;
 }
@@ -89,6 +94,8 @@ our $global;
         default => sub { [] });
     has methods => (isa => 'ArrayRef[Metamodel::Method]', is => 'ro',
         default => sub { [] });
+    has superclasses => (isa => 'ArrayRef[Metamodel::Class]', is => 'ro',
+        default => sub { [] });
 
     sub add_attribute {
         my ($self, $name, $accessor) = @_;
@@ -102,6 +109,11 @@ our $global;
         # TODO $accessor
     }
 
+    sub add_super {
+        my ($self, $targ) = @_;
+        push @{ $self->superclasses }, $targ;
+    }
+
     no Moose;
     __PACKAGE__->meta->make_immutable;
 }
@@ -200,17 +212,29 @@ our $global;
     has class    => (isa => 'Str', is => 'ro', default => 'Sub');
 
     sub find_pkg { my ($self, $names) = @_;
-        if (!ref($names) || @$names != 1) {
-            die "unimplemented form of find_pkg $names";
-        }
-        my $lex = $self->find_lex($names->[0]);
-        if (!$lex || !$lex->isa('Metamodel::Lexical::Stash')) {
-            die "$names->[0] is not declared as a package";
+        my $rns;
+        if (ref $names) {
+            if (@$names != 1) {
+                die "unimplemented form of find_pkg @$names";
+            }
+            my $lex = $self->find_lex($names->[0]);
+            if (!$lex || !$lex->isa('Metamodel::Lexical::Stash')) {
+                die "$names->[0] is not declared as a package";
+            }
+            if (!$lex->referent->obj) {
+                die "$names->[0] is an unresolved stub";
+            }
+            return $lex->referent->obj;
+        } else {
+            my $lex = $self->find_lex($names);
+            if (!$lex || !$lex->isa('Metamodel::Lexical::Stash')) {
+                die "$names is not declared as a package";
+            }
+            if (!$lex->referent->obj) {
+                die "$names is an unresolved stub";
+            }
+            return $lex->referent->obj;
         }
-        if (!$lex->referent->obj) {
-            die "$names->[0] is an unresolved stub";
-        }
-        return $lex->referent->obj;
     }
 
     sub find_lex { my ($self, $name) = @_;
@@ -319,6 +343,15 @@ sub Op::Attribute::begin {
     $ns->add_attribute($self->name, $self->accessor);
 }
 
+sub Op::Super::begin {
+    my $self = shift;
+    my $ns   = $opensubs[-1]->body_of // die ("superclass " . $self->name .
+        " declared outside of any class");
+    die "superclass $self->name declared in an augment"
+        if $opensubs[-1]->augmenting;
+    $ns->add_super($opensubs[-1]->find_pkg($self->name));
+}
+
 sub Op::SubDef::begin {
     my $self = shift;
     my $body = $self->body->begin;