Changeset 3373

Timestamp:

05/18/05 03:51:03 (4 years ago)

Author:

Stevan

svk:copy_cache_prev:

4945

Message:

Perl::MetaModel? - findMethod and invokeMethod methods coded and tested (and an isMethodSupported too); Smalltalk Meta-Model++

Location:

ext/Perl-MetaModel

Files:

• lib/Perl/Meta/Class.pm (modified) (1 diff)
• t/12_Perl_Meta_MetaClass_methods.t (modified) (3 diffs)

ext/Perl-MetaModel/lib/Perl/Meta/Class.pm

@@ -158 +158 @@
 }
 
-# can we remove these?
 method methods      ($self:) returns Hash  { %:methods        }
 method methodLabels ($self:) returns Array { %:methods.keys() }
 
 method findMethod ($self: $label) returns Perl::Meta::Method {
-
-}
-
-our &Perl::Meta::Class::isMethodSupported ::= &Perl::Meta::Class::findMethod;
-
-method invokeMethod ($self: Str $label, @args) returns Any {  
+    return %:methods{$label} if %:methods.exists($label);
+    return $:parent.findMethod($label) if $:parent.defined;
+    return undef;
+}
+
+method isMethodSupported ($self: $label) returns Bool {
+    $self.findMethod($label) ?? 1 :: 0;
+}
+
+method invokeMethod ($self: Str $label, *@args) returns Any {  
     my $method = $self.findMethod($label);
     ($method.defined)
         || die "Method not found";
     my $impl = $method.code();
+    ($impl.defined)
+        || die "Method has no code";    
     return $impl($self, @args);
 }

ext/Perl-MetaModel/t/12_Perl_Meta_MetaClass_methods.t

@@ -4 +4 @@
 use Test;
 
-plan 10;
+plan 25;
 
 use Perl::Meta::Class;
@@ -23 +23 @@
 
 my $method1 = Perl::Meta::Method.new();
-my $method2 = Perl::Meta::Method.new();
+my $method2 = Perl::Meta::Method.new(code => sub { 'Hello World' });
 
 $mmc.addMethod('method1', $method1);
 $mmc.addMethod('method2', $method2);
+
+ok($mmc.findMethod('method1') =:= $method1, '... found the right method');
+ok($mmc.findMethod('method2') =:= $method2, '... found the right method');
+
+ok(!$mmc.isMethodSupported('method3'), '... did not find the method (as expected)');
 
 {
@@ -50 +55 @@
     ok(%methods{'method1'} =:= $method1, '... the first is $method1');     
 }
+
+my $sub_mmc = Perl::Meta::Class::new('SubClass');
+$sub_mmc.superclass($mmc);
+
+$sub_mmc.addMethod('method2', $method2);
+
+ok($sub_mmc.isMethodSupported('method1'), '... did find the method in parent class');
+ok($sub_mmc.findMethod('method1') =:= $method1, '... found the right method (in parent class)');
+
+ok(!$mmc.isMethodSupported('method2'), '... did not find the method (as expected) in parent class');
+ok($sub_mmc.isMethodSupported('method2'), '... did find the method (as expected) in class');
+
+my $sub_sub_mmc = Perl::Meta::Class::new('SubSubClass');
+$sub_sub_mmc.superclass($sub_mmc);
+
+ok($sub_sub_mmc.isMethodSupported('method1'), '... did find the method in parents parent class');
+ok($sub_sub_mmc.findMethod('method1') =:= $method1, '... found the right method (in parents parent class)');
+ok($sub_sub_mmc.findMethod('method2'), '... did find the method (as expected) in parents class');
+
+# check some errors
+
+$!= undef; 
+dies_ok {
+    $mmc.invokeMethod('method2');
+}, '... this dies as expected';
+like($!, rx:perl5/^Method not found/, '... got the right error');
+
+$!= undef; 
+dies_ok {
+    $sub_sub_mmc.invokeMethod('method1');
+}, '... this dies as expected';
+like($!, rx:perl5/^Method has no code/, '... got the right error');
+
+is($sub_mmc.invokeMethod('method2'), 'Hello World', '... the method returned what we expected');