-
Notifications
You must be signed in to change notification settings - Fork 135
/
submethods.t
124 lines (99 loc) · 3.8 KB
/
submethods.t
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
use v6;
use Test;
plan 27;
=begin pod
Basic submethod tests. See L<S12/"Submethods">
=end pod
# L<S12/Submethods>
{
class Foo { has $.foo_build; submethod BUILD() { $!foo_build++ } }
class Bar is Foo { has $.bar_build; submethod BUILD() { $!bar_build++ } }
my $a;
lives-ok {$a = Foo.new()}, "Foo.new() worked (1)";
is $a.foo_build, 1, "Foo's BUILD was called";
# is instead of todo_is to avoid unexpected succeedings
dies-ok { $a.bar_build }, "Bar's BUILD counter not available";
my $b;
lives-ok {$b = Bar.new()}, "Bar.new() worked";
is $b.foo_build, 1, "Foo's BUILD was called again";
is $b.bar_build, 1, "Bar's BUILD was called, too";
# The next three tests are basically exactly the same as the first three tests
# (not counting the initial class definition). This is to verify our call to
# Bar.new didn't removed/changed some internal structures which'd prevent
# Foo.BUILD of getting called.
my $c;
lives-ok {$c = Foo.new()}, "Foo.new() worked (2)";
is $c.foo_build, 1, "Foo's BUILD was called again";
}
# See thread "BUILD and other submethods" on p6l
# L<"http://groups-beta.google.com/group/perl.perl6.language/msg/e9174e5538ded4a3">
{
class Baz {
has $.baz_blarb = 0;
submethod blarb() { $!baz_blarb++ }
}
class Grtz is Baz {
has $.grtz_blarb = 0;
submethod blarb() { $!grtz_blarb++ }
}
my ($baz, $grtz);
lives-ok {$baz = Baz.new}, "Baz.new() worked";
lives-ok {$grtz = Grtz.new}, "Grtz.new() worked";
lives-ok { $baz.blarb }, 'can call submethod on parent class';
is $baz.baz_blarb, 1, "Baz's submethod blarb was called";
is $grtz.grtz_blarb, 0, "Grtz's submethod blarb was not called";
lives-ok { $grtz.blarb }, 'can call submethod on child class';
is $grtz.baz_blarb, 0, "Baz's submethod blarb was not called";
is $grtz.grtz_blarb, 1, "Grtz's submethod blarb was called now";
lives-ok { $grtz.Baz::blarb }, '$obj.Class::submthod';
is $grtz.baz_blarb, 1, "Baz's submethod blarb was called now";
is $grtz.grtz_blarb, 1, "Grtz's submethod blarb was not called again";
}
# Roles with BUILD
# See thread "Roles and BUILD" on p6l
# L<"http://www.nntp.perl.org/group/perl.perl6.language/21277">
#?rakudo skip 'outer lexicals in roles RT #124850'
#?niecza todo
{
my $was_in_a1_build = 0;
my $was_in_a2_build = 0;
role RoleA1 { multi submethod BUILD() { $was_in_a1_build++ } }
role RoleA2 { multi submethod BUILD() { $was_in_a2_build++ } }
class ClassA does RoleA1 does RoleA2 {}
ClassA.new;
is $was_in_a1_build, 1, "roles' BUILD submethods were called when mixed in a class (1)";
is $was_in_a2_build, 1, "roles' BUILD submethods were called when mixed in a class (2)";
}
#?rakudo skip 'roles and submethods RT #124851'
#?DOES 4
{
my $was_in_b1_build = 0;
my $was_in_b2_build = 0;
role RoleB1 { multi submethod BUILD() { $was_in_b1_build++ } }
role RoleB2 { multi submethod BUILD() { $was_in_b2_build++ } }
class ClassB {}
my $B = ClassB.new;
is $was_in_b1_build, 0, "roles' BUILD submethods were not yet called (1)";
is $was_in_b2_build, 0, "roles' BUILD submethods were not yet called (2)";
$B does (RoleB1, RoleB2);
#?niecza 2 todo
is $was_in_b1_build, 1, "roles' BUILD submethods were called now (1)";
is $was_in_b2_build, 1, "roles' BUILD submethods were called now (2)";
};
# BUILD with signatures that don't map directly to attributes
{
class ClassC
{
has $.double_value;
submethod BUILD ( :$value = 1 )
{
$!double_value = $value * 2;
}
}
my $C = ClassC.new();
is( $C.double_value, 2,
'BUILD() should allow default values of optional params in signature' );
my $C2 = ClassC.new( :value(100) );
is( $C2.double_value, 200, '... or value passed in' );
}
# vim: ft=perl6