Merge branch 'master' of github.com:perl6/roast

Author: skids

S02-names/pseudo.t

@@ -2,7 +2,7 @@ use v6;
 
 use Test;
 
-plan 142;
+plan 144;
 
 # I'm not convinced this is in the right place
 # Some parts of this testing (i.e. WHO) seem a bit more S10ish -sorear
@@ -412,4 +412,15 @@ my $x110 = 110; #OK
 
 # PARENT - NYI in any compiler
 
+# RT #123154
+{
+    my $x = 'really unlikely value';
+    ok MY::.values.grep({ ($_ // '') eq 'really unlikely value' }),
+        'MY::.values actually produces values';
+    {
+        ok OUTER::.values.grep({ ($_ // '') eq 'really unlikely value' }),
+            'OUTER::.values actually produces values';
+    }
+}
+
 # vim: ft=perl6

S02-types/bag.t

@@ -1,7 +1,7 @@
 use v6;
 use Test;
 
-plan 197;
+plan 199;
 
 sub showkv($x) {
     $x.keys.sort.map({ $^k ~ ':' ~ $x{$k} }).join(' ')
@@ -454,17 +454,6 @@ sub showkv($x) {
     is $e.fmt('%s,%s',':'), "", '.fmt(%s%s,sep) works (empty)';
 }
 
-{
-    my $b = <a b c>.Bag;
-    #?rakudo.jvm    todo "?"
-    throws-like { $b.pairs[0].key++ },
-      X::Parameter::RW,
-      'Cannot change key of Bag.pairs';
-    throws-like { $b.pairs[0].value++ },
-      Exception,  # no exception type yet
-      'Cannot change value of Bag.pairs';
-}
-
 #?rakudo todo 'we have not secured .WHICH creation yet RT #124454'
 {
         isnt 'a(1) Str|b(1) Str|c'.Bag.WHICH, <a b c>.Bag.WHICH,
@@ -492,4 +481,23 @@ sub showkv($x) {
     is showkv($b), 'a:5 b:1 foo:2', '...with the right elements';
 }
 
+{
+    my $b = <a>.Bag;
+    throws-like { $b<a> = 42 },
+      X::Assignment::RO,
+      'Make sure we cannot assign on a key';
+
+    throws-like { $_ = 666 for $b.values },
+     X::AdHoc,   # X::Assignment::RO ???
+      'Make sure we cannot assign on a .values alias';
+
+    throws-like { .value = 999 for $b.pairs },
+      X::Assignment::RO,
+      'Make sure we cannot assign on a .pairs alias';
+
+    throws-like { for $b.kv -> \k, \v { v = 22 } },
+      X::Assignment::RO,
+      'Make sure we cannot assign on a .kv alias';
+}
+
 # vim: ft=perl6

S02-types/baghash.t

@@ -1,7 +1,7 @@
 use v6;
 use Test;
 
-plan 246;
+plan 254;
 
 # L<S02/Mutable types/QuantHash of UInt>
 
@@ -532,3 +532,32 @@ sub showkv($x) {
     ok $b3.elems == 0,
         'named argument is happily eaten by .new method';
 }
+
+{
+    my $b = <a>.BagHash;
+    $b<a> = 42;
+    is $b<a>, 42, 'did we set an Int value';
+    throws-like { $b<a> = "foo" },
+      X::Multi::NoMatch, # X::TypeCheck::Assignment ???
+      'Make sure we cannot assign Str on a key';
+
+    $_ = 666 for $b.values;
+    is $b<a>, 666, 'did we set an Int value from a .values alias';
+    throws-like { $_ = "foo" for $b.values },
+      X::TypeCheck::Assignment,
+      'Make sure we cannot assign Str on a .values alias';
+
+    .value = 999 for $b.pairs;
+    is $b<a>, 999, 'did we set an Int value from a .pairs alias';
+    throws-like { .value = "foo" for $b.pairs },
+      X::TypeCheck::Assignment,
+      'Make sure we cannot assign Str on a .pairs alias';
+
+    for $b.kv -> \k, \v { v = 22 };
+    is $b<a>, 22, 'did we set an Int value from a .kv alias';
+    throws-like { for $b.kv -> \k, \v { v = "foo" } },
+      X::TypeCheck::Assignment,
+      'Make sure we cannot assign Str on a .kv alias';
+}
+
+# vim: ft=perl6

S02-types/mix.t

@@ -1,7 +1,7 @@
 use v6;
 use Test;
 
-plan 178;
+plan 180;
 
 sub showkv($x) {
     $x.keys.sort.map({ $^k ~ ':' ~ $x{$k} }).join(' ')
@@ -410,21 +410,29 @@ sub showkv($x) {
     is $e.fmt('%s,%s',':'), "", '.fmt(%s%s,sep) works (empty)';
 }
 
-{
-    my $m = <a b c>.Mix;
-    #?rakudo.jvm    todo "?"
-    throws-like { $m.pairs[0].key++ },
-      X::Parameter::RW,
-      'Cannot change key of Mix.pairs';
-    throws-like { $m.pairs[0].value++ },
-      Exception,
-      'Cannot change value of Mix.pairs';
-}
-
 #?rakudo todo 'we have not secured .WHICH creation yet RT #124496'
 {
     isnt 'a(1) Str|b(1) Str|c'.Mix.WHICH, <a b c>.Mix.WHICH, 
       'Faulty .WHICH creation';
 }
 
+{
+    my $m = <a>.Mix;
+    throws-like { $m<a> = 42.1 },
+      X::Assignment::RO,
+      'Make sure we cannot assign on a key';
+
+    throws-like { $_ = 666.1 for $m.values },
+      X::AdHoc,  # X::Assignment::RO  ???
+      'Make sure we cannot assign on a .values alias';
+
+    throws-like { .value = 999.1 for $m.pairs },
+      X::Assignment::RO,
+      'Make sure we cannot assign on a .pairs alias';
+
+    throws-like { for $m.kv -> \k, \v { v = 22.1 } },
+      X::Assignment::RO,
+      'Make sure we cannot assign on a .kv alias';
+}
+
 # vim: ft=perl6

S02-types/mixhash.t

@@ -1,7 +1,7 @@
 use v6;
 use Test;
 
-plan 209;
+plan 217;
 
 # L<S02/Mutable types/QuantHash of UInt>
 
@@ -450,4 +450,31 @@ sub showkv($x) {
     is $e.fmt('%s,%s',':'), "", '.fmt(%s%s,sep) works (empty)';
 }
 
+{
+    my $m = <a>.MixHash;
+    $m<a> = 42.1;
+    is $m<a>, 42.1, 'did we set a Real value';
+    throws-like { $m<a> = "foo" },
+      X::Str::Numeric, # X::TypeCheck::Assignment ???
+      'Make sure we cannot assign Str on a key';
+
+    $_ = 666.1 for $m.values;
+    is $m<a>, 666.1, 'did we set a Real value from a .values alias';
+    throws-like { $_ = "foo" for $m.values },
+      X::TypeCheck::Assignment,
+      'Make sure we cannot assign Str on a .values alias';
+
+    .value = 999.1 for $m.pairs;
+    is $m<a>, 999.1, 'did we set a Real value from a .pairs alias';
+    throws-like { .value = "foo" for $m.pairs },
+      X::TypeCheck::Assignment,
+      'Make sure we cannot assign Str on a .pairs alias';
+
+    for $m.kv -> \k, \v { v = 22.1 };
+    is $m<a>, 22.1, 'did we set a Real value from a .kv alias';
+    throws-like { for $m.kv -> \k, \v { v = "foo" } },
+      X::TypeCheck::Assignment,
+      'Make sure we cannot assign Str on a .kv alias';
+}
+
 # vim: ft=perl6

S02-types/pair.t

@@ -2,14 +2,15 @@ use v6;
 
 use Test;
 
-plan 3 * 19 + 94;
+plan 4 * 19 + 100;
 
 # L<S02/Mutable types/A single key-to-value association>
 # basic Pair
 
 for
   foo => "bar",                     'fat-comma',
-  Pair.new(:key<foo>, :value<bar>), 'Pair.new',
+  Pair.new(:key<foo>, :value<bar>), 'Pair.new(:key,:value)',
+  Pair.new("foo", "bar"),           'Pair.new(key,value)',
   pair("foo","bar"),                'pair()'
 -> $pair, $type {
     diag "checking $type";
@@ -360,4 +361,20 @@ Note, "non-chaining binary" was later renamed to "structural infix".
     is ((1|2|3) => 1&2&3).gist, 'any(1, 2, 3) => all(1, 2, 3)', "both key and value can convey a Junction object";
 }
 
+{
+    my $p = Pair.new("foo",my Int $);
+    isa-ok $p.value, Int;
+    is ($p.value = 42), 42, 'can assign integer value and return that';
+    is $p.value, 42, 'the expected Int value was set';
+    throws-like { $p.value = "bar" },
+      X::TypeCheck::Assignment,
+      'cannot assign a Str to an Int';
+
+    $p.freeze;
+    throws-like { $p.value = 666 },
+      X::Assignment::RO,
+      'cannot assign an Int to a frozen';
+    is $p.value, 42, 'did not change integer value';
+}
+
 # vim: ft=perl6

S04-phasers/enter-leave.t

@@ -5,7 +5,7 @@ use Test;
 use lib 't/spec/packages';
 use Test::Util;
 
-plan 28;
+plan 30;
 
 # L<S04/Phasers/ENTER "at every block entry time">
 # L<S04/Phasers/LEAVE "at every block exit time">
@@ -182,14 +182,14 @@ plan 28;
 # RT #121530
 #?niecza todo '@!'
 #?rakudo.jvm todo 'unwind, RT #121530'
-#?rakudo.moar todo 'unwind, RT #121530'
 {
     my $str;
     try {
         LEAVE { $str ~= '1' }
         LEAVE { $str ~= '2'; die 'foo' }
     }
     is $str, '21', 'die doesn\'t abort LEAVE queue';
+    is $!.message, 'foo', 'single exception from LEAVE is rethrown after running LEAVEs';
 }
 
 # RT #113548
@@ -265,4 +265,13 @@ plan 28;
     is doit(), 'ls', 'return in nested block with LEAVE works';
 }
 
+{
+    sub foo() {
+        LEAVE die 'wtf';
+        LEAVE die 'omg';
+    }
+    throws-like { foo() }, X::PhaserExceptions,
+        exceptions => sub (@ex) { @ex>>.message ~~ <omg wtf> };
+}
+
 # vim: ft=perl6

S12-methods/fallback.t

@@ -56,11 +56,11 @@ is F.new.something(''), 'Str', 'Can multi-dispatch on regular arguments (also on
 dies-ok { F.something() }, 'Error when none of the candidates match';
 
 class I {
-    method postcircumfix:<( )>(|) { 'invaught' }
+    method CALL-ME { 'invaught' }
     method FALLBACK($name, |c) { 'yes, I work' }
 }
 my $i = I.new;
-is $i.spy, 'yes, I work', 'FALLBACK is effective with a postcircumfix:<( )>';
-is $i(), 'invaught', 'postcircumfix:<( )> beats FALLBACK';
+is $i.spy, 'yes, I work', 'FALLBACK is effective with a CALL-ME';
+is $i(), 'invaught', 'CALL-ME beats FALLBACK';
 
 # vim: ft=perl6

S13-overloading/operators.t

@@ -1,7 +1,7 @@
 use v6;
 use Test;
 
-plan 5;
+plan 6;
 
 #L<S06/Operator overloading>
 
@@ -23,14 +23,16 @@ plan 5;
 }
 
 {
+    my @keys;
     class A does Associative {
-        method postcircumfix:<{ }>(*@ix) {   # METHOD TO SUB CASUALTY
-            return @ix
+        multi method AT-KEY(A:D: $key) {
+            push @keys, $key;
+            ++state $i
         }
     };
 
-    #?rakudo skip 'cannot easily override {} at the moment'
-    is A.new<foo bar>, <foo bar>, 'defining postcircumfix:<{ }> works';
+    is A.new<foo bar>, (1, 2), 'implementing AT-KEY gets {...} indexing working';
+    is @keys, [<foo bar>], 'AT-KEY called once for each key';
 }
 
 # overloaded invoke
@@ -41,7 +43,7 @@ plan 5;
 {
     class B {
         has $.x;
-        method postcircumfix:<( )>($y) {
+        method CALL-ME($y) {
             $.x ~ $y;
         }
     }