Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[t] move some tests to spec/, re-worked pre-post.t, some minor correc…

…tions and

rakudo fudgings


git-svn-id: http://svn.pugscode.org/pugs@22514 c213334d-75ef-0310-aa23-eaa082d1ae64
  • Loading branch information...
commit e7ca07b160707c2cd5f108a14ca6c483c259d9f9 1 parent 6425024
moritz authored
71 S04-closure-traits/keep-undo.t
View
@@ -0,0 +1,71 @@
+use v6;
+
+use Test;
+
+plan 10;
+
+# L<S04/Closure traits/KEEP "at every successful block exit">
+# L<S04/Closure traits/UNDO "at every unsuccessful block exit">
+
+{
+ my $str;
+ my sub is_pos ($n) {
+ return (($n > 0) ?? 1 !! undef);
+ KEEP { $str ~= "$n > 0 " }
+ UNDO { $str ~= "$n <= 0 " }
+ }
+
+ ok is_pos(1), 'is_pos worked for 1';
+ is $str, '1 > 0 ', 'KEEP ran as expected';
+
+ ok !is_pos(0), 'is_pos worked for 0';
+ is $str, '1 > 0 0 <= 0 ', 'UNDO worked as expected';
+
+ ok !is_pos(-1), 'is_pos worked for 0';
+ is $str, '1 > 0 0 <= 0 -1 <= 0 ', 'UNDO worked as expected';
+}
+
+# L<S04/Closure traits/KEEP UNDO are "variants of LEAVE"
+# "treated as part of the queue of LEAVE blocks">
+{
+ my $str;
+ my sub is_pos($n) {
+ return (($n > 0) ?? 1 !! undef);
+ LEAVE { $str ~= ")" }
+ KEEP { $str ~= "$n > 0" }
+ UNDO { $str ~= "$n <= 0" }
+ LEAVE { $str ~= "(" }
+ }
+
+ is_pos(1);
+ is $str, '(1 > 0)', 'KEEP triggered as part of LEAVE blocks';
+
+ is_pos(-5);
+ is $str, '(1 > 0)(-5 <= 0)', 'UNDO triggered as part of LEAVE blocks';
+}
+
+# L<S04/Closure traits/"can occur multiple times">
+
+# multiple KEEP/UNDO
+{
+ my $str;
+ {
+ KEEP { $str ~= 'K1 ' }
+ KEEP { $str ~= 'K2 ' }
+ UNDO { $str ~= 'U1 ' }
+ UNDO { $str ~= 'U2 ' }
+ 1;
+ }
+ is $str, 'K2 K1 ', '2 KEEP blocks triggered';
+}
+
+{
+ my $str;
+ {
+ KEEP { $str ~= 'K1 ' }
+ KEEP { $str ~= 'K2 ' }
+ UNDO { $str ~= 'U1 ' }
+ UNDO { $str ~= 'U2 ' }
+ }
+ is $str, 'U2 U1 ', '2 UNDO blocks triggered';
+}
38 S04-closure-traits/multiple.t
View
@@ -0,0 +1,38 @@
+use v6;
+
+# [TODO] add tests for ENTER/LEAVE/KEEP/UNDO/PRE/POST/etc
+
+# Test multiple closure traits.
+
+use Test;
+
+plan 2;
+
+# L<S04/Closure traits/"occur multiple times">
+# IRC log:
+# [05:41] <agentzh> TimToady: S04 doesn't discuss the running order
+# of multiple closure traits (say, two END {} in
+# the same scope), so should we assume it's the
+# same as in Perl 5?
+# [05:41] <TimToady> yes
+
+my $hist;
+
+END { is $hist, 'B b c C I i S s end End ', 'running order of multiple closure traits' }
+
+END { $hist ~= 'End ' }
+END { $hist ~= 'end ' }
+
+START { $hist ~= 'S ' }
+START { $hist ~= 's ' }
+
+INIT { $hist ~= 'I ' }
+INIT { $hist ~= 'i ' }
+
+CHECK { $hist ~= 'C ' }
+CHECK { $hist ~= 'c ' }
+
+BEGIN { $hist ~= 'B ' }
+BEGIN { $hist ~= 'b ' }
+
+is $hist, 'B b c C I i S s ', 'running order of multiple closure traits';
151 S04-closure-traits/next.
View
@@ -0,0 +1,151 @@
+use v6;
+
+use Test;
+
+plan 13;
+
+# L<S04/Closure traits/NEXT executes "only if"
+# "end of the loop block" or "explicit next">
+{
+ my $str = '';
+ for 1..5 {
+ NEXT { $str ~= ':' }
+ next if $_ % 2 == 1;
+ $str ~= $_;
+ }
+ is $str, ':2::4::', 'NEXT called by both next and normal falling out';
+}
+
+# NEXT is positioned at the bottom:
+{
+ my $str = '';
+ for 1..5 {
+ next if $_ % 2 == 1;
+ $str ~= $_;
+ NEXT { $str ~= ':' }
+ }
+ is $str, ':2::4::', 'NEXT called by both next and normal falling out';
+}
+
+# NEXT is positioned in the middle:
+{
+ my $str = '';
+ for 1..5 {
+ next if $_ % 2 == 1;
+ NEXT { $str ~= ':' }
+ $str ~= $_;
+ }
+ is $str, ':2::4::', 'NEXT called by both next and normal falling out';
+}
+
+# NEXT is evaluated even at the last iteration
+{
+ my $str = '';
+ for 1..2 {
+ NEXT { $str ~= 'n'; }
+ LAST { $str ~= 'l'; }
+ }
+ is $str, 'nnl', 'NEXT are LAST blocks may not be exclusive';
+}
+
+# L<S04/Closure traits/NEXT "not executed" if exited
+# "via any exception other than" next>
+
+{
+ my $str = '';
+ try {
+ for 1..5 {
+ NEXT { $str ~= $_ }
+ die if $_ > 3;
+ }
+ }
+ is $str, '123', "die didn't trigger NEXT \{}";
+}
+
+{
+ my $str = '';
+ try {
+ for 1..5 {
+ NEXT { $str ~= $_ }
+ leave if $_ > 3;
+ }
+ }
+ is $str, '123', "leave didn't trigger NEXT \{}";
+}
+
+{
+ my $str = '';
+ my sub foo {
+ for 1..5 {
+ NEXT { $str ~= $_ }
+ return if $_ > 3;
+ }
+ }
+ foo();
+ is $str, '123', "return didn't trigger NEXT \{}";
+}
+
+# L<S04/Closure traits/last bypasses "NEXT blocks">
+{
+ my $str = '';
+ for 1..5 {
+ NEXT { $str ~= $_; }
+ last if $_ > 3;
+ }
+ is $str, '123', "last bypass NEXT \{}";
+}
+
+# L<S04/Closure traits/NEXT "before any LEAVE">
+
+{
+ my $str = '';
+ for 1..2 {
+ NEXT { $str ~= 'n' }
+ LEAVE { $str ~= 'l' }
+ }
+ is $str, 'nlnl', 'NEXT {} ran before LEAVE {} (1)';
+}
+
+# reversed order
+{
+ my $str = '';
+ for 1..2 {
+ LEAVE { $str ~= 'l' }
+ NEXT { $str ~= 'n' }
+ }
+ is $str, 'nlnl', 'NEXT {} ran before LEAVE {} (2)';
+}
+
+# L<S04/Closure traits/NEXT "at loop continuation time">
+
+# L<http://groups.google.com/group/perl.perl6.language/msg/07370316d32890dd>
+
+{
+ my $str = '';
+ my $n = 0;
+ my $i;
+ while $n < 5 {
+ NEXT { ++$n } # this gets run second (LIFO)
+ NEXT { $str ~= $n } # this gets run first (LIFO)
+ last if $i++ > 100; # recursion prevension
+ }
+ is $str, '01234', 'NEXT {} ran in reversed order';
+}
+
+{
+ my $str = '';
+ loop (my $n = 0; $n < 5; ++$n) {
+ NEXT { $str ~= $n }
+ }
+ is $str, '01234', 'NEXT {} works in loop (;;) {}';
+}
+
+{
+ my @x = 0..4;
+ my $str = '';
+ for @x {
+ NEXT { $str ~= $_; }
+ }
+
+ is($str, '01234', 'NEXT {} works in for loop');
+}
102 S04-closure-traits/pre-post.t
View
@@ -8,43 +8,31 @@ use Test;
#
# TODO:
# * Multiple inheritance + PRE/POST blocks
-# * check that the POST block receives the return value as topic ($_)
-plan 16;
+plan 18;
-my $foo = '
sub foo(Num $i) {
PRE {
$i < 5
}
return 1;
}
-';
-sub bar(int $i) {
+sub bar(Int $i) {
return 1;
POST {
$i < 5;
}
}
-ok eval($foo ~ 'foo(2);'), 'sub with PRE compiles and runs';
-ok eval(bar(3)), 'sub with POST compiles';
+lives_ok { foo(2) }, 'sub with PRE compiles and runs';
+lives_ok { bar(3) }, 'sub with POST compiles and runs';
-try {
- eval($foo ~ 'foo(10)');
-}
-
-ok defined($!), 'Violated PRE fails OK';
-
-try {
- bar(10);
-}
-ok defined($!), 'violated POST fails OK';
+dies_ok { foo(10) }, 'Violated PRE throws (catchable) exception';
+dies_ok { bar(10) }, 'Violated POST throws (catchable) exception';
# multiple PREs und POSTs
-my $baz = '
sub baz (Num $i) {
PRE {
$i > 0
@@ -54,14 +42,11 @@ sub baz (Num $i) {
}
return 1;
}
-';
-ok($baz ~ 'baz(2)', 'sub with two PREs compiles and runs');
+lives_ok { baz(2) }, 'sub with two PREs compiles and runs';
-eval( $baz ~ 'baz(-1)');
-ok(defined($!), 'sub with two PREs fails when first is violated');
+dies_ok { baz(-1)}, 'sub with two PREs fails when first is violated';
+dies_ok { baz(42)}, 'sub with two PREs fails when second is violated');
-eval( $baz ~ 'baz(42)');
-ok(defined($!), 'sub with two PREs fails when second is violated');
sub qox (Num $i) {
return 1;
@@ -73,80 +58,69 @@ sub qox (Num $i) {
}
}
-ok(qox(23), "sub with two POSTs compiles and runs");
-
-try {
- qox(-1);
-}
-
-ok(defined($!), "sub with two POSTs fails if first POST is violated");
-
-try {
- qox(123);
-}
-
-ok(defined($!), "sub with two POSTs fails if second POST is violated");
+lives_ok({ qox(23) }, "sub with two POSTs compiles and runs");
+dies_ok( { qox(-1) }, "sub with two POSTs fails if first POST is violated");
+dies_ok( { qox(123)}, "sub with two POSTs fails if second POST is violated");
# inheritance
-my $ih_pre =
-' class Foo {
+class PRE_Parent {
method test(Num $i) {
PRE {
- $i > 23
+ $i < 23
}
-
return 1;
}
}
-class Bar is Foo {
+class PRE_Child is PRE_Parent {
method test(Num $i){
PRE {
- $i < -23
+ $i > 0;
}
return 1;
}
}
-my $foo = Bar.new; ';
-ok(eval($ih_pre ~ '$foo.test(-42)'), "PRE in methods compiles and runs");
-ok(eval($ih_pre ~ '$foo.test(42)'), "inherited PRE in compiles and runs");
+my $foo = PRE_Child.new;
-try {
- eval($ih_pre ~ '$foo.test(0)');
-}
+lives_ok { $foo.test(5) }, 'PRE in methods compiles and runs';
+dies_ok { $foo.test(-42) }, 'PRE in child throws';
+dies_ok { $foo.test(78) }, 'PRE in parent throws';
-ok(defined($!), "violated PRE in methods fails OK");
-
-class Foo {
+class POST_Parent {
method test(Num $i) {
return 1;
POST {
- $i < 23
+ $i > 23
}
}
}
-class Bar is Foo {
+class POST_Child is POST_Parent {
method test(Num $i){
return 1;
POST {
- $i > -23
+ $i < -23
}
}
}
-my $foo_post = Bar.new;
+my $mp = POST_Child.new;
-ok(eval('$foo_post.test(0)'), "Inherited POST compiles and runs");
+lives_ok { $mp.test(-42) }, "It's enough if we satisfy one of the POST blocks (Child)";
+lives_ok { $mp.test(42) }, "It's enough if we satisfy one of the POST blocks (Parent)";
+dies_ok { $tmp.test(12) }, 'Violating poth POST blocks throws an error';
-try {
- $foo_post.test(42);
+class Another {
+ method test(Num $x) {
+ return 3 * $x;
+ POST {
+ $_ > 4
+ }
+ }
}
-ok(defined($!), "Inherited POST fails ok");
-try {
- $foo_post.test(-42);
-}
-ok(defined($!), "Own POST fails ok");
+my $pt = Another.new;
+lives_ok { $pt.test(2) }, 'POST receives return value as $_ (succeess)';
+dies_ok { $pt.test(1) }, 'POST receives return value as $_ (failure)';
111 S06-signature/sub-ref.t
View
@@ -0,0 +1,111 @@
+use v6;
+
+
+use Test;
+
+plan 33;
+
+=begin description
+
+These tests test subroutine references and their invocation.
+
+See L<S02/"Built-in Data Types"> for more information about Code, Routine, Sub, Block, etc.
+
+=end description
+
+# See L<S02/"Built-in Data Types"> and especially L<A06/"The C<sub> form"> why {...} and ->
+# ... {...} aren't Subs, but Blocks (they're all Codes, though).
+# Quoting A06:
+# Code
+# ____________|________________
+# | |
+# Routine Block
+# ________________|_______________
+# | | | | | |
+# Sub Method Submethod Multi Rule Macro
+
+{
+ my $foo = sub () { 42 };
+ isa_ok($foo, Code);
+ #?rakudo 2 todo 'types Sub, Routine'
+ isa_ok($foo, Routine);
+ isa_ok($foo, Sub);
+ is $foo.(), 42, "basic invocation of an anonymous sub";
+ #?rakudo todo 'signature error checking'
+ dies_ok { $foo.(23) }, "invocation of an parameterless anonymous sub with a parameter dies";
+}
+
+#?rakudo skip 'pointy blocks'
+{
+ my $foo = -> { 42 };
+ isa_ok($foo, Code);
+ isa_ok($foo, Block);
+ is $foo.(), 42, "basic invocation of a pointy block";
+ dies_ok { $foo.(23) }, "invocation of an parameterless pointy block with a parameter dies";
+}
+
+{
+ my $foo = { 100 + $^x };
+ isa_ok($foo, 'Code');
+ isa_ok($foo, 'Block');
+ is $foo.(42), 142, "basic invocation of a pointy block with a param";
+ dies_ok { $foo.() }, "invocation of an parameterized block expecting a param without a param dies";
+}
+
+{
+ my $foo = sub { 100 + (@_[0] // -1) };
+ isa_ok($foo, Code);
+ #?rakudo 2 todo 'types Sub, Routine'
+ isa_ok($foo, Routine);
+ isa_ok($foo, Sub);
+ is $foo.(42), 142, "basic invocation of a perl5-like anonymous sub (1)";
+ is $foo.(), 99, "basic invocation of a perl5-like anonymous sub (2)";
+}
+
+{
+ my $foo = sub ($x) { 100 + $x };
+ isa_ok($foo, Code);
+ #?rakudo 2 todo 'types Sub, Routine'
+ isa_ok($foo, Routine);
+ isa_ok($foo, Sub);
+ is $foo.(42), 142, "calling an anonymous sub with a positional param";
+ #?rakudo skip 'calling positiona parameters by name'
+ is $foo.(x => 42), 142, "calling an anonymous sub with a positional param addressed by name";
+ dies_ok { $foo.() },
+ "calling an anonymous sub expecting a param without a param dies";
+ dies_ok { $foo.(42, 5) },
+ "calling an anonymous sub expecting one param with two params dies";
+}
+
+# Confirmed by p6l, see thread "Anonymous macros?" by Ingo Blechschmidt
+# L<"http://www.nntp.perl.org/group/perl.perl6.language/21825">
+#?rakudo skip 'macros, compile time binding'
+{
+ # We do all this in a eval() not because the code doesn't parse,
+ # but because it's safer to only call macro references at compile-time.
+ # So we'd need to wrap the code in a BEGIN {...} block. But then, our test
+ # code would be called before all the other tests, causing confusion. :)
+ # So, we wrap the code in a eval() with an inner BEGIN.
+ # (The macros are subject to MMD thing still needs to be fleshed out, I
+ # think.)
+ our &foo_macro ::= macro ($x) { "1000 + $x" };
+ isa_ok(&foo_macro, Code);
+ isa_ok(&foo_macro, Routine);
+ #?pugs todo 'macros'
+ isa_ok(&foo_macro, Macro);
+
+ is foo_macro(3), 1003, "anonymous macro worked";
+}
+
+#?rakudo skip 'scoping/closures'
+{
+ my $mkinc = sub { my $x = 0; return sub { $x++ }; };
+
+ my $inc1 = $mkinc();
+ my $inc2 = $mkinc();
+
+ is($inc1(), 0, "clousures: inc1 == 0");
+ is($inc1(), 1, "clousures: inc1 == 1");
+ is($inc2(), 0, "clousures: inc2 == 0");
+ is($inc2(), 1, "clousures: inc2 == 1");
+}
Please sign in to comment.
Something went wrong with that request. Please try again.