Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2322 lines (1944 sloc) 67.49 kb
# vim: ft=perl6
use Test;
plan 1007;
ok 1, "one is true";
ok 2, "two is also true";
ok !(0), "zero is false";
ok 2 + 2 == 4, "two and two makes four";
{
my $x = 2 + 2;
ok $x == 4, "two and two can be stored in a variable";
}
ok 2 < 3, "two is less than three";
ok !(3 < 1), "three is not less than one";
ok 42 / 3 == 14, "division comes out in the right order";
{
my $x = 2;
ok (--$x) == 1, "predecrement returns new value";
ok $x == 1, "value clearly decremented";
ok ($x++) == 1, "postincrement returns old";
ok $x == 2, "but value increased";
}
{
my $x = 2;
my $y := $x;
ok $y == 2, "binding shares old value";
$x = 5;
ok $y == 5, "changing old changes new";
$y = 4;
ok $y == 4, "changing new changes old";
}
{
sub fib($n) {
if $n <= 2 {
1
} else {
fib($n - 1) + fib($n - 2);
}
}
ok fib(10) == 55, "recursion works";
}
{
my $n = 9;
my $a = 1;
my $b = 1;
while --$n >= 0 {
my $c = $a + $b;
$a = $b;
$b = $c;
}
ok $a == 55, "looping works";
}
{
sub foo() { 42 }
ok (foo) == 42, "can call argless function without parens";
}
ok !Cool, "undefined type objects are false";
ok !Cool.defined, "type objects are undefined";
ok "Foo".defined, "strings are defined";
ok !Str.defined, "derived type objects are still undefined";
ok "foo" eq "foo", "equal strings are equal";
ok !("foo" ne "foo"), "equal strings are not not equal";
ok "foo" ne "bar", "unequal strings are unequal";
ok Cool === Cool, "identical objects are identical";
ok !(Cool === Any), "unidentical objects are unidentical";
ok 12 eq "12", "eq stringifies";
ok ("a" ~ "b") eq "ab", "a + b = ab";
ok ("a" ~ "b" ~ "c") eq "abc", "a + b + c = abc";
ok (?1) eq "True", "True strings to True";
ok (?0) eq "False", "False strings to False";
ok False ~~ Bool && !False, "False is the right constant";
ok True ~~ Bool && True, "True is the right constant";
ok Bool::False ~~ Bool && !Bool::False, "Bool::False is the right constant";
ok Bool::True ~~ Bool && Bool::True, "Bool::True is the right constant";
ok Any.gist eq "Any()", "Any.gist is Any()";
ok (2.WHAT === 3.WHAT), "different objects get the same WHAT";
ok !(2.WHAT.defined), "WHATs are undefined type objects";
ok (sub foo() {}).WHAT.gist eq 'Sub()', 'WHAT of a Sub is Sub()';
ok "Foo".WHAT === Str, 'WHAT of a Str *is* Str';
ok "Foo".HOW.WHAT.gist eq 'ClassHOW()', 'anything.HOW is a ClassHOW';
ok "Foo".HOW === "Cow".HOW, 'objects of the same class have the same HOW';
ok !("Foo".HOW === Any.HOW), 'objects of different classes have different HOWs';
{
my class Foo {
method zow() {
"A";
}
method !moo() { "Z" }
method moop() { self!moo }
method zilch() {
"B";
}
method crow($x) {
$x * $x;
}
method pie() {
self.zow
}
}
my class Bar is Foo {
method zow() {
"C";
}
}
ok !Foo.defined, "class type objects are undefined";
ok !Bar.defined, "even derived ones";
ok Foo.zow eq 'A', "can call defined methods";
ok Foo.moop eq 'Z', "can call 'private' methods";
ok Bar.zow eq 'C', "subclasses can override methods";
ok Bar.zilch eq 'B', "not overriden methods are inherited";
ok Foo.crow(13) == 169, "can call methods with arguments";
ok Foo.pie eq 'A', "can call methods through self";
ok Bar.pie eq 'C', "calls through self are virtual";
}
{
my $x = 0;
{
START { $x = 1 };
ok $x, "START blocks are run";
}
}
{
my $x = '';
{
$x = $x ~ '1';
START { $x = $x ~ '2'; }
$x = $x ~ '3';
}
ok $x eq '123', "START blocks are run in order with other code";
}
{
my $x = '';
my $y = 0;
while $y < 3 {
$x = $x ~ '1';
START { $x = $x ~ '2'; }
$x = $x ~ '3';
$y++;
}
ok $x eq '1231313', "START blocks are only run once";
}
{
my $x = '';
my $z = 0;
while $z < 2 {
my $y = 0;
while $y < 3 {
$x = $x ~ '1';
START { $x = $x ~ '2'; }
$x = $x ~ '3';
$y++;
}
$z++;
}
ok $x eq '12313131231313', "START blocks reset on clone";
}
{
my $x = sub () { 5 };
ok $x() == 5, 'Anonymous functions can be called';
sub const($y) { sub { $y } }
my $z = const(42);
ok $z, "subs are true";
ok $z() == 42, "subs close over lexicals";
my $w = const(81);
ok !($w === $z), "sub returns different values in different clonings";
ok $w() == 81, "new sub captures new values";
ok $z() == 42, "old sub keeps old value";
}
{
sub accum() {
anon sub go() {
state $x = 0;
$x++;
}
}
my $f = accum;
my $g = accum;
ok $f() == 0, "state variables can be initialized";
ok $f() == 1, "state variables preserve values";
ok $g() == 0, "different clones have different state vars";
}
{
my class A { }
my class B is A { }
my class C is B { }
ok A.^isa(Any), "a new class is Any";
ok B.^isa(A), "a subclass is the superclass";
ok C.^isa(A), "isa is transitive";
ok !(A.^isa(B)), "a superclass is not the subclass";
ok B.^does(A), "a subclass does the superclass";
ok !(A.^does(B)), "a superclass not-does the subclass";
}
ok "Foo".^isa(Str), "strings are Str";
ok (?1).^isa(Bool), "booleans are Bool";
ok (1.HOW).^isa(ClassHOW), "class objects are ClassHOW";
{
my $canary = 1;
ok 1 || ($canary = 0), "1 || ? returns true";
ok $canary, "without touching the rhs";
ok !(0 && ($canary = 0)), "0 && ? returns false";
ok $canary, "without touching the rhs";
ok (0 // ($canary = 0)) eq '0', "0 // ? returns 0";
ok $canary, "without touching the rhs";
ok (12 && 34) == 34, "12 && 34 -> 34";
ok (2 andthen "three") eq "three", '2 andthen three -> three';
ok (12 || 34) == 12, '12 || 34 -> 34';
ok (0 || 34) == 34, '0 || 34 -> 34';
}
{
my $x = 42;
ok (do $x) == 42, "do <statement> sees a lexical";
ok (do { $x }) == 42, "do <block> sees a lexical";
ok (do { my $x = 42; $x }) == 42, "do <block> sees a new lexical";
}
{
ok 42.ACCEPTS(42), "accepts can match stuff";
ok 12 ~~ "12", "strings match string value";
ok "Hi" ~~ Str, "types match identity";
ok (?0) ~~ (?1), "Bool.ACCEPTS ignores its argument";
}
{
constant foo = 42;
constant $bar = 51;
ok foo == 42, "constants without sigils work";
ok $bar == 51, "constants with sigils work";
}
{
ok "Hello".substr(1,3) eq "ell", "substr works";
ok "Hello".chars == 5, ".chars works";
}
{
my $buf = '';
sub cat(*@x) {
while @x {
$buf = $buf ~ @x.shift;
}
$buf;
}
ok cat(1, (2, 3), ((4, 5), ((), 7))) eq "123457", "parcels flatten";
}
{
my package Foo { our $x = 42; }
ok $Foo::x == 42, "can access our vars";
my module Bar { our $x = 42; }
ok $Bar::x == 42, "module accepted too";
my class Baz { our $x = 42; }
ok $Baz::x == 42, "and class";
ok !$Cow::x.defined, "package variables autoviv to undef";
$Cow::x = 51;
ok $Cow::x == 51, "but can still hold values";
}
{
our $kluw = 99; #OK
ok $GLOBAL::kluw == 99, "GLOBAL:: works";
ok $OUR::kluw == 99, "OUR:: works";
}
{
my class Foo {
has $.a;
has $!b;
method test() {
ok self.a == 33, "values accessible as self.a";
ok $.a == 33, 'values accessible as $.a';
$!b = 44;
ok $!b == 44, 'private values accessible as $!b';
ok $!a == 33, 'public values so accessible too';
}
}
my class Bar is Foo {
has $.c;
}
my $x = Foo.new;
my $y = Bar.new;
$x.a = 33;
$x.test;
$y.a = 33;
$y.test;
$y.c = 55;
ok $y.c == 55, "subclass attributes work";
}
{
sub foo($v) {
ok $*FOO == $v, "contextuals accessible";
}
my $*FOO = 99;
foo(99);
ok !$*BAR.defined, "contextuals undefined are undef";
$PROCESS::qaax = 555;
ok $*qaax == 555, "contextuals default to PROCESS";
$GLOBAL::qeex = 5;
$PROCESS::qeex = 3;
ok $*qeex == 5, "GLOBAL takes precedence";
$GLOBAL::quux = 111;
ok $*quux == 111, "contextuals default to GLOBAL too";
{
my $*quux = 222;
ok $*quux == 222, "but can be overriden";
}
ok $*quux == 111, "but only in the one scope";
}
{
my $whatever = *;
ok $whatever.WHAT.gist eq 'Whatever()', "can call methods on a specific Whatever";
my $wwhat = *.WHAT;
ok !($wwhat.^isa(Whatever)), "method calls against * curry, though";
ok (* + 5)(2) == 7, "can curry simple binops";
is ((*) eq "foo"), Bool::False, "parens defeat Whatever directly";
ok (1 + 2 * *)(5) == 11, "nested Whatever works";
ok (2 * (1 + *))(5) == 12, "parens for grouping do not kill WhateverCode";
ok (* + *)(5,12) == 17, "multiple *, multiple args";
ok ((2 * *) + (3 * *))(13,19) == 83, "even from groups";
ok (1,*).^isa(Parcel), "infix:<,> doesn't curry";
}
{
my $x1; my $x2; my $x3; my $x4;
$x1 = 1 if 0;
$x2 = 1 if 1;
$x3 = 1 unless 0;
$x4 = 1 unless 1;
ok !$x1, "if 0 doesn't execute";
ok $x2, "if 1 does execute";
ok $x3, "unless 0 does execute";
ok !$x4, "unless 1 doesn't execute";
}
{
ok ({ $_ * $_ })(20) == 400, '$_ treated as placeholder';
ok ({ $^a - $^b })(5,3) == 2, '$^x treated as such';
ok ({ $^b - $^a })(3,5) == 2, '... in the right order';
}
{
my $canary = 1;
ok !(1 > 2 > ($canary = 0)), "1 > 2 > ... is false";
ok $canary, "short circuitally";
ok !(1 < 3 < 2), "1 < 3 < 2 is false";
ok (1 < 2 < 3), "1 < 2 < 3 is true";
}
ok (-42) + 42 == 0, "unary minus works";
{
ok Q:to/EOA/.substr(0,5) eq 'Hello', "heredocs work";
Hello
EOA
ok Q:to/EOB/ eq Q:to/EOC/, "multiple heredocs in a line work";
Foo
EOB
Foo
EOC
}
{
my @x;
ok @x ~~ Array, '@x isa Array';
ok @x.elems == 0, 'no elements';
ok +@x == 0, 'no elements (+)';
@x.push(5);
ok @x.elems == 1, 'one element now';
ok @x.shift == 5, 'element removed is 5';
@x.push(7,8);
ok @x.elems == 2, "added two elements";
ok @x.shift == 7, "removed first correctly";
ok @x.shift == 8, "removed second correctly";
ok @x.elems == 0, "no elements again";
my $k = 2;
@x.push($k);
$k = 3;
ok @x.shift == 2, "push copies";
@x.push(11,12);
ok @x.pop == 12, "pop is LIFO (1)";
ok @x.pop == 11, "pop is LIFO (2)";
ok +@x == 0, "pop removed all elements";
my @y = 15;
ok @y.elems == 1, "assigning a single value makes a single-item list";
ok @y.shift == 15, "and the value came right!";
@y = 1, 2, 3;
ok @y.elems == 3, "list assignment gets correct item count";
is @y.join("|"), '1|2|3', "assignment of multiple values works properly";
@y = 1, (2, 3), 4;
ok @y.elems == 4, "list assignment flattens (1)";
is @y.join("|"), '1|2|3|4', "list assignment flattens (2)";
@y = 5, @y;
ok @y.elems == 5, "self assignment works (1)";
is @y.join("|"), '5|1|2|3|4', "self assignment works (2)";
}
{
my $a = 0;
my $b = 0;
my $c = 0;
my $d = 0;
my $e = 0;
(Any!Any::butWHENCE({ $a = 1 }));
my $x := (Any!Any::butWHENCE({ $b = 1 })); #OK not used
my $y ::= (Any!Any::butWHENCE({ $c = 1 })); #OK not used
my $z = (Any!Any::butWHENCE({ $d = 1 })); #OK not used
(Any!Any::butWHENCE({ $e = 1 })) = 2;
ok !$a, "no autovivification in void context";
ok $b, "autovivification after rw bind";
ok !$c, "no autovivification after ro bind";
ok !$d, "no autovivification after rvalue context";
ok $e, "autovivification after lvalue context";
}
{
sub postcircumfix:<[ ]>($a, $b) { $a ~ "|" ~ $b }
is 1[2], "1|2", "can call postcircumfix [ ]";
}
{
sub postcircumfix:<{ }>($a, $b) { $a ~ "|" ~ $b }
is 1{2}, "1|2", 'can call postcircumfix { }';
}
{
my @arr = <a b c>;
is @arr.join("|"), 'a|b|c', "word splitter works";
my @narr;
@narr[0];
ok +@narr == 0, "rvalue reference to out of range value does not add";
@narr[2] = 5;
ok +@narr == 3, "assigning to element 2 makes length 3";
ok !(@narr[0].defined), "first element undefined";
ok !(@narr[1].defined), "second element undefined";
ok @narr[2] == 5, "third element properly assigned";
my @darr;
@darr[1][1];
ok +@darr == 0, "rvalue nested reference, no effect";
@darr[2][2] = 'pie';
ok +@darr == 3, "outer level vivifies elements";
ok @darr[2] ~~ Array, "inner Array created";
is @darr[2][2], 'pie', "inner value retained";
}
{
sub postcircumfix:<{ }> { @_.join("|") }
is 1<2 3>, '1|2|3', "angle bracket postcircumfix works";
}
{
my $foo;
ok !($foo<x>.defined), "fetch from hash, no value";
ok !($foo.defined), "no autoviv for rvalue";
$foo<x> = 'foo';
is $foo<x>, 'foo', "values are retained";
ok !($foo<y>.defined), "no cross-slot leakage";
ok $foo ~~ Hash, "foo isa hash now";
$foo<z><a> = 'pie';
is $foo<z><a>, 'pie', "can autoviv deeply";
$foo<y>[2] = 'zed';
is $foo<y>[2], 'zed', "can mix array and hash viv";
$foo<12> = 'fry';
is $foo{12}, 'fry', "keys are strings";
}
{
ok ("a" ~~ /a/), "letter matches itself";
ok !("a" ~~ /b/), "letter does not match other";
ok ("xxa" ~~ /a/), "leading garbage ignored";
ok ("axx" ~~ /a/), "trailing garbage ignored";
ok ("ab" ~~ /ab/), "sequence matches sequence";
ok !("ab" ~~ /ba/), "sequence requires order";
ok ("abc" ~~ /ab?c/), "conditional can match";
ok ("ac" ~~ /ab?c/), "conditional can match nothing";
ok !("adc" ~~ /ab?c/), "conditional cannot match something else";
ok ("ac" ~~ /ab*c/), "kleene closure can match none";
ok ("abbc" ~~ /ab*c/), "kleene closure can match many";
ok !("adc" ~~ /ab*c/), "kleene closure cannot match other";
ok ("abc" ~~ /ab+c/), "plus can match one";
ok ("abbbc" ~~ /ab+c/), "plus can match many";
ok !("adc" ~~ /ab+c/), "plus cannot match other";
ok !("ac" ~~ /ab+c/), "plus cannot match none";
grammar Bob {
rule TOP {ab*c}
}
ok Bob.parse("abbc"), "grammars work (1)";
ok !Bob.parse("adc"), "grammars work (2)";
ok !Bob.parse("xac"), "grammars anchor (1)";
ok !Bob.parse("acx"), "grammars anchor (2)";
}
{
my $x = False;
my $y = False;
my @l1 := gather do { $x = True; take 1; $y = True };
ok !$x, "gather does not run block immediately";
ok @l1.shift == 1, "first value pulled";
ok $x, "pull started block";
ok !$y, "but did not finish it";
ok !@l1, "no more values";
ok $y, "querying that fact finished the block";
}
{
my grammar G1 {
regex TOP { <.foo> }
regex foo { x }
}
ok G1.parse("x"), "subrules work (positive)";
ok !G1.parse("y"), "subrules work (negative)";
my grammar G2 {
regex TOP { y <.foo> <.foo> y }
regex foo { x }
}
ok G2.parse("yxxy"), "subrule position tracking works";
ok !G2.parse("yxy"), "subrule position tracking works (2)";
my grammar G3 {
regex TOP { <moo> }
regex moo { x }
}
ok G3.parse("x"), "capturing subrules work (positive)";
ok !G3.parse("y"), "capturing subrules work (negative)";
}
{
ok (&infix:<+>)(2,2) == 4, '&infix:<+> syntax works';
}
{
sub foo($x = 5) { $x }
ok foo() == 5, "defaults operate";
ok foo(19) == 19, "can override defaults";
ok !foo(Any).defined, "defaults do not misfire";
my $y = 0;
sub bar($x = $y++) { $x }
ok bar() == 0, "expressional defaults operate";
ok bar() == 1, "expressional defaults are called each time";
ok bar(3) == 3, "expressional defaults can be overridden";
ok bar() == 2, "when not used, expressional defaults are not called";
}
{
sub foo($x?) { $x }
ok !foo().defined, "defaults to undef";
ok foo(19) == 19, "can override optionals";
sub bar($x?, $y?) { ($x // 5), ($y // 9) }
is bar().join("|"), "5|9", "2x defaulting works";
is bar(10,20).join("|"), "10|20", "2x overriding works";
is bar(10).join("|"), "10|9", "one value hits the right parameter";
}
{
is :foo.value, Bool::True, ":foo is true";
is :!foo.value, Bool::False, ":!foo is false";
is :foo<12>.value, '12', ":foo<12> is 12";
is :foo.key, 'foo', ":foo is foo";
is (foo => 1).key, 'foo', "foo => 1 keeps key";
is (foo => 1).value, '1', "foo => 1 keeps value";
is ("foo" => 1).key, 'foo', '"foo" => 1 keeps key';
is ("foo" => 1).value, '1', '"foo" => 1 keeps value';
my %hash;
ok %hash ~~ Hash, '%-vars are Hash';
}
{
ok ("aab" ~~ /a* ab/), "a*ab backtracks";
ok !("aab" ~~ /a*: ab/), "a*: ab doesn't";
ok ("aab" ~~ /a*! ab/), "a*! ab backtracks";
ok !("aab" ~~ /:r a* ab/), "ratcheting a* ab does not";
ok !("aab" ~~ /:r a*: ab/), "ratcheting a*: ab does not";
ok ("aab" ~~ /:r a*! ab/), "ratcheting a*! ab does";
ok !("aab" ~~ token { a* ab }), "a* ab in a token does not";
ok ("ab ab" ~~ / ab <.ws> ab /), "ws matches a space";
ok (q:to/end/ ~~ / ab <.ws> ab /), "ws matches a newline";
ab
ab
end
ok ("ab ab" ~~ / ab <.ws> ab /), "ws matches several spaces";
ok !("abab" ~~ / ab <.ws> ab /), "ws does not match nothing";
ok ("ab ab" ~~ rule { ab ab }), "rule gives space";
}
{
sub meow(*@x) {
is @x[0], 'a', "can index [0] slurpies";
is @x[1], 'b', "can index [1] slurpies";
}
meow('a', 'b');
# doing a more reasonable test will probably require embedded blocks
ok "foobarx" ~~ / [ foo | foobar ]: x /, "LTM picks longest even if second";
ok "foobarx" ~~ / [ foobar | foo ]: x /, "LTM picks longest even if first";
}
{
my $x = '';
ok !("a" ~~ / a { $x = 1; } b /), '{} does not terminate regex';
is $x, 1, '{} is run even if regex fails';
$x = '';
ok !("" ~~ / a { $x = 1; } b /), '{} does not affect regex that ends before it';
is $x, '', '{} is only run if reached';
$x = 0;
ok ("aab" ~~ / a* { $x++ } ab /), '{} does not block backtracking';
is $x, 2, '{} is run multiple times when backtracking';
$x = '';
ok ("foo" ~~ / foo { $x = $x ~ 1 } | foo { $x = $x ~ 2 } /),
"foo ~~ foo|foo";
is $x, 1, "with no other constraints, first item is used";
$x = '';
ok ("foo" ~~ / fo* { $x = $x ~ 1 } | foo { $x = $x ~ 2 } /),
"foo ~~ fo*|foo";
is $x, 2, "longer literal prefix wins over seniority";
$x = '';
ok ("fooo" ~~ / fo* { $x = $x ~ 1 } | foo { $x = $x ~ 2 } /),
"foo ~~ fo*|foo";
is $x, 1, "longer length wins over prefix";
$x = '';
ok !("fooo" ~~ / [ fo*: { $x = $x ~ 1 } | foo { $x = $x ~ 2 } ] x /),
"foo !~~ [fo*:|foo]x";
is $x, '12', "will backtrack into shorter token";
our $x6474;
my grammar G5 {
token a { foo }
token b { foobar }
token c { <a> | <b> }
token d { <c> x }
token e { x <e> x | y }
token TOP { A <d> | E <e> }
}
ok G5.parse('Afoobarx'), 'LTM works even through subrules';
ok G5.parse('Exxyxx'), 'recursivity does not crash LTM';
my grammar G6 {
token a { fo* { $x6474 = 1 } }
token b { foo { $x6474 = 2 } }
token TOP { <a> | <b> }
}
G6.parse("foo");
is $x6474, 2, "prefix length testing works in subrules";
}
{
is "\x63", "c", '\x works';
is "Y\x63", "Yc", 'can put stuff before escapes';
is "\x63Y", "cY", 'can put stuff after escapes';
is "Y\x63Y", "YcY", 'can put stuff before and after escapes';
is "\x[63,69]", "ci", 'bracketed \x works';
is "\x4E03", "七", '\x with >2 characters works';
is "七".chars, 1, "nana is one kanji";
is "\\", "\x5C", 'can backslash backslashes';
is "\"", "\x22", 'can backslash quotes';
is '\'', "\x27", 'can backslash single quotes';
is "\b", "\x08", '\b works';
is "\a", "\x07", '\a works';
# punt named forms for now
is "\e", "\x1B", '\e works';
is "\f", "\x0C", '\f works';
is "\n", "\x0A", '\n works';
is "\r", "\x0D", '\r works';
is "\t", "\x09", '\t works';
is "\o[61,63,65]", '135', '\o works (bracketed)';
is "\o67", '7', '\o works (bare)';
is "\0", "\x00", '\0 works';
is "foo { 2 + 2 } bar", "foo 4 bar", "code interpolation works";
my $cow = 'hi';
is "foo $cow bar", "foo hi bar", '$-interpolation works';
is "foo $cow.substr(0,1) bar", "foo h bar", 'methodcall interpolation works';
}
{
my grammar G7 {
proto token tok {*}
token tok:sym<+> { <sym> }
token tok:foo { <sym> }
rule TOP { <tok> }
}
ok G7.parse('+'), "can parse :sym<> symbols";
ok G7.parse('foo'), "can parse : symbols";
}
{
sub t1(*@k, :$x, :y($)) { $x } #OK
sub t2(*@k, :y($x), :x($)) { $x } #OK
sub t3(*@k, :y(:$x)) { $x } #OK
ok !t1.defined, "no arg, no value";
ok !t1(12).defined, "positional is not enough";
ok t1(x => 5) == 5, "can pass argument (fatarrow)";
ok !t1("x" => 5), "quoted fatarrow doesn't work";
ok !t1((x => 5)), "parenned fatarrow doesn't work";
ok t1(:x(6)) == 6, "colonpair works";
ok !t1(:y(7)).defined, "wrong name, no cigar";
ok t2(y => 9) == 9, ":y(\$x) syntax picks out y as name";
ok !t2(x => 10).defined, "x is NOT a usable name";
ok t3(:x(11)) == 11, ":y(:\$x) works for both (1)";
ok t3(:y(11)) == 11, ":y(:\$x) works for both (2)";
}
{
ok "\n" ~~ /\n/, '\n in regex matches literal NL';
ok !('\n' ~~ /\n/), '\n in regex does not match literal \n';
ok '+' ~~ /\+/, '\+ in regex matches literal +';
ok '\\' ~~ /\\/, '\\\\ in regex matches literal \\';
ok 'a' ~~ /\x61/, '\x61 in regex matches literal a';
ok 'xy' ~~ /x <?> y/, '<?> matches null string';
my $a = 2;
my $b ::= $a;
$a = 5;
is $b, 2, "ro binding loses original container";
ok 'xxy' ~~ /x { $a = $/.pos } /, "can match with \$/ stuff";
is $a, 1, '$/.pos is the right sort of thing';
'xxy' ~~ /x { $a = ($¢ ~~ Cursor) }/;
is $a, True, '$¢ isa Cursor';
}
{
sub infix:<@>($x, $y, :$z) { $x, $y, $z }
is (1 @ 2 :z(3)).join("|"), "1|2|3", "adverbs on infix ops work";
}
{
my $x = 4;
$x += 3;
is $x, 7, "metaop += works";
sub testx:sym«foo bar»() { 42 }
is &testx:sym<foo bar>(), 42, "can use french quotes in declarations";
sub foo(Str $x) { $x ~ $x }
is foo("bar"), "barbar", "can parse type constraints";
}
rxtest /x.y/, "x.y", ("xay", "x y"), ("xy", "xaay");
rxtest /<!>/, '<!>', (), ("", "x");
rxtest /\s/, '\s', (" ", ("\n" => '\n'), ("\r" => '\r'), "\x3000"),
("x", "1", "+");
rxtest /\S/, '\S', ("x", "1", "+"),
(" ", ("\n" => '\n'), ("\r" => '\r'), ("\x3000" => 'id space'));
rxtest /\w/, '\w', ("x", "1", "_", "\x4E00"), ("+", " ");
rxtest /<[ y ]>/, '<[ y ]>', ("y"), (" ", "x", "z");
rxtest /<[ i .. k ]>/, '<[ i .. k ]>', ("i", "j", "k"), ("h", "l");
rxtest /<[ \W a..z ]>/, '<[\W a..z]>', ("a", "z", "+"), ("\x4E00");
rxtest /a || b/, 'a || b', ("a", "b"), ("c", "");
rxtest /x [a || aa]: c/, 'x[a||b]:c', ("xac",), ("xaac",);
{
my $obj ::= (class {
method item() { "item" }
method list() { "list" }
method hash() { "hash" }
}).new;
is $($obj), "item", '$() calls item';
is @($obj), "list", '@() calls list';
is %($obj), "hash", '%() calls hash';
is $$obj, "item", '$$ truncated context';
is @$obj, "list", '@$ truncated context';
is %$obj, "hash", '%$ truncated context';
is "x$$obj", "xitem", '$$ interpolation';
is "x@$obj.Str()", "xlist", '@$ interpolation';
is "x%$obj.Str()", "xhash", '%$ interpolation';
}
ok "axy" ~~ / a <before x> \w y / , "before is zero-width";
ok "axy" ~~ / a <?before x> \w y / , "?before is zero-width";
ok "azy" ~~ / a <!before x> \w y / , "!before is zero-width";
ok !("azy" ~~ / a <?before x> \w y /) , "?before x needs x";
ok !("axy" ~~ / a <!before x> \w y /) , "!before x needs !x";
ok '{}' ~~ / \{ <.ws> \} /, 'ws matches between \W';
{
rxtest /z .* y [ a :: x | . ]/, "z.*y[a::x|.]",
("zyax", "zyb", "zyaxya"), ("zya",);
# no ::> until STD gets here...
rxtest /z .* y [ a ::: x || . ]/, "z.*y[a:::x||.]",
("zyax", "zyb"), ("zya", "zyaxya");
my grammar G7 {
proto regex TOP {*}
regex TOP:foo { a :: x }
regex TOP:bar { . }
}
ok G7.parse("ax"), ":: does not block forward";
ok G7.parse("b"), ":: does not affect other paths";
ok !G7.parse("a"), "cannot backtrack past :: in proto ltm";
}
rxtest /y [ [ foo || bar ] | . ]: y/, "|| hides right side from LTM",
("yky","yfooy"), ("ybary",);
rxtest /y [ [a||b] | c ]: y/, "|| exposes a declarative prefix for left only",
("yay","ycy"), ("yby",);
{
# one CgOp bug manifested as a failure to compile this
ok (/ <?before x>: <ws>: /).defined, "unnamed regression";
my $ma = ("ab29x" ~~ /\d+/);
ok $ma.defined, "match is defined";
ok $ma.WHAT === Match, "matches are Match";
is $ma.from, 2, '$ma.from works';
is $ma.to, 4, '$ma.to works';
is $ma.Str, '29', '$ma.Str works';
}
{
use MONKEY_TYPING;
my class Foo {
method foo { 1 }
}
is Foo.foo, 2, "augments run early";
augment class Foo {
method foo { 2 }
}
}
{
my $ma = (grammar {
token TOP { <foo> <bar> }
token foo { \d+ }
token bar { \D+ }
}).parse("123abc");
ok $ma<foo> ~~ Match, "<foo> sub is a Match";
is $ma<foo>, "123", "<foo> sub got 123";
ok $ma<bar> ~~ Match, "<bar> sub is a Match";
is $ma<bar>, "abc", "<bar> sub got 123";
ok !$ma<quux>, "no <quux> sub";
my $mb = (grammar {
token TOP { <foo> <foo> }
token foo { \D+ | \d+ }
}).parse("def456");
ok $mb.defined, "grammar b matched";
ok $mb<foo> ~~ List, "<foo> sub isa List";
is +$mb<foo>, 2, "2 matches";
ok $mb<foo>[0] ~~ Match, "<foo>[0] sub isa Match";
is $mb<foo>[0], "def", "<foo>[0] got def";
is $mb<foo>[1], "456", "<foo>[1] got 456";
my $mc = (grammar {
token TOP { <foo>+ }
token foo { \D+ | \d+ }
}).parse("def");
ok $mc<foo> ~~ List, "<foo>+ makes a list";
is +$mc<foo>, 1, "despite only one element";
my $md = (grammar {
token TOP { \D+ <foo> \D+ }
token foo { \d+ <bar> \d+ }
token bar { \D+ }
}).parse("a1b2c");
is $md<foo><bar>, "b", "<foo><bar> works";
my $mf = (grammar {
proto token TOP {*}
token TOP:x { <foo> }
token foo { \w+ }
}).parse("abc");
is $mf<foo>, "abc", "protoregex captures work";
my $me = (grammar {
token TOP { <tok>+ }
proto token tok {*}
token tok:num { <sign>? <digit>+ }
token tok:ws { \s+ }
token sign { \+ | \- }
token digit { \d | _ }
}).parse("2 -34 5");
ok $me<tok> ~~ List, "a list of tokens";
is +$me<tok>, 5, "5 of them";
is ?($me<tok>[0]<sign>), False, "first no sign";
is ?($me<tok>[2]<sign>), True, "third sign";
is ?($me<tok>[4]<sign>), False, "fifth no sign";
is $me<tok>[2], '-34', "3rd token '-34'";
}
{
rxtest / . << . /, ".<<.", (" x",), ("x "," ","xx");
rxtest / . << /, ".<<", (), ("x", " ");
rxtest / << . /, "<<.", ("x",), (" ",);
rxtest / << /, "<<", (), ("",);
rxtest / . >> . /, ".>>.", ("x ",), (" x"," ","xx");
rxtest / . >> /, ".>>", ("x",), (" ",);
rxtest / >> . /, ">>.", (), ("x"," ");
rxtest / >> /, ">>", (), ("",);
rxtest / . « . /, ".«.", (" x",), ("x "," ","xx");
rxtest / . « /, ".«", (), ("x", " ");
rxtest / « . /, "«.", ("x",), (" ",);
rxtest / « /, "«", (), ("",);
rxtest / . » . /, ".».", ("x ",), (" x"," ","xx");
rxtest / . » /, ".»", ("x",), (" ",);
rxtest / » . /, "».", (), ("x"," ");
rxtest / » /, "»", (), ("",);
rxtest / . ^ . /, ".^.", (), ("x",);
rxtest / . ^ /, ".^", (), ("x",);
rxtest / ^ . /, "^.", ("x",), ();
rxtest / ^ /, "^", ("",), ();
rxtest / . $ . /, '.$.', (), ("x",);
rxtest / . $ /, '.$', ("x",), ();
rxtest / $ . /, '$.', (), ("x",);
rxtest / $ /, '$', ("",), ();
rxtest / . ^^ . /, '.^^.', ("\nx","\n\n"), ("x\n","xx");
rxtest / . ^^ /, '.^^', (), ("x","\n");
rxtest / ^^ . /, '^^.', ("x","\n"), ();
rxtest / ^^ /, '^^', ("",), ();
rxtest / . $$ . /, '.$$.', ("x\n", "\n\n"), ("\nx","xx");
rxtest / . $$ /, '.$$', ("x",), ("\n",);
rxtest / $$ . /, '$$.', ("\n",), ("x",);
rxtest / $$ /, '$$', ("",), ();
}
{
ok "foo" ~~ / :my $gothere = 1; foo /, "can embed :my in regexes";
ok $gothere, ":my code is run";
}
{
sub flow-ok($fn, $flw, $msg) {
my $log = '';
$fn(-> $i { $log ~= $i });
is $log, $flw, $msg;
}
flow-ok -> &l { my $i = 0; while $i < 2 { $i++; l(1); next; l(2) } }, '11',
"next skips second half of while loop";
flow-ok -> &l { my $i = 0; while $i < 2 { $i++; l(1); last; l(2) } }, '1',
"last skips everything";
flow-ok -> &l { my $i = 0; while True { l($i++); last if $i == 3 } }, '012',
"last can leave inf loop";
flow-ok -> &l { my $i = 3; while $i == 3 { l($i--); redo if $i } }, '321',
"redo reenters loops";
sub foo { return 2; }
is foo(), 2, "return values work";
my $cont = False;
sub foo3 { return 2; $cont = True; }
foo3;
ok !$cont, "return exits function";
}
{
rxtest /^ x**2..4 $/, 'x**2..4', ('xx','xxx','xxxx'), ('x','xxxxx');
rxtest /^ x**2..* $/, 'x**2..*', ('xx','xxx','xxxx'), ('x',);
rxtest /^ [x**2] $/, 'x**2', ('xx',), ('x','xxx');
rxtest /^ [x**y] $/, 'x**y', ('x','xyx','xyxyx'), ('','xy','yx');
}
{
our $x8484;
(class { method foo() {
$x8484 = 1;
} }).foo;
ok $x8484, "changes made in the protolexpad are visible at runtime";
}
{
our $x1903;
my $unclonable-sub = (class { method foo() { sub () { $x1903 } } }).foo;
$x1903 = 42;
ok $unclonable-sub() == 42, "mainlines are not cloned";
}
{
class Foo {
method foo() { 42 }
class Bar {
method bar() { 51 }
}
ok Bar.bar == 51, "within Foo, Bar is directly accessible";
ok OUR::Bar.bar == 51, "within Foo, Bar is package accessible";
ok Foo::Bar.bar == 51, "within Foo, Bar is longname accessible";
ok GLOBAL::Foo::Bar.bar == 51, "within Foo, Bar is GLOBAL accessible";
}
ok Foo.gist eq 'Foo()', "lexical lookup of our-class works";
ok OUR::Foo.gist eq 'Foo()', "also visible in ourpad";
ok GLOBAL::Foo.gist eq 'Foo()', "also visible globally";
ok Foo::Bar.bar == 51, "can call through nested methods";
ok GLOBAL::Foo::Bar.bar == 51, "can call through GLOBAL nested";
}
{
role Foo6596[$x] { # XXX std bug, need to use OUR::Foo[$x]
method rfoo { $x }
}
my role Quux {
method rquux { "quux" }
}
my class Bar { }
is (Bar but Quux).rquux, "quux", "can bind roles to classes";
is (Bar but OUR::Foo6596["hi"]).rfoo, "hi", "can bind parametric roles to classes";
}
ok "abc" ~~ / :dba("foo") abc /, ":dba doesn't affect parsing";
{
our $log9434 = '';
my grammar B {
token a { { $log9434 ~= 'A' } }
token b { { $log9434 ~= 'B' } }
token c { { $log9434 ~= 'C' } }
}
my grammar A {
token a { { $log9434 ~= 'a' } }
token b { { $log9434 ~= 'b' } }
token c { { $log9434 ~= 'c' } }
token TOP { x <.a> [ :lang(B) <.b> ] <.c> x }
}
A.parse("xx");
is $log9434, 'aBc', ':lang has the expected effect';
}
{
is chars("foo"), 3, '&chars works';
is substr("Hello",1,3), 'ell', '&substr works';
is substr("Hello",2), "llo", '&substr works (2 args)';
is reverse(1,2,3).join("|"), '3|2|1', '&reverse works';
is join("|",1,2,3), '1|2|3', '&join works';
my @foo = 4,5,6;
is join("|",item @foo), '4 5 6', '&item works';
is join("|",@foo.item), '4 5 6', 'Mu.item works';
is (not False), True, '&not works';
is (defined 5), True, '&defined works';
push @foo, 7, 8;
is join("|",@foo), '4|5|6|7|8', '&push works';
unshift @foo, 2, 3;
is join("|",@foo), '2|3|4|5|6|7|8', '&unshift works';
is pop(@foo), '8', '&pop works';
is shift(@foo), '2', '&shift works';
is join("|",@foo), '3|4|5|6|7', '... with side effects';
is +True, '1', "Bool.Numeric works";
my %bar = :a<9>;
is %bar<a>, '9', "Hash.LISTSTORE works";
%bar = :c<9>;
ok (!defined %bar<a>), "Hash.LISTSTORE clears existing";
is keys(%bar), "c", "Hash.keys works";
is values(%bar), "9", "Hash.values works";
is (join "|", %bar.kv), "c|9", "Hash.kv works";
is (%bar.invert.<9>), "c", "Hash.invert works";
ok %bar<c> :exists, ":exists works";
is (%bar<c> :delete), "9", ":delete returns old";
ok !(%bar<c> :exists), ":delete removes value";
}
{
my class A {
method tom() { 12 }
method foo($x) { $x * $x }
method bar(:$x) { $x + $x }
}
my class B is A {
method tom() { nextsame; }
method foo($x) { nextsame; } #OK
method bar(:$x) { nextsame; } #OK
}
is B.tom(), 12, "nextsame functional";
is B.foo(5), 25, "nextsame functional w/ argument";
# TODO
# is B.bar(:x(7)), 14, "nextsame functional w/ named arg";
sub foo(*%x) { %x }
is foo(:z(2))<z>, 2, "slurpy hashes work";
}
ok 'cow' le 'sow', 'cow le sow';
ok !('sow' le 'cow'), 'sow !le cow';
ok 'row' lt 'tow', 'row lt tow';
ok 'how' gt 'bow', 'how gt bow';
ok 'yow' ge 'yow', 'yow ge yow';
is join("|", sort <c f d z a>), 'a|c|d|f|z', '&sort works';
is join("|", <a3 b2 c1 d0>.sort({ substr($^a,1) leg substr($^b,1) })),
'd0|c1|b2|a3', '.sort with callback works';
is ("yayay" ~~ /y\w*?y/), "yay", "minimal matching works";
is ("yayay" ~~ /y**?a/), "y", "minimal matching works with **";
is +[ 2 ], 1, "array construction w/ one argument";
is +[ ], 0, "array construction w/ no arguments";
is +[ 3, 4 ], 2, "array construction w/ two";
is +[ $( 3, 4 ) ], 1, "array construction w/ scalar argument";
{
sub bar { $*x + $*x }
sub foo($*x) { bar }
is foo(12), 24, "*-twigilled arguments work";
}
is { a => 1 }.<a>, 1, "hash constructors work (1)";
is { "a" => 1 }.<a>, 1, "hash constructors work w/ quotes";
is { :a(1) }.<a>, 1, "hash constructors work w/ colons";
is { a => 1, b => 2 }.<b>, 2, "hash constructors work w/ lists";
ok { } ~~ Hash, "hash constructors work w/ nothing";
ok !('xy' ~~ /x <{ False }> y/), '<{False}> blocks a match';
ok 'xy' ~~ /x <{ True }> y/, '<{True}> does not affect it';
ok (1 < 3 > 2), "CHAIN works with dissimilar ops";
{
my $b = "oo";
is ("foox" ~~ /f$b/), "foo", '$x matches contents in a regex';
}
{
sub f1(:$x) { $x }
is f1(|("x" => 2)), 2, "can flatten pairs";
is f1(|{"x" => 2}), 2, "can flatten hashes";
sub f2($x,$) { $x }
is f2(|[1,2]), 1, "can flatten lists";
is f2(|(1,2)), 1, "can flatten parcels";
}
rxtest / <alpha> / , '<alpha>', ('a', 'A', "\x4E00"), ("+", "1", " ");
{
my $m = "" ~~ / $<foo> = { 2 + 2 } $<bar> = {"x"} $<bar> = {"y"} /;
is $m<foo>, 4, "value aliasing works (sing)";
is $m<bar>, "x y", "value aliasing works (plur)";
$m = "fo" ~~ / (.) (.) /;
is $m[0], "f", "numbered captures work";
is $m[1], "o", "capture auto-numbering works";
$m = "foo" ~~ / (.) ( (.) (.) ) /;
is $m[1], "oo", "outer capture sees inner";
is $m[1][1], "o", "nested numeric captures work";
$m = "def" ~~ /<a=.alpha> $<moo> = [ <b=.alpha> <c=.alpha> ]/;
is $m<a>, "d", "aliasing works";
is $m<c>, "f", "aliased [] transparent to captures";
is $m<moo>, "ef", "aliased [] captures string";
ok !$m<moo><b>, "no spurious nested captures";
my $save;
"()" ~~ / '(' ~ ')' { $save = $*GOAL } /;
is $save, ')', 'Setting $*GOAL works';
}
ok 1 !== 2, "infix_prefix_meta_operator:<!> works (T)";
ok !(1 !== 1), "infix_prefix_meta_operator:<!> works (F)";
{
my $m = "ab" ~~ / (.) <alpha> /;
is (@$m)[0], "a", "Match.list returns positional captures";
is (%$m)<alpha>, "b", "Match.hash returns named";
is ((-> $p, :$alpha { $p, $alpha })(|$m)).join("|"), "a|b", "Match.Capture returns both";
my @arr = "abc" ~~ / (.) (.) (.) /;
is @arr.join("|"), "a|b|c", "Regex.ACCEPTS in list context returns captures";
$m = "" ~~ / <O( foo => 2 )> /;
is $m<O><foo>, 2, "<O> is functional";
$m = (grammar {
proto token TOP {*}
token TOP:foo { <sym> }
}).parse("foo");
is $m<sym>, "foo", '$<sym> is functional';
ok !(try die "foo").defined, "try of an error is undef";
is $!, "foo", 'the error goes into $!';
{
my @*foo = 1, 2, 3;
{
temp @*foo;
push @*foo, 4;
is +@*foo, 4, '@*foo has 4 elements in temp scope';
}
is +@*foo, 3, '@*foo has 3 elements again after temp';
}
my @ar = [1, 2, 3];
is +@ar, 1, "array constructors are singular";
my $i = 0;
$i++ until $i == 10;
is $i, 10, "until loops functional";
ok "foo" !~~ / f <.suppose { die }> /, ".suppose works (F)";
ok "fox" ~~ / f <.suppose o> x /, ".suppose works (T)";
ok "abcabc" ~~ /^ (\w+) $0 $/, '$/ in variable refs functional';
ok "abcabc" ~~ /^ (\w+) "$0" $/, '$/ in substrings functional';
(grammar {
method moo($cap) { is $cap<cap>, "hi", '$/ from subrule args works'; @( self, ) }
token TOP { $<cap>={"hi"} <moo($/)> }
}).parse("");
ok (grammar {
method moo() { self }
regex TOP { <.moo> }
}).parse(""), "simply returning self from a regex works";
rxtest / <after ':+'> X / , '<after ":+">X', (':+X', 'a:+X'), (':X','+:X');
rxtest / <after \s> X / , '<after \s>X', (' X',), ('xX','X');
rxtest / <after ab> X / , '<after ab>X', ('abX',), ('baX',);
}
{
my ($x) = (1, 2);
is $x, 1, "list assign takes first";
($x, my $y) = (1, 2);
is "$x|$y", "1|2", "list assign takes both";
($x, $y) = 1;
is $x, 1, "list assign takes what it can";
ok !$y.defined, "rest of list gets undef";
($x, my @z, my @w) = (1, 2, 3);
is $x, 1, "scalar gets first";
is @z.join("|"), "2|3", "list gets rest";
is +@w, 0, "second list gets none";
}
{
sub infix:<=>($x, $y) { $x ~ "|" ~ $y }
is (1 = 2), '1|2', 'can override infix:<=> in lexical scope';
}
{
my class Regex { }
ok "x" ~~ /x/, "Regex shadowing doesn't cause problems";
}
ok "\x2FFF" ~~ /<-[ x ]>/, "Negated char classes match unassigned characters";
ok "x:" ~~ /. >> ./, "Punctuation ends words";
{
my class A { method foo(:$x) { $x * 2 } }
my class B is A { method foo() { nextwith( self, x => 5 ) } }
is B.foo, 10, "nextwith works";
}
{
our role R6025[$x] {
method foo() { $x }
}
ok ((Any but OUR::R6025[True]).foo.^isa(Bool)),
"parameterized roles can store non-strings";
}
{
our role Stop4717[$a] {
token foo { $a }
}
grammar X {
token TOP { [ <foo> | foo ]: x }
}
ok (X but OUR::Stop4717["foobar"]).parse("foobarx"),
"LTM works through parameterized role variables";
}
{
my $M;
my $t;
$M = ("a()" ~~ / <alpha> '(' ~ ')' { $t = $<alpha>.Str } /);
is $t, "a", "Inside of ~ can see captures";
$M = ("(a)" ~~ / '(' ~ ')' <alpha> /);
is $M<alpha>, "a", "Captures can escape from ~";
my $died = 1;
try { $*NONEX = 1; $died = 0; }
ok $died, "Assignment to non-existing dynvar fails";
is "foo".substr(5,2), "", "substr starting off end works";
is "foo".substr(1,10), "oo", "substr ending off end works";
rxtest /:i "abc"/, ':i "abc"',
("abc","aBc","ABC"),("cba","ab");
my grammar G {
proto token TOP {*}
token TOP:foo { :i <sym> }
}
ok G.parse("fOo"), ":i <sym> works";
my %h; %h<used>++;
is %h<used>, 1, "autoviv works with ++";
is ((anon method retme ($x:) { $x })(53)), 53, "method definitions with explicit invocants work";
}
{
my class A { method Numeric { 42 } }
is A.new + 23, 65, '+ calls user-written .Numeric';
}
{
"abc" ~~ /. (.) ./;
is $0, 'b', 'Regex matches set $/';
}
{
"abc" ~~ /de(.)/;
ok !defined($/), 'Failed regex matches clear $/';
}
{
my @foo = 1, 2, 3, 4, 5;
is @foo[2,3].join('|'), '3|4', 'slicing works';
is @foo[[1,4]].join('|'), 3, 'items do not slice';
ok !defined(@foo[4,5,6][1]), 'slices off end work';
@foo[1,2,3] = 5,6,7;
is @foo.join('|'), '1|5|6|7|5', 'can assign to slices';
@foo[4,5,6] = 1,2,3;
is @foo.join('|'), '1|5|6|7|1|2|3', 'can assign to slices off end';
my %quux;
%quux<a b c> = (1, 2, 3);
is %quux<b>, 2, 'can assign to hash slices';
is %quux<c b>.join('|'), '3|2', 'can read from hash slices';
my @bar = 1, 2, 3, 4, 5;
is @bar[{ $^x / 2 }], 3, 'code indexes work';
is @bar[*-1], 5, 'WhateverCode indexes work';
}
{
my @arr;
my $ix = -1;
ok !(defined @arr[$ix]), "can index before arrays to get undef";
}
{
is ("foo bar baz".split(/\s/).join('|')), 'foo|bar|baz', 'basic split';
is ("foo bar baz".split(' ').join('|')), 'foo|bar|baz', 'split with string';
is ("foo bar baz".split(' ', 2).join('|')), 'foo|bar baz',
'split with a limit';
is (" foo bar".split(' ').join('|')), '||foo|bar',
'split with leading empty fields';
is ("foo bar ".split(' ').join('|')), 'foo|bar||',
'split with trailing empty fields';
try { "foo bar".split };
ok $!, 'split requires an argument';
is ("ax+by*cz".split(/\W/, :all).join('|')), 'ax|+|by|*|cz',
'split :all';
is "hello world".index('l'), 2, ".index";
is "hello world".index('l',5), 9, ".index with restart point";
ok (!defined("hello world".index('x'))), ".index off end";
is "hello world".rindex('l'), 9, ".rindex";
is "hello world".rindex('l', 6), 3, ".rindex with restart point";
ok (!defined("hello world".rindex('x'))), ".rindex off end";
is ("abc".comb.join('|')), 'a|b|c', 'comb with default matcher';
is ("abc".comb(/./, 2).join('|')), 'a|b', 'comb with limit';
is ("A1 B2 C3".comb(/(\w)(\d)/, :match).[2].[1]), 3, 'comb :match';
}
{
my $a = 3; $a &&= 4; is $a, 4, '&&= works (T)';
my $b = 0; $b &&= 4; is $b, 0, '&&= works (F)';
my $c = 3; $c ||= 4; is $c, 3, '||= works (T)';
my $d = 0; $d ||= 4; is $d, 4, '||= works (F)';
my $e = 0; $e andthen= 4; is $e, 4, 'andthen= works (D)';
my $f = Any; $f andthen= 4; is $f.gist, Any.gist, 'andthen= works (U)';
my $g = 0; $g //= 4; is $g, 0, '//= works (D)';
my $h = Any; $h //= 4; is $h, 4, '//= works (U)';
is 2.&not, False, '.& notation works';
my class X1 {
submethod foo { 1 }
}
my class X2 is X1 {
}
is X1.foo, 1, "can call submethods";
my $i; try { X2.foo; $i = True }
ok !$i, "submethods are not inherited";
}
{
my class X1 {
has $.a = 123;
has $.b;
}
my $x = X1.new;
ok !defined($x.b), "without initializer, attr is undefined";
is $x.a, 123, "initializers work";
$x.a = 456;
is $x.a, 456, "initialized attrs can still be reset";
}
{
my $called = 1;
sub called {
$called++;
"foo";
}
if called() -> $a {
is $a,"foo","the condition in an if is passed to the block as an argument";
}
is $called,2,"the if condition only gets called once";
my $false_branch = 0;
if 0 -> $a {
1+$a;
$false_branch = 1;
}
is $false_branch,0,"a branch of an if with a false condition doesn't get called";
}
{
our $str8646;
INIT $str8646 = '';
$str8646 ~= 1;
INIT $str8646 ~= 2;
$str8646 ~= 3;
INIT $str8646 ~= 4;
is $str8646, '2413', 'INIT blocks run in correct order';
}
{
my class X3 {
has $.a;
}
my $x = X3.new(a => 5);
is $x.a, 5, 'Attribute values can be passed in constructors';
sub foo($/) { $<a> }
is foo({ a => 5 }), 5, 'Can bind $/ in signature';
my class X4 {
method foo { 13 }
method !bar { 17 }
method sam($x) { self!"$x"() }
}
is X4."foo"(), 13, 'indirect method calls work'; #OK
is X4."{ "fo" ~ "o" }"(), 13, 'indirect calls work with interpolation';
is X4.sam("bar"), 17, "indirect private method calls work";
}
{
"foo" ~~ /oo/;
is $/.ast, 'oo', '.ast defaults to .Str';
"foo" ~~ /oo { make 15 }/;
is $/.ast, 15, 'make can change .ast';
"foo" ~~ /{make 30} oo/;
is $/.ast, 30, 'make works in the middle';
my grammar X5 {
proto token TOP {*}
token TOP:x { foo { make 45 } }
}
is X5.parse("foo").ast, 45, 'make works in multiregexes';
}
{
my grammar X6 {
token a { <?> }
proto token b {*}
token b:x { <?> }
proto token c {*}
token c:x { <?> }
}
my class A6 {
method a($/) { make 1 }
method b($/) { make 2 }
method c:x ($/) { make 3 }
}
is X6.parse("", :actions(A6), :rule<a>).ast, 1,
'action methods work (simple rule)';
#is X6.parse("", :actions(A6), :rule<b>).ast, 2,
# 'action methods work (proto rule)';
is X6.parse("", :actions(A6), :rule<c>).ast, 3,
'action methods work (candidate rule)';
}
{
my @foo = 1; #OK
my $tgt; #OK
my %into;
$tgt = %into<foo> = True;
ok %into<foo>, "2011-01-13 list assignment parsefail";
}
{
is +"12" - 5, 7, "Str.Numeric works";
is 6 +& 3, 2, "+& works";
is 6 +^ 3, 5, "+^ works";
is 6 +| 3, 7, "+| works";
is 6 +< 3, 48, "+< works";
is 6 +> 1, 3, "+> works";
is +^6, -7, "+^ works";
is ord('0'), 48, "ord works";
is chr(65), 'A', "chr works";
}
{
is [ 1..5 ], "1 2 3 4 5", "Ranges work in list context";
is [ 1 ..^ 5 ], "1 2 3 4", "Tail exclusion works";
is [ 1 ^.. 5 ], "2 3 4 5", "Head exclusion works";
is [ 1 ^..^ 5 ], "2 3 4", "Dual exclusion works";
is [ ^5 ], "0 1 2 3 4", "Shorthand form works";
is ((5 .. *)[3]), 8, "Infinite ranges can be iterated";
ok 3 ~~ 1..4, "Range checking works (+)";
ok 5 !~~ 1..4, "Range checking works (-)";
}
{
my $i = 0;
1 < ($i++; 2) < 3;
is $i, 1, "Chained comparisons only evaluate terms once";
my $foo = [5];
for $foo { .shift }
is +$foo, 0, ".method works";
my $x = 5;
$x ~~ .++;
is $x, 6, "~~ topicalization works";
my $y;
given 12 { $y = $_ }
is $y, 12, "prefix given works";
$y = $_ given 24;
is $y, 24, "postfix given works";
my $z = '';
$z ~= $_ for 1, 2, 3;
is $z, '123', "postfix for works";
my $k = '';
given 12 {
$k ~= 1 when 12;
$k ~= 2 when * > 5;
$k ~= 3 when * <= 5;
}
is $k, '12', "postfix when works";
$k = '';
given 12 {
when 9 { $k ~= 1 }
when * > 6 { $k ~= 2 }
when * > 3 { $k ~= 3 }
}
is $k, '2', "normal when works";
given my $g { #OK
$_ = 'abc';
s/b/d/;
is $_, 'adc', 'simple s/// works';
is $/, 'b', 's/// sets $/';
$k = 'bac';
$k ~~ s/c/g/;
is $k, 'bag', '~~ s/// works';
$_ = 'abc';
s/(\w)/$0$0/;
is $_, 'aabc', 's/// can refer to $/';
$_ = 'abc';
ok ?(s/b/x/), 's/// is true if replacing';
$_ = 'abc';
ok !(s/d/x/), 's/// is false if not replacing';
is $_, 'abc', '... and target unchanged';
$_ = 'abc';
s!a!xx!;
is $_, 'xxbc', 's/// with alternate delims works';
$_ = 'abc123';
s{b} = 'g' ~ 'k';
is $_, 'agkc123', 's{} = works';
$_ = 'abc123';
s{\D+} = $/ ~ $/;
is $_, 'abcabc123', 's{} = can refer to $/';
$_ = 'abc123';
s{\d+} *= 2;
is $_, 'abc246', 'metaoperator s{} works';
}
}
{
my $a = 0;
{
A: while True {
$a++; while True { last A }; $a++;
last;
}
}
is $a, 1, "last with label works";
sub funlp($fn) {
A: while True {
$fn(A)
}
}
my $b = 0;
funlp(-> $o {
$b++; funlp(-> $i { last $o }); $b++; #OK
last;
});
is $b, 1, "last with label object is not fooled by names";
my $c = 0;
funlp(-> $o { #OK
$c++; funlp(-> $i { last "A" }); $c++; #OK
last;
});
is $c, 2, "last with name picks innermost";
sub loopy () { True }
ok loopy, "can call functions starting with 'loop'";
my @a = "abc" ~~ /abc/;
is +@a, 1, "capture-less matches return 1 item";
@a = "abc" ~~ /(a)(b)(c)/;
is +@a, 3, "capturing matches return catures in list context";
}
{
is ~[4,0 Z+ 2,0 Z+ 1,0], "7 0", "Z+ works";
is ~[1,2 X+ 3,4 X+ 5,6], "9 10 10 11 10 11 11 12", "X+ works";
is ~[4,0 Z 2,0 Z 1,0], "4 2 1 0 0 0", "Z works";
is ~[1,2 X 3,4 X 5,6], "1 3 5 1 3 6 1 4 5 1 4 6 2 3 5 2 3 6 2 4 5 2 4 6", "X works";
ok "{1}" ~~ Str, "string interpolation stringifies";
is q:to[A] , " x\n", "q:to strips equal whitespace";
x
A
}
{
my class X1 {
my @foo = 4, 5, 6;
method a() { @foo }
method b() { [ 1, 2, 3 ] }
method test() {
is +[ @.b ], 3, '@.foo syntax listifies';
is +[ $.a ], 1, '$.foo syntax itemifies';
}
}
X1.test;
constant $foo = 1, 2, 3;
constant @bar = 4;
constant %baz = a => 3, c => 6;
is +[ $foo ], 1, '$-constants itemize';
is +@bar, 1, '@-constants listize';
is %baz<c>, 6, '%-constants hashize';
my class X2 {
method test($x) { $x * $x }
}
my class X3 is X2 {
method test($) {
is callsame(), 25, "callsame() works";
is callwith(self, 6), 36, "callwith() works";
}
}
X3.test(5);
}
{
"f" ~~ /<alpha>?/;
ok $<alpha>.^isa(Match), "? returns match directly on success";
my $r = &return;
sub dfoo() { return; }
sub dbar() { return 5; }
sub dquux() { return 5, 10; }
sub foo() { $r(); }
sub bar() { $r(5); }
sub quux() { $r(5, 10); }
is +[ foo ], 0, "can return no values (i)";
is +[ bar ], 1, "can return one value (i)";
ok (bar() == 5), "one value isn't wrapped (i)";
is +[ quux ], 2, "can return two values (i)";
is +[ dfoo ], 0, "can return no values";
is +[ dbar ], 1, "can return one value";
ok (dbar() == 5), "one value isn't wrapped";
is +[ dquux ], 2, "can return two values";
}
{
"foo" ~~ /\w+/;
is $0, "foo", 'Match[0] returns whole match if no parens';
constant %bar = (:a, :b);
is +[ %bar ], 2, "constant hashes flatten";
}
{
package Foo7426 { }
class Foo7426::Inner {
method pie() { 32 }
}
is Foo7426::Inner.pie, 32, ":: class names work";
class Foo9215::Inner {
method pie() { 64 }
}
is Foo9215::Inner.pie, 64, ":: class names work, without predecl";
eval_dies_ok 'my class A::B { }', 'cannot use :: with my';
eval_dies_ok 'my class A::B { }; B', 'A::B does not install B alias';
}
{
my $x = 5;
$x.=pred;
is $x, 4, ".=foo works (dottyop form)";
$x = 4; $x .= pred;
is $x, 3, ".= foo works (infix form)";
}
{
my class K { }
my class L { has Str $.y }
my Str $x;
ok $x === Str, "typed variable initializes to type object";
lives_ok { $x = "pie" }, "can assign correct type";
dies_ok { $x = True }, "cannot assign wrong type";
my K $z .= new;
ok ($z.defined && $z ~~ K), 'my K $z .= new syntax works';
my $l = L.new;
ok $l.y === Str, "typed attribute initializes to type object";
lives_ok { $l.y = "pie" }, "can assign correct type";
dies_ok { $l.y = True }, "cannot assign wrong type";
}
{
my $log = '';
my $ret = '';
my $var := _newtiedscalar(Any, Any, { $log ~= "F"; $ret }, { $log ~= $_ });
$ret = 5; $log = "";
my $a = $var;
is $a, 5, "fetches work";
is $log, "F", "fetch called once only";
$ret = 3; $log = "";
$var = 9;
is $log, "9", "stores work";
$log = "";
$a = _newtiedscalar(Any, { $log ~= "B" }, { Any }, { Any });
is $log, "", "bind not called spuriously (1)";
$log = "";
$a ::= _newtiedscalar(Any, { $log ~= "B" }, { Any }, { Any });
is $log, "", "bind not called spuriously (2)";
$log = "";
my $b := _newtiedscalar(Any, { $log ~= "B" }, { Any }, { Any }); #OK
is $log, "B", "bind called when needed (bind)";
$log = "";
_newtiedscalar(Any, { $log ~= "B" }, { Any }, { Any }) = 5;
is $log, "B", "bind called when needed (write)";
}
{
sub bar(Str $) {}
lives_ok { bar "foo" }, "can pass correct type";
dies_ok { bar True }, "cannot pass wrong type";
is "foo".$({ uc $_ }), "FOO", "contextualizer variables";
my grammar G19 {
multi token foo:a { x }
multi token foo:b { y }
}
ok "y" ~~ / :lang(G19) <foo> /, "can use multi regex without proto";
my class C20 {
multi method b1(Bool $) { "bool" }
multi method b1(Str $) { "str" }
multi method b2(Bool $) { "bool" }
multi method b2(Any $) { "any" }
multi method b3(Any $) { "any" }
multi method b3(Bool $) { "bool" }
multi method b4(Bool $ , Any $) { "doom" }
multi method b4(Any $ , Bool $) { "doom" }
}
is C20.b1(True), "bool", "multimethods work (1)";
is C20.b1("foo"), "str", "multimethods work (2)";
is C20.b2(True), "bool", "multimethod sorting works (1)";
is C20.b2("foo"), "any", "multimethod sorting works (2)";
is C20.b3(True), "bool", "multimethod sorting works (3)";
is C20.b3("foo"), "any", "multimethod sorting works (4)";
dies_ok { C20.b4("foo", "bar") }, "multimethod fail checking works";
dies_ok { C20.b4(True, True) }, "multimethod tie checking works";
}
{
multi foo(Str $) { "str" }
multi foo(Bool $) { "bool" }
is foo(True), "bool", "multisubs work (1)";
is foo("abc"), "str", "multisubs work (2)";
{
multi foo(Any $) { "any" }
is foo(True), "bool", "augmenting multisubs works (1)";
is foo(5), "any", "augmenting multisubs works (2)";
{
proto foo($) {*}
multi foo(Any $) { "any2" }
is foo(True), "any2", "proto-shadowing works";
}
{
sub foo(Any $) { "any3" }
is foo(True), "any3", "only-shadowing works";
}
}
}
{
sub circumfix:<《 》>($a) { "|{$a}|" }
sub postcircumfix:<「 」>($a,$b) { "|{$a}|{$b}|" }
is 《 2 》, "|2|", "user circumfix works";
is 3「4」, "|3|4|", "user postcircumfix works";
}
{
grammar G4675 {
token TOP { abc }
}
G4675.parse("abc");
ok $/, '.parse sets $/ (1)';
G4675.parse("def");
nok $/, '.parse sets $/ (2)';
}
{
is "a1b2c".subst(/\d/, 'd'), 'adb2c', '.subst works';
is "a1b2c".subst(:global, /\d/, 'd'), 'adbdc', '.subst works with :g';
is "a1b2c".subst(/\d/, {$/+1}, :g), 'a2b3c', '.subst works with $/';
ok Str.^can("subst"), "Str can subst";
ok Str.^can("defined"), "Str can defined";
nok Str.^can("quux"), "Str cannot quux";
rxtest /z .* y [ a ::> x || . ]/, "z.*y[a::>x||.]",
("zyax", "zyb", "zyaxya"), ("zya",);
rxtest /z [ [ a ::> x || . ] | . y ]/, "z[[a::>x||.]|.y]", ("zay",), ();
}
{
my $i = 0;
L1: while $i < 10 { L1.last if $i == 5; $i++ }
is $i, 5, "method .last works";
L2: for 2,3,4 { $i = $_; last L2 if $i == 3; }
is $i, 3, "last in for works";
}
{
my ($str, $v1, $v2);
$str = "abcdef";
substr($str,1,2) = "xy";
is $str, "axydef", "lvalue substr is functional";
$str = "abcdef";
substr($str,1,2) = "jklmno";
is $str, "ajklmnodef", "lvalue substr can change string length";
$str = "abcdef";
$v1 := substr($str,1,2);
$str = "xyzw";
is $v1, "yz", "substr return values read lazily";
$str = "abcdef";
$v1 := substr($str,0,1);
$v2 := substr($str,3,1);
$v1 = "xx";
$v2 = "yy";
is $str, "xxbyydef", "substr thunks track by index";
}
{
my class A {
multi method foo(Str $, Any $) { "A" }
}
my class B is A {
multi method foo(Any $, Str $) { "B" }
}
is B.foo("x","y"), "B", "MRO used as tiebreaker";
multi bar(Str $, Any $) { "X" } #OK
{
multi bar(Any $, Str $) { "Y" }
is bar("a","b"), "Y", "depth used as tiebreaker";
}
my $ok;
given 1 {
when 2 { }
default { $ok = True }
}
ok $ok, "default works";
}
{
my @q;
sub capture() { push @q, caller.hints('$_') }
$_ := 5;
capture;
for 6 { capture }
capture given 7;
capture;
is @q[0], 5, 'can capture $CALLER::_ from run-once block';
is @q[1], 6, 'can capture $_ from a run-many block';
is @q[2], 7, 'can capture temporary $_ from postfix given';
is @q[3], 5, '$_ not disturbed by given';
}
{
$_ := "baar";
ok (/a+/ ?? True !! False), "Regex.Bool works";
is $/.chars, 2, 'Regex.Bool sets $/ properly';
is 'ab-c'.split(/<.ws>/).join('|'), '|ab|-|c|',
'zero-width split works correctly';
}
{
ok ![1,2,3].flattens, "[1,2,3] non-flatteny";
ok [1,2,3].list.flattens, "[1,2,3].list flatteny";
is Array.perl, "Array", ".perl: Array";
is [].perl, "[]", ".perl: []";
is [1].perl, "[1]", ".perl: [1]";
is [1,2,3].perl, "[1, 2, 3]", ".perl: [1,2,3]";
is @([1,2,3]).perl, "[1, 2, 3].list", '.perl: @([1,2,3])';
is Hash.perl, "Hash", ".perl: Hash";
is {a => 1}.perl, '{"a" => 1}', '.perl: {a => 1}';
is %({a => 1}).perl, '{"a" => 1}.hash', '.perl: %({a => 1})';
is Num.perl, "Num", ".perl: Num";
is 5.perl, "5", ".perl: 5";
is Str.perl, "Str", ".perl: Str";
is "foo".perl, '"foo"', '.perl: "foo"';
is Capture.perl, "Capture", '.perl: Capture';
is (\1).perl, '\(1)', '.perl: \1';
is (\(1, :x)).perl, '\(1, |{"x" => Bool::True})', '.perl: \(1, :x)';
is (\(:x)).perl, '\(|{"x" => Bool::True})', '.perl: \(:x)';
is Parcel.perl, "Parcel", '.perl: Parcel';
is ().perl, '()', '.perl: ()';
is (1,).perl, '(1, )', '.perl: (1,)';
is (1,2,3).perl, '(1, 2, 3)', '.perl: (1,2,3)';
is $(1,2,3).perl, '$(1, 2, 3)', '.perl: $(1,2,3)';
}
{
$_ := 5;
if True {
is $_, 5, '$_ passes into ifs';
}
if False {
} else {
is $_, 5, '$_ passes into elses';
}
my $i = 1;
while $i-- {
is $_, 5, '$_ passes into whiles';
}
given 8 {
default {
is $_, 8, '$_ passes into whens/defaults';
}
}
{
is $_, 5, '$_ passes into bare blocks';
}
sub foo($x is rw) { $x }
dies_ok { foo 5 }, "cannot rw-bind constant";
my @foo = 1,2,3; #OK
is "@foo", '@foo', '@-vars do not interpolate';
my $x; my $y;
ok $x =:= $x, '$x =:= $x';
nok $x =:= $y, '$x !=:= $y';
$x := $y;
ok $x =:= $y, '$x =:= $y (after $x := $y)';
my class A {
has $.x;
method foo($bar:) { $.x } #OK
}
is A.new(x => 5).foo, 5, "explicit invocants don't break self";
}
{
my class Foo {
has @.bar;
has %.baz;
has @.quux = 1,2,3;
}
isa_ok Foo.new.bar, Array, '@.bar initializes as an array';
isa_ok Foo.new.baz, Hash, '%.baz initializes as a hash';
is +[ Foo.new(bar => (1,2,4)).bar ], 3, '@.bar initializes with list context';
is +[ Foo.new(bar => 5).bar ], 1, '@.bar can initialize from a single item';
is +[ Foo.new.quux ], 3, '@.quux with init list works';
my $str = '';
for 1,2,3,4 -> $x, $y { $str ~= "$x|$y," }
is $str, "1|2,3|4,", 'multivariable for works';
is "moo".subst('o','a',:g), "maa", '.subst can take Str';
is 'Hello'.substr(1), 'ello', '.substr can take 1 arguaent';
is hash((a => 1)).perl, '{"a" => 1}.hash', '&hash works (1)';
is hash((a => 1, b => 2)).<b>, 2, '&hash works (2)';
is hash({a => 1}).perl, '{"a" => 1}.hash', '&hash works (3)';
my %hash = "foo", 5;
is %hash<foo>, 5, "Hash.LISTSTORE can take keys and values separately";
dies_ok { %hash = "pie" }, "keys must be matched";
}
{
class X7140::X1122 { }
my X7140::X1122 $obj .= new;
isa_ok $obj, X7140::X1122, 'Type constraints via :: work';
sub foo(X7140::X1122 $) { }
lives_ok { foo($obj) }, 'Parameter :: constraints work (1)';
dies_ok { foo(5) }, 'Parameter :: constraints work (1)';
sub bar(@x) {} #OK
lives_ok { bar <a b c> }, '<> splitting counts as one argument';
my class Foo { method foo() { 12 } }
is Foo.?foo, 12, '.? works (successful)';
is +[Foo.?bar], 0, '.? works (unsuccessful, list)';
my $k = 2;
my $st = '';
while $k -> $z { $st ~= $z; $k = False }
is $st, '2', 'while loops can take ->';
$st = ''; $k = False;
until $k -> $z { $st ~= $z; $k = True }
is $st, False, 'until loops can take ->';
$st = '';
unless False -> $z { $st ~= $z }
is $st, False, 'unless can take ->';
$st = ''; $k = True;
repeat until $k -> $z { $st ~= ($z // 5); $k = !$k; }
is $st, 5~False, 'repeat until (prefix) can take ->';
$st = ''; $k = True;
repeat -> $z { $st ~= ($z // 5); $k = !$k; } until $k;
is $st, 5~False, 'repeat until (postfix) can take ->';
}
{
sub foo($x is copy) { $x++; $x }
is foo(5), 6, "is copy works (non inline)";
my $y;
for 5 -> $k is copy { $k++; $y = $k }
is $y, 6, "is copy works (inline)";
}
{
is "filename0000.jpg".succ, "filename0001.jpg", "filename0000.jpg test";
is "000".succ, "001", "basic succ";
is "009".succ, "010", ".succ with carry";
is "099".succ, "100", ".succ with cascading carry";
is "a99".succ, "b00", ".succ with carry across types";
is "z99".succ, "aa00", ".succ with extending (non-digit)";
is "99".succ, "100", ".succ with extending (digit)";
is "001".pred, "000", "basic .pred";
is "010".pred, "009", ".pred with borrow";
is "100".pred, "099", "cascading borrow";
is "b00".pred, "a99", "borrow across types";
is "--99--".succ, "--100--", "lengthening shifts";
is "--00--".succ, "--01--", "not lengthening, no shift";
is "00.00".succ, "01.00", "dot sets endpoint";
is +["a" .. "z"], 26, "char ranges work";
is_deeply [[<za zz az aa>].sort(*.flip)], [<aa za az zz>],
'Automatic Schwartzian transform works';
}
is 10.abs, 10, "10.abs == 10";
is (-10).abs, 10, "(-10).abs == 10";
is (-10).abs.WHAT, 10.WHAT, "(-10).abs and 10 have same WHAT";
{
my $big = 2 ** 200 - 42;
is $big.abs, $big, '$big.abs == $big';
is (-$big).abs, $big, '(-$big).abs == $big';
is (-$big).abs.WHAT, $big.WHAT, '(-$bi).abs and $big have same WHAT';
}
ok (10/2).abs == 10/2, "(10/2).abs == 10/2";
ok (-10/2).abs == 10/2, "(-10/2).abs == 10/2";
is (-10/2).abs.WHAT, (10/2).WHAT, "(-10/2).abs and 10/2 have same WHAT";
ok FatRat.new(10,2).abs == FatRat.new(10,2), "(10/2).abs == 10/2";
ok FatRat.new(-10,2).abs == FatRat.new(10,2), "(-10/2).abs == 10/2";
is FatRat.new(-10,2).abs.WHAT, FatRat, "FatRat.new(-10,2).abs.WHAT";
ok (10.Num).abs == 10.Num, "(10.Num).abs == 10.Num";
ok (-10.Num).abs == 10.Num, "(-10.Num).abs == 10.Num";
is (-10.Num).abs.WHAT, (10.Num).WHAT, "(-10.Num).abs and 10.Num have same WHAT";
ok (10 + 5i).abs == 125.sqrt, "(10 + 5i).abs == 125.sqrt";
ok (-10 - 5i).abs == 125.sqrt, "(-10 - 5i).abs == 125.sqrt";
is (-10 - 5i).abs.WHAT, "Num()", "(-10 - 5i).abs is a Num";
ok (10 + 5i).re == 10, "(10 + 5i).re == 10";
ok (10 + 5i).im == 5, "(10 + 5i).im == 5";
ok (10/3).numerator == 10, "(10/3).numerator == 10";
ok (10/3).denominator == 3, "(10/3).denominator == 3";
is FatRat.new(10,3).WHAT.gist, FatRat.gist, "FatRat.new returns FatRat";
ok FatRat.new(10,3).numerator == 10, "FatRat.new(10,3).numerator == 10";
ok FatRat.new(10,3).denominator == 3, "FatRat.new(10,3).denominator == 3";
class {
is (sub () {}).WHAT.gist, Sub.gist, "sub gets correct class";
is ({ $_ * $_ }).WHAT.gist, Block.gist, "bare block gets correct class";
is /a+/.WHAT.gist, Regex.gist, "regex gets correct class";
is (method a () {}).WHAT.gist, Method.gist, "method gets correct class";
is (submethod b () {}).WHAT.gist, Submethod.gist, "submethod gets correct class";
};
is one(1,2).perl, 'one(1, 2)', '.perl roundtrips one()';
is any(1,2).perl, 'any(1, 2)', '.perl roundtrips any()';
is all(1,2).perl, 'all(1, 2)', '.perl roundtrips all()';
is none(1,2).perl, 'none(1, 2)', '.perl roundtrips none()';
is (1 & 2).perl, 'all(1, 2)', '& means all';
is (1 | 2).perl, 'any(1, 2)', '| means any';
is (1 ^ 2).perl, 'one(1, 2)', '^ means one';
is (1, 2).any.perl, 'any(1, 2)', 'Any.any means any()';
is (1, 2).one.perl, 'one(1, 2)', 'Any.one means one()';
is (1, 2).all.perl, 'all(1, 2)', 'Any.all means all()';
is (1, 2).none.perl, 'none(1, 2)', 'Any.none means none()';
is { a => True }.any.perl, any("a").perl, 'Hash.any means any(keys)';
ok ?(all( True, True)), 'all(True, True)';
nok ?(all( True, False)), '!all(True, False)';
nok ?(all(False, False)), '!all(False, False)';
ok ?(any( True, True)), 'any(True, True)';
ok ?(any( True, False)), 'any(True, False)';
nok ?(any(False, False)), '!any(False, False)';
nok ?(one( True, True)), '!one(True, True)';
ok ?(one( True, False)), 'one(True, False)';
nok ?(one(False, False)), '!one(False, False)';
nok ?(none( True, True)), '!none(True, True)';
nok ?(none( True, False)), 'none(True, False)';
ok ?(none(False, False)), 'none(False, False)';
is ((1 & 3) + 1).perl, 'all(2, 4)', '+ autothreads all';
is ((1 | 3) + 1).perl, 'any(2, 4)', '+ autothreads any';
is (1 == (1 | 3)).perl, 'any(Bool::True, Bool::False)', '== autothreads';
is (4 & 9).sqrt.perl, 'all(2, 3)', '.sqrt autothreads';
is (4 & 9).Bool.perl, 'Bool::True', '.Bool does not autothread';
is (40 & 90).substr(0,1).perl, 'all("4", "9")', '.substr with arguments autothreads';
is ((2 | 4) + (1 & 2)).perl, 'all(any(3, 5), any(4, 6))',
'& takes precedence in multiple autothreading';
{
sub f1($x) { ?$x }
sub f2(Mu $x) { ?$x }
sub f3($x,$y) { $x ~ $y }
is f1(1 | 0).perl, 'any(Bool::True, Bool::False)',
'simple autothreading of only sub';
is f2(1 | 0).perl, 'Bool::True', 'non-autothreading of sub that takes Mu';
is f3((1 | 0), (1 | 0)).perl, 'any(any("11", "10"), any("01", "00"))',
'autothreading of multi-arg only sub';
}
nok ?("foo" !eq any("foo","bar")), "foo !eq (foo | bar)";
ok ?("foo" !eq any("quux","bar")), "foo !eq (quux | bar)";
nok ?(2 != any(2, 4)), "2 != (2|4)";
ok ?(2 != any(0, 4)), "2 != (0|4)";
ok 2 ~~ any(Int, Num), "junctional ~~ works";
{
my package Thing {
our sub foo() { 42 }
is foo(), 42, 'direct call to our sub works';
is &OUR::foo.(), 42, 'call via &OUR::foo works';
is OUR::foo, 42, 'call via OUR::foo works';
}
is Thing::foo, 42, 'call via Thing::foo works for inside declared sub';
our sub Thing::bar() { 84 }
is Thing::bar, 84, 'call via Thing::bar for outside declared works';
}
ok $?FILE ~~ /test2?\.pl/, '$?FILE works';
Jump to Line
Something went wrong with that request. Please try again.