Changeset 2912
- Timestamp:
- 05/10/05 03:01:51 (4 years ago)
- svk:copy_cache_prev:
- 4437
- Location:
- ext/Perl-MetaClass
- Files:
-
- 8 modified
-
lib/Hack/Instances.pm (modified) (1 diff)
-
lib/Perl/MetaAssoc.pm (modified) (1 diff)
-
lib/Perl/MetaClass.pm (modified) (2 diffs)
-
lib/Perl/MetaMethod.pm (modified) (2 diffs)
-
lib/Perl/MetaProperty.pm (modified) (2 diffs)
-
t/10_MetaClass.t (modified) (2 diffs)
-
t/11_MetaProperty.t (modified) (3 diffs)
-
t/12_MetaMethod.t (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
ext/Perl-MetaClass/lib/Hack/Instances.pm
r2903 r2912 25 25 26 26 sub instance_isa(Str $inst: Str $class) is export { 27 (%INSTANCES.exists($inst)) 28 || die "The instance '$inst' is not a valid instance (key not found)"; 27 return 0 unless %INSTANCES.exists($inst); 29 28 my (undef, $inv_class, undef) = split(';', $inst); 30 29 return ($inv_class eq $class); -
ext/Perl-MetaClass/lib/Perl/MetaAssoc.pm
r2911 r2912 89 89 # property end. 90 90 91 my $Property_mc = Perl::MetaClass ->new("Property");92 my $Class_mc = Perl::MetaClass ->new("Class");91 my $Property_mc = Perl::MetaClass::new("Property"); 92 my $Class_mc = Perl::MetaClass::new("Class"); 93 93 94 $Class_mc ->clsAssocs95 (properties => Perl::MetaAssoc ->new94 $Class_mc.clsAssocs 95 (properties => Perl::MetaAssoc::new 96 96 ( 97 97 assocOrdered => false, 98 assocRange => [0, inf],98 assocRange => [0, Inf], 99 99 assocCompanion => "class", 100 assocIsComposite => true,101 assocPair => Perl::MetaAssoc ->new100 assocIsComposite => 1, 101 assocPair => Perl::MetaAssoc::new 102 102 ( assocRange => [1, 1], 103 103 assocClass => $Property_mc ) -
ext/Perl-MetaClass/lib/Perl/MetaClass.pm
r2911 r2912 13 13 'name' => $name, 14 14 'super' => undef, 15 'subclasses' => [],15 'subclasses' => hash(), 16 16 'properties' => hash(), 17 17 'methods' => hash(), … … 54 54 my %self := get_instance($inv, "Perl::MetaClass"); 55 55 if @subclasses { 56 my %inv_subclasses = %self<subclasses>; 56 57 # NOTE: 57 58 # enforce the following rules on all @subclasses: 58 # - they are instances of Perl::MetaClass 59 # - they're superclass is our invocant 59 # - the subclass is an instance of Perl::MetaClass 60 # - if the subclass has a superclass, it's superclass is our invocant 61 # - if the invocant has a superclass, the subclass is not the superclass of our invocant 60 62 for @subclasses -> $subclass { 61 63 ($subclass.instance_isa('Perl::MetaClass')) 62 64 || die "Sub class must be a Perl::MetaClass instance (got: '$subclass')"; 63 65 ($subclass.clsSuper() && $subclass.clsSuper().clsName() eq $inv.clsName()) 64 || die "Sub class's superclass must be the invocant (got: '{ $subclass.clsSuper() }')"; 66 || die "Sub class's superclass must be the invocant (got: '{ $subclass.clsSuper() }')"; 67 ($subclass.clsName() ne $inv.clsSuper().clsName()) 68 || die "Subclass cannot be the superclass of the invocant" 69 if $inv.clsSuper(); 70 %inv_subclasses{$subclass} = undef; 65 71 } 66 # NOTE: 67 # this is kind of ugly, but I get a 68 # "can't modify constant" error otherwise 69 my @inv_subclasses = %self<subclasses>; 70 %self<subclasses> = [ @inv_subclasses, @subclasses ]; 72 %self<subclasses> = \%inv_subclasses; 71 73 } 72 return %self<subclasses>;74 return keys(%self<subclasses>); 73 75 } 74 76 -
ext/Perl-MetaClass/lib/Perl/MetaMethod.pm
r2904 r2912 5 5 use Hack::Instances; 6 6 7 sub Perl::MetaMethod::new(Code $sub ) returns Str is export {7 sub Perl::MetaMethod::new(Code $sub, Str +$visibility) returns Str is export { 8 8 my $id = make_instance("Perl::MetaMethod", { 9 'sub' => $sub, 10 'params' => [], 9 'sub' => $sub, 10 'params' => [], 11 'visibility' => 'public', 11 12 }); 13 $id.methodVisibility($visibility) if $visibility.defined; 12 14 return $id; 13 15 } … … 27 29 my %self := get_instance($inv, "Perl::MetaMethod"); 28 30 return %self<sub>(@args); 31 } 32 33 sub methodVisibility(Str $inv: Str ?$visibility) returns Str { 34 my %self := get_instance($inv, "Perl::MetaMethod"); 35 if $visibility.defined { 36 ($visibility ~~ rx:perl5:i/(private|public)/) 37 || die "Visibility must be either 'private' or 'public' (got: '$visibility')"; 38 %self<visibility> = lc($visibility); 39 } 40 return %self<visibility>; 29 41 } 30 42 -
ext/Perl-MetaClass/lib/Perl/MetaProperty.pm
r2910 r2912 9 9 'type' => $type, 10 10 'default' => undef, 11 'visibility' => undef,11 'visibility' => 'public', 12 12 }); 13 13 $id.propDefault($default) if $default.defined; … … 54 54 if $visibility.defined { 55 55 ($visibility ~~ rx:perl5:i/(private|public)/) 56 || die "Visibility must be either ' Private' of 'Public' (got: '$visibility')";57 %self<visibility> = $visibility;56 || die "Visibility must be either 'private' or 'public' (got: '$visibility')"; 57 %self<visibility> = lc($visibility); 58 58 } 59 59 return %self<visibility>; -
ext/Perl-MetaClass/t/10_MetaClass.t
r2909 r2912 23 23 # -------------------------------------------------------------- 24 24 25 my $ class= Perl::MetaClass::new('Role');25 my $role = Perl::MetaClass::new('Role'); 26 26 27 is($ class.clsName(), 'Role', '... we got the right class name');27 is($role.clsName(), 'Role', '... we got the right class name'); 28 28 29 29 # Super Class 30 30 31 my $ superclass= Perl::MetaClass::new('Package');31 my $package = Perl::MetaClass::new('Package'); 32 32 33 is($ class.clsSuper(), undef, '... we do not have a superclass');34 $ class.clsSuper($superclass);35 is($ class.clsSuper().clsName(), 'Package', '... we now have a superclass');33 is($role.clsSuper(), undef, '... we do not have a superclass'); 34 $role.clsSuper($package); 35 is($role.clsSuper().clsName(), 'Package', '... we now have a superclass'); 36 36 37 37 # Sub Classes 38 38 39 39 { 40 my @subclasses = $ class.clsSubClasses();40 my @subclasses = $role.clsSubClasses(); 41 41 is(+@subclasses, 0, '... no subclasses yet'); 42 42 } 43 43 44 my $ subclass1= Perl::MetaClass::new('Class');45 $ subclass1.clsSuper($class);44 my $class = Perl::MetaClass::new('Class'); 45 $class.clsSuper($role); 46 46 47 47 { 48 my @subclasses = $ class.clsSubClasses();48 my @subclasses = $role.clsSubClasses(); 49 49 is(+@subclasses, 1, '... we have 1 subclasses now'); 50 is(@subclasses[0].clsName(), ' Foo::Bar', '... this is our first subclass');50 is(@subclasses[0].clsName(), 'Class', '... this is our first subclass'); 51 51 } 52 53 dies_ok { 54 $class.clsSubClasses($role); 55 }, '... subclass cannot be the superclass of the invocant'; 56 like($!, rx:perl5/^Sub class\'s superclass must be the invocant/, '... got the right error'); 52 57 53 58 # Properties 54 59 55 60 { 56 my %props = $ class.clsProperties();61 my %props = $role.clsProperties(); 57 62 is(+keys(%props), 0, '... we have no properties yet'); 58 63 } … … 62 67 63 68 { 64 my %props = $ class.clsProperties('.prop1', $prop1, '.prop2', $prop2);69 my %props = $role.clsProperties('.prop1', $prop1, '.prop2', $prop2); 65 70 my @keys = keys(%props); 66 71 is(+@keys, 2, '... we have 2 properties now'); -
ext/Perl-MetaClass/t/11_MetaProperty.t
r2903 r2912 11 11 is($prop.propType(), 'Str', '... our property type is "Str"'); 12 12 is($prop.propDefault(), undef, '... our property default is not defined'); 13 is($prop.propVisibility(), 'public', '... our property by default is public'); 13 14 14 15 lives_ok { … … 20 21 21 22 is($prop.propDefault(), undef, '... our property default is now undefined since we changed types'); 23 is($prop.propVisibility(), 'public', '... our property is still public'); 22 24 23 25 dies_ok { 24 26 $prop.propDefault('Testing default'); 25 27 }, '... property default successfully'; 28 like($!, rx:perl5/^Incorrect Type value for property default/, '... got the right error'); 26 29 27 30 lives_ok { … … 38 41 }, '... we set the property default successfully'; 39 42 43 dies_ok { 44 $prop.propVisibility('invisible'); 45 }, '... property must be either public or private'; 46 like($!, rx:perl5/^Visibility must be either \'private\' or \'public\'/, '... got the right error'); 47 40 48 my $prop2; 41 49 lives_ok { 42 $prop2 = Perl::MetaProperty::new('Str', :default("Hello World") );43 }, '... set our default in the constructor successfully' 50 $prop2 = Perl::MetaProperty::new('Str', :default("Hello World"), :visibility<private>); 51 }, '... set our default in the constructor successfully'; 44 52 45 53 is($prop2.propType(), 'Str', '... our property type is "Str"'); 46 54 is($prop2.propDefault(), "Hello World", '... our property default is defined'); 55 is($prop2.propVisibility(), 'private', '... our property is private'); 56 57 -
ext/Perl-MetaClass/t/12_MetaMethod.t
r2904 r2912 8 8 my $method = Perl::MetaMethod::new(sub { return "Hello Meta-World" }); 9 9 is($method.methodInvoke(), 'Hello Meta-World', '... got the expected value from our method'); 10 is($method.methodVisibility(), 'public', '... by default it is public'); 10 11 11 12 { … … 19 20 is(~@params, '1 2 3', '... get have the right params'); 20 21 } 22 23 my $method2 = Perl::MetaMethod::new(sub { return "Hello (Private) Meta-World" }, :visibility<private>); 24 is($method2.methodVisibility(), 'private', '... this method is private'); 25 26 dies_ok { 27 $method2.methodVisibility('invisible'); 28 }, '... method must be either public or private'; 29 like($!, rx:perl5/^Visibility must be either \'private\' or \'public\'/, '... got the right error');
