Merge pull request #620 from perl6/rakudo_3495

Add tests for `is rw` trait on roles

S12-class/rw.t

@@ -2,28 +2,29 @@ use v6;
 
 use Test;
 
-plan 5;
+plan 3;
 
 # L<S12/Attributes/If you declare the class as>
 
-class Foo {
-    has $.readonly_attr;
-}
-
-{
+subtest "Basic sanity" => {
+    plan 1;
+    my class Foo {
+        has $.readonly_attr;
+    }
     my Foo $foo .= new;
-    dies-ok { $foo.readonly_attr++ }, "basic sanity";
+    dies-ok { $foo.readonly_attr++ }, "the default is readonly";
 }
 
+subtest "'is rw' on a class" => {
+    plan 4;
 
-class Bar is rw {
-    has $.readwrite_attr;
-    has $.but_not_this is readonly;
-}
+    my class Bar is rw {
+        has $.readwrite_attr;
+        has $.but_not_this is readonly;
+    }
 
-{
     my Bar $bar .= new(but_not_this => 42);
-    
+
     lives-ok { $bar.readwrite_attr++ },
         "'is rw' on the class declaration applies to all attributes (1)";
     is $bar.readwrite_attr, 1,
@@ -35,4 +36,23 @@ class Bar is rw {
         "'is readonly' on a specific attribute can overrule the is rw on the class (2)";
 }
 
+subtest "With 'also is rw'" => {
+    plan 6;
+
+    my class C {
+        has $.a;
+        has $.a-ro is readonly;
+        also is rw;
+        has $.b;
+    }
+
+    my $obj = C.new( a => 12, a-ro => 42, b => 1 );
+    lives-ok { $obj.a++ }, "'also is rw' is being respected as class default";
+    is $obj.a, 13, "attribute value has been changed";
+    lives-ok { $obj.b-- }, "post-'also is rw' attribute is writable";
+    is $obj.b, 0, "post-'also is rw' attribute value changed";
+    dies-ok { $obj.a-ro++ }, "'is readonly' is not altered";
+    is $obj.a-ro, 42, "readonly attribute value unchanged";
+}
+
 # vim: ft=perl6

S14-roles/rw.t

@@ -0,0 +1,73 @@
+use v6;
+use Test;
+
+plan 6;
+
+role R1 is rw {
+    has $.r1;
+    has $.r1-ro is readonly;
+}
+
+sub test-R1(Mu \type, Str $msg?) {
+    my $title = $msg // "rw/ro";
+    subtest $title => {
+        plan 4;
+        my $obj = type.new(r1 => 41, r1-ro => 12);
+
+        lives-ok { $obj.r1++ }, "'is rw' on a role is being repsected";
+        is $obj.r1, 42, "attribute value has really changed";
+        dies-ok { $obj.r1-ro++ }, "'is readonly' overrides 'is rw' on role";
+        is $obj.r1-ro, 12, "read only attribute didn't change";
+    }
+}
+
+subtest "Default is readonly" => {
+    plan 4;
+
+    my role R2 {
+        has $.r2;
+    }
+
+    dies-ok { R2.new.r2 = 0 }, "pun of a role preserves default readonly";
+    my role R3 does R2 { }
+    dies-ok { R3.new.r2 = 0 }, "pun of a role doing role preserves default readonly";
+    my class C1 does R2 { }
+    dies-ok { C1.new.r2 = 0 }, "class consuming a role repsects default readonly";
+    my class C2 does R3 { }
+    dies-ok { C2.new.r2 = 0 }, "class consuming a role doing a role repsects default readonly";
+}
+
+subtest "Puning" => {
+    plan 1;
+    test-R1 R1;
+}
+
+subtest "Pun of a role doing role" => {
+    plan 1;
+    my role R3 does R1 { };
+    test-R1 R3;
+}
+
+subtest "Class consuming role" => {
+    plan 1;
+    my class C1 does R1 { }
+    test-R1 C1;
+}
+
+subtest "Class consuming role doing a role" => {
+    plan 1;
+    my role R3 does R1 { }
+    my class C2 does R3 { }
+    test-R1 C2;
+}
+
+subtest "use 'also is rw'" => {
+    my role R3 {
+        has $.r1;
+        also is rw;
+        has $.r1-ro is readonly;
+    }
+    test-R1 R3, "role puning";
+    my role R4 does R3 { }
+    test-R1 R4, "role doing role puning";
+}

spectest.data

@@ -731,6 +731,7 @@ S14-roles/instantiation.t
 S14-roles/lexical.t
 S14-roles/mixin.t
 S14-roles/namespaced.t
+S14-roles/rw.t
 S14-roles/parameterized-basic.t
 S14-roles/parameterized-mixin.t
 S14-roles/parameterized-type.t