Changeset 6792

Timestamp:

09/06/05 13:05:40 (3 years ago)

Author:

Stevan

Message:

Perl6::MetaModel? 2.0 -
* added $::Module into the hierarchy, now:

$::Class->isa($::Module) && $::Class->isa($::Object)

* moved name, version, authority and identifier methods

to $::Module

• adjusted tests and files appropriately

Location:

perl5/Perl6-MetaModel2.0

Files:

• lib/genesis.pl (modified) (1 diff)
• lib/gnosis.pl (modified) (1 diff)
• lib/metamorph.pl (modified) (2 diffs)
• t/03_metamorph.t (modified) (4 diffs)
• t/05_genesis.t (modified) (3 diffs)
• t/06_bootstrapped.t (modified) (3 diffs)
• t/07_Perl6_MetaModel.t (modified) (2 diffs)

perl5/Perl6-MetaModel2.0/lib/genesis.pl

@@ -6 +6 @@
 BEGIN { do "lib/pneuma.pl" };
 
+## Now create some of the other things we need ...
+
+## ----------------------------------------------------------------------------
+## Module
+
+$::Module = $::Class->new('$:name' => 'Module');
+
+$::Module->superclasses([ $::Object ]);
+
+$::Module->add_attribute('$:name'       => ::make_attribute('$:name'));
+$::Module->add_attribute('$:version'    => ::make_attribute('$:version'));
+$::Module->add_attribute('$:authority'  => ::make_attribute('$:authority'));
+
+$::Module->add_method('name' => ::make_method(sub {
+    my $self = shift;
+    ::opaque_instance_attrs($self)->{'$:name'} = shift if @_;        
+    ::opaque_instance_attrs($self)->{'$:name'};
+}, $::Module));
+
+$::Module->add_method('version' => ::make_method(sub {
+    my ($self, $version) = @_;
+    if (defined $version) {
+        ($version =~ /^\d+\.\d+\.\d+$/)
+            || confess "The version ($version) is not in the correct format '0.0.0'";
+        ::opaque_instance_attrs($self)->{'$:version'} = $version;
+    }
+    ::opaque_instance_attrs($self)->{'$:version'};    
+}, $::Module));
+
+$::Module->add_method('authority' => ::make_method(sub {
+    my $self = shift;
+    ::opaque_instance_attrs($self)->{'$:authority'} = shift if @_;        
+    ::opaque_instance_attrs($self)->{'$:authority'};
+}, $::Module));
+
+$::Module->add_method('identifier' => ::make_method(sub {
+    return join '-' => ($::SELF->name, $::SELF->version, ($::SELF->authority || ()));
+}, $::Module));
+
 # ... this makes ::Class a subclass of ::Object
 # the result of this is (Theos)
 
 # < Class is a subclass of Object >
-::opaque_instance_attrs($::Class)->{'@:superclasses'} = [ $::Object ];
+::opaque_instance_attrs($::Class)->{'@:superclasses'} = [ $::Module, $::Object ];
 
-::opaque_instance_attrs($::Class)->{'@:MRO'} = [ $::Class, $::Object ];
+# NOTE:
+# this is to avoid recursion
+::opaque_instance_attrs($::Class)->{'@:MRO'} = [ $::Class, $::Module, $::Object ];
 ::opaque_instance_attrs($::Object)->{'@:MRO'} = [ $::Object ];
 
+## ----------------------------------------------------------------------------
+## Role
+
+$::Role = $::Class->new('$:name' => 'Role');
+
+$::Role->superclasses([ $::Module ]);
+
+$::Role->add_attribute('@:subroles'   => ::make_attribute('@:subroles'));
+$::Role->add_attribute('%:methods'    => ::make_attribute('%:methods'));
+$::Role->add_attribute('%:attributes' => ::make_attribute('%:attributes'));
+
+$::Role->add_method('add_method' => ::make_method(sub {
+    my ($self, $label, $method) = @_;
+    # NOTE: 
+    # the $method here can be undefined, this is to allow
+    # for methods which do not have an implementation. These
+    # methods are then required to be implemented by the 
+    # composing class.
+    # (see A12/Class Composition with Roles/Declaration of Roles/Interfaces)
+    ::opaque_instance_attrs($self)->{'%:methods'}->{$label} = $method;
+}, $::Role));
+
+$::Role->add_method('get_method_list' => ::make_method(sub {
+    keys %{::opaque_instance_attrs($::SELF)->{'%:methods'}};
+}, $::Role));
+
+$::Role->add_method('add_attribute' => ::make_method(sub {
+    my ($self, $label, $attribute) = @_;
+    ::opaque_instance_attrs($self)->{'%:attributes'}->{$label} = $attribute;
+}, $::Role));
+
+$::Role->add_method('get_attribute_list' => ::make_method(sub {
+    keys %{::opaque_instance_attrs($::SELF)->{'%:attributes'}};
+}, $::Role));
+
+$::Role->add_method('subroles' => ::make_method(sub {
+    my $self = shift;
+    ::opaque_instance_attrs($self)->{'@:subroles'} = shift if @_;
+    ::opaque_instance_attrs($self)->{'@:subroles'};
+}, $::Role));
+
+$::Role->add_method('does' => ::make_method(sub {
+    my $self = shift;
+    if (my $role_name = shift) {
+        foreach (@{::opaque_instance_attrs($self)->{'@:subroles'}}) {
+            return 1 if $_->name eq $role_name;            
+        }
+        return 0;
+    }
+    return map { $_->name } @{::opaque_instance_attrs($self)->{'@:subroles'}};
+}, $::Role));
+
+
 1;

perl5/Perl6-MetaModel2.0/lib/gnosis.pl

@@ -16 +16 @@
         (
             # meta-information
-            '$:name'             => $attrs{'$:name'}      || undef,
-            '$:version'          => $attrs{'$:version'}   || '0.0.0',
-            '$:authority'        => $attrs{'$:authority'} || undef,
+            '$:name'             => $attrs{'$:name'} || undef,
             # the guts
             '@:MRO'              => [],

perl5/Perl6-MetaModel2.0/lib/metamorph.pl

@@ -99 +99 @@
     ::opaque_instance_attrs($self)->{'$:name'} = shift if @_;        
     ::opaque_instance_attrs($self)->{'$:name'};
-}, $::Class));
-
-$::Class->add_method('version' => ::make_method(sub {
-    my ($self, $version) = @_;
-    if (defined $version) {
-        ($version =~ /^\d+\.\d+\.\d+$/)
-            || confess "The version ($version) is not in the correct format '0.0.0'";
-        ::opaque_instance_attrs($self)->{'$:version'} = $version;
-    }
-    ::opaque_instance_attrs($self)->{'$:version'};    
-}, $::Class));
-
-$::Class->add_method('authority' => ::make_method(sub {
-    my $self = shift;
-    ::opaque_instance_attrs($self)->{'$:authority'} = shift if @_;        
-    ::opaque_instance_attrs($self)->{'$:authority'};
-}, $::Class));
-
-$::Class->add_method('identifier' => ::make_method(sub {
-    return join '-' => ($::SELF->name, $::SELF->version, ($::SELF->authority || ()));
 }, $::Class));
 
@@ -389 +369 @@
 
 $::Class->add_attribute('$:name'             => ::make_attribute('$:name'));
-$::Class->add_attribute('$:version'          => ::make_attribute('$:version'));
-$::Class->add_attribute('$:authority'        => ::make_attribute('$:authority'));
 $::Class->add_attribute('@:MRO'              => ::make_attribute('@:MRO'));
 $::Class->add_attribute('@:superclasses'     => ::make_attribute('@:superclasses'));

perl5/Perl6-MetaModel2.0/t/03_metamorph.t

@@ -4 +4 @@
 use warnings;
 
-use Test::More tests => 88;
+use Test::More tests => 72;
 use Test::Exception;
 
@@ -28 +28 @@
     $::Class->name;
 } 'Class', '... got the name we expected';
-
-lives_ok_and_is {
-    $::Class->version;
-} '0.0.0', '... got the version we expected';
-
-lives_ok_and_is {
-    $::Class->authority;
-} undef, '... got the authority we expected';
-
-lives_ok_and_is {
-    $::Class->identifier;
-} 'Class-0.0.0', '... got the identifier we expected';
 
 lives_ok_and_is {
@@ -86 +74 @@
 # check public methods
 foreach my $method_name (qw(name
-                            version
-                            authority
-                            identifier
                             superclasses
                             MRO
@@ -120 +105 @@
 }
 
-my @attribute_name_list = ('$:name',
-                           '$:version',      
-                           '$:authority',        
+my @attribute_name_list = ('$:name',       
                            '@:MRO',              
                            '@:superclasses',    

perl5/Perl6-MetaModel2.0/t/05_genesis.t

@@ -4 +4 @@
 use warnings;
 
-use Test::More tests => 28;
+use Test::More tests => 47;
 use Test::Exception; 
 
@@ -11 +11 @@
 is_deeply(
     $::Class->superclasses, 
-    [ $::Object ], 
-    '... $::Class->superclasses() is $::Object');
+    [ $::Module, $::Object ], 
+    '... $::Class->superclasses() is [ $::Module, $::Object ]');    
 
 is_deeply(
@@ -21 +21 @@
 is_deeply(
     [ $::Class->MRO() ], 
-    [ $::Class, $::Object ], 
-    '... $::Class->MRO() is ($::Class, $::Object)');    
+    [ $::Class, $::Module, $::Object ], 
+    '... $::Class->MRO() is ($::Class, $::Module, $::Object)');    
+
+ok($::Class->is_a('Module'), '... $::Class->is_a(Module)');
+ok($::Class->isa('Module'), '... $::Class->isa(Module)');
 
 ok($::Class->is_a('Object'), '... $::Class->is_a(Object)');
 ok($::Class->isa('Object'), '... $::Class->isa(Object)');
 
-# can call all of Object's class methods ...
-foreach my $method_name (qw(new bless CREATE isa can)) {
+ok($::Object->is_a('Object'), '... $::Object->is_a(Object)');
+ok($::Object->isa('Object'), '... $::Object->isa(Object)');
+
+ok($::Module->is_a('Object'), '... $::Module->is_a(Object)');
+ok($::Module->isa('Object'), '... $::Module->isa(Object)');
+
+# Module can call all of Modules's methods and all of Object's ...
+foreach my $method_name (qw(name version authority identifier
+                            BUILD BUILDALL DESTROYALL isa can)) {
+    ok($::Module->can($method_name), '... Module->can(' . $method_name . ')');
+}
+
+# Class can call all of Modules's methods ...
+foreach my $method_name (qw(name version authority identifier)) {
     ok($::Class->can($method_name), '... Class->can(' . $method_name . ')');
 }
 
-# can call all of Object's instance methods as well ...
+# Object can call all of Modules's methods ...
+foreach my $method_name (qw(name version authority identifier)) {
+    ok($::Object->can($method_name), '... Object->can(' . $method_name . ')');
+}
+
+# can call all of Object's methods as well ...
 foreach my $method_name (qw(BUILD BUILDALL DESTROYALL isa can)) {
     ok($::Class->can($method_name), '... Class->can(' . $method_name . ')');
 }
 
-# now call some Object methods
-
-ok($::Object->isa('Object'), '... Object->isa(Object)');
-
-foreach my $method_name (qw(new bless CREATE isa can)) {
-    ok($::Object->can($method_name), '... Object->can(' . $method_name . ')');
-}
+# now create an Object
 
 my $iObject = $::Object->new();
 ok($iObject->isa('Object'), '... iObject->isa(Object)');
 
-is($iObject->id, 3, '... $iObject is the third object in the system');
+cmp_ok($iObject->id, '>', 3, '... $iObject is at least the third object in the system');
 
 foreach my $method_name (qw(BUILD BUILDALL DESTROYALL isa can)) {
     ok($iObject->can($method_name), '... iObject->can(' . $method_name . ')');
 }
+
+# now create a Module
+
+# now create an Object
+
+my $MyModule = $::Module->new();
+ok($MyModule->isa('Module'), '... MyModule->isa(Module)');
+ok($MyModule->isa('Object'), '... MyModule->isa(Object)');
+
+cmp_ok($MyModule->id, '>', 3, '... $MyModule is the at least the third object in the system');
+
+# Module can call all of Modules's methods and all of Object's ...
+foreach my $method_name (qw(name version authority identifier)) {
+    ok($MyModule->can($method_name), '... MyModule->can(' . $method_name . ')');
+}
+
+
+

perl5/Perl6-MetaModel2.0/t/06_bootstrapped.t

@@ -4 +4 @@
 use warnings;
 
-use Test::More tests => 14;
+use Test::More tests => 18;
 use Test::Exception; 
 
@@ -14 +14 @@
 is($Foo->name, 'Foo', '... Foo->name == Foo');
 is($Foo->version, '0.0.1', '... Foo->version == 0.0.1');
+is($Foo->authority, undef, '... Foo->authority == undef');
+
+is($Foo->identifier, 'Foo-0.0.1', '... Foo->identifier == Foo-0.0.1');
 
 lives_ok {
@@ -33 +36 @@
 # Now try to create a new class ....
 
-my $Bar = $::Class->new('$:name' => 'Bar', '$:version' => '0.0.1');
+my $Bar = $::Class->new('$:name' => 'Bar', '$:version' => '0.0.1', '$:authority' => 'cpan:JRANDOM');
 is($Bar->name, 'Bar', '... Bar->name == Bar');
 is($Bar->version, '0.0.1', '... Bar->version == 0.0.1');
+is($Bar->authority, 'cpan:JRANDOM', '... Bar->authority == cpan:JRANDOM');
+
+is($Bar->identifier, 'Bar-0.0.1-cpan:JRANDOM', '... Bar->identifier == Bar-0.0.1-cpan:JRANDOM');
 
 lives_ok {

perl5/Perl6-MetaModel2.0/t/07_Perl6_MetaModel.t

@@ -4 +4 @@
 use warnings;
 
-use Test::More tests => 26;
+use Test::More tests => 27;
 use Test::Exception; 
 
@@ -12 +12 @@
 ok($::Object->isa('Object'), '... genesis was loaded ok');
 ok($::Class->isa('Class'), '... genesis was loaded ok');
+ok($::Class->isa('Module'), '... genesis was loaded ok');
 ok($::Class->isa('Object'), '... genesis was loaded ok');
 is_deeply(
     $::Class->superclasses,
-    [ $::Object ],
+    [ $::Module, $::Object ],
     '... genesis was loaded ok');