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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
use strict;
use warnings;
use Test::More;
use Test::Exception;
use Parse::Method::Signatures;
my @sigs = (
['()', 'empty signature'],
['($x)', 'single required positional'],
['($x:)', 'invocant only'],
['($x, $y)', 'two required positionals'],
['($x where { $_->isa("Moose") })',
'with constraint'],
['($x where { $_->isa("Moose") } where { $_->does("Gimble") })',
'multiple constraints'],
['(Str $name)', 'typed positional'],
['(Int $x, Str $y)', 'multiple typed positionals'],
['(Animal|Human $affe)', 'type constraint alternative'],
['(Some::Class $x)', 'type constraint with colon'],
['(Some2Class $x)', 'type constraint with number in middle'],
['(SomeClass2 $x)', 'type constraint with number at end'],
['(Tuple[Int,Str] $x)', 'parameterized types'],
['(Str|Tuple[Int,Str] $x)', 'parameterized with alternative'],
['($: $x, $y, $z)', 'dummy invocant'],
['($, $, $x)', 'dummy positionals'],
['($x, @)', 'dummy list'],
['(:$x)', 'optional named'],
['(:$x!)', 'required named'],
['(Str :$x)', 'named with type constraint'],
['($x, $y, :$z)', 'positional and named'],
['($x, $y?, :$z)', 'optional positional and named'],
['(:$a, :$b, :$c)', 'multiple named'],
['($a, $b, :$c!, :$d!)', 'positional and multiple required named'],
['($a?, $b?, :$c, :$d)', 'optional positional and named'],
['(:$x! where { 1 })', 'required named with constraint'],
['($self: $moo)', 'invocant and positional'],
['(:apan($affe))', 'long named'], # called as $obj->foo(apan => $value)
['(:apan($affe)!)', 'required long named'],
['($self: :$x)', 'named param with invocant'],
['($: :$x)', 'named param with dummy invocant'],
['($x = 42)', 'positional with default'],
['(:$x = 42)', 'named with default'],
['($x = "foo")', 'simple string default'],
['($x = "foo, bar")', 'string default with comma'],
["(\$x = 'foo, bar')", 'single quoted default with comma'],
['($x = q"foo")', 'default with q"" quoting'],
['($x = q{foo})', 'default with q{} quoting'],
['($x = q(foo))', 'default with q() quoting'],
['($x = q,foo,)', 'default with q,, quoting'],
['($x, $y = $x)', 'default based on other paramter'],
['(Str :$who, Int :$age where { $_ > 0 })',
'complex with constraint'],
['(Str $name, Bool :$excited = 0)',
'complex with default'],
[q#(SomeClass $thing where { $_->can('stuff') })#,
'complex with constraint'],
[q#(SomeClass $thing where { $_->can('stuff') }: Str $bar = "apan", Int :$baz = 42 where { $_ % 2 == 0 } where { $_ > 10 })#,
'complex invocant, defaults and constraints'],
['(@x)', 'positional array'],
['($x, @y)', 'positinal scalar and array'],
['(%x)', 'positinal hash'],
['($x, %y)', 'positinal scalar and hash'],
['([$x, $y])', 'simple array ref unpacking'],
['(ArrayRef [$x, $y])', 'simple array ref unpacking with unparameterized type', 'TODO'],
['(ArrayRef[] [$x, $y])', 'simple array ref unpacking with empty parameterized type',],
['([@x])', 'array ref unpacking into array'],
['([$x, $y, @rest])', 'array ref unpacking into scalars and arrays'],
['($x, [$y, $z, @rest])', 'array ref unpacking combined with normal positionals'],
['([$y, $z, @rest], $x)', 'array ref unpacking combined with normal positionals'],
['([$y, $z, @rest], :$x)', 'array ref unpacking combined with named'],
['(:foo([$x, $y, @rest]))', 'named array ref unpacking'],
['({%x})', 'hash ref unpacking into hash'],
['(:foo({%x}))', 'labeld hash ref unpacking into hash'],
['({:$x, :$y, %rest})', 'hash ref unpacking into scalars and hash'],
['($x, {:$y, :$z, %rest})', 'hash ref unpacking combined with normal positionals'],
['({:$y, :$z, %rest}, $x)', 'hash ref unpacking combined with normal positionals'],
['({:$x, :$y, %r}, :$z)', 'hash ref unpacking combined with named'],
['(:foo({:$x, :$y, %r}))', 'named hash ref unpacking'],
['(:foo($), :bar(@))', 'named placeholders'],
['(Foo[Bar|Baz[Moo]]|Kooh $foo)',
'complex parameterized type'],
['($foo is coerce)', 'positional with traits (is)'],
['($foo does coerce)', 'positional with traits (does)'],
['(:$foo is coerce)', 'named with traits (is)'],
['(:$foo does coerce)', 'named with traits (does)'],
['($foo is copy is ro does coerce)',
'multiple traits'],
['($x = "foo")', 'string default'],
['($x = q"fo)o")', 'string default'],
['($x = [ ])', 'simple array default'],
['($x = { })', 'simple hash default'],
['($x = 0xf)', 'hex default'],
['($x = 0xfF)', 'hex default'],
);
my @alternative = (
[q{($param1, # Foo bar
$param2?)}, '($param1, $param2?)', 'comments in multiline'],
['(:$x = "foo")', '(:$x = "foo")', 'default value stringifies okay'],
['($self: $moo)', '($self: $moo)', 'invocant and positional'],
['(Animal | Human $affe)', '(Animal|Human $affe)', 'type constraint alternative with whitespace'],
['(HashRef[foo => Str] $foo)',
'(HashRef["foo",Str] $foo)', 'Hash with required key'],
);
my @invalid = (
['($x?:)', 'optional invocant'],
['(@x:)', 'non-scalar invocant'],
['(%x:)', 'non-scalar invocant'],
['($x?, $y)', 'required positional after optional one'],
['(Int| $x)', 'invalid type alternation'],
['(|Int $x)', 'invalid type alternation'],
['(@x, $y)', 'scalar after array'],
['(@x, @y)', 'multiple arrays'],
['(%x, %y)', 'multiple hashes'],
['(@, $x)', 'scalar after array placeholder'],
['(:@x)', 'named array'],
['(:%x)', 'named hash'],
['(:@)', 'named array placeholder'],
['(:%)', 'named hash placeholder'],
['(:[@x])', 'named array ref unpacking without label'],
['([:$x, :$y])', 'unpacking array ref to something not positional'],
['(:{%x})', 'named hash ref unpacking without label'],
['({$x, $y})', 'unpacking hash ref to something not named'],
['($foo where { 1, $bar)', 'unbalanced { in conditional'],
['($foo = `pwd`)', 'invalid quote op', "Do we want to allow this"],
['($foo = "pwd\')', 'unbalanced quotes'],
['(:$x:)', 'named invocant is invalid'],
['($x! = "foo":)', 'default value for invocant is invalid'],
['($foo is bar moo is bo)', 'invalid traits'],
['(Foo:: Bar $foo)', 'invalid spaces in TC'],
['(Foo ::Bar $foo)', 'invalid spaces in TC'],
['(@y: $foo)', 'invalid invocant'],
['(@y,)', 'trailing comma'],
['($x where [ foo ])', 'no block after where'],
['($x does $x)', 'invalid param trait'],
['(:foo(Str $x))', 'invalid label contents'],
# This should probably be valid
['($x = $a[0])', 'invalid label contents'],
);
my @no_warn = (
['($x where { $_ =~ /foo/ })', 'Regexp without operator' ]
);
plan tests => scalar @sigs * 3
+ scalar @alternative
+ scalar @invalid
+ scalar @no_warn
;
test_sigs(sub {
my ($input, $msg, $todo) = @_;
my $sig;
lives_ok {
$sig = Parse::Method::Signatures->signature($input);
} $msg;
isa_ok($sig, 'Parse::Method::Signatures::Sig', $msg);
TODO: {
todo_skip $todo, 1 if $todo && !$sig;
is($sig->to_string, $input, $msg);
}
}, @sigs);
for my $row (@alternative) {
my ($in, $out, $msg) = @{ $row };
lives_and {
is(Parse::Method::Signatures->signature($in)->to_string, $out, $msg)
} $msg;
}
test_sigs(sub {
my ($sig, $msg) = @_;
dies_ok { Parse::Method::Signatures->signature($sig) } $msg;
}, @invalid);
test_no_warn(@no_warn);
sub test_sigs {
my ($test, @sigs) = @_;
for my $row (@sigs) {
my ($sig, $msg, $todo) = @{ $row };
TODO: {
local $TODO = $todo if $todo;
$test->($sig, $msg, $todo);
}
}
}
sub test_no_warn {
my (@sigs) = @_;
my $warnings = "";
local $SIG{__WARN__} = sub { $warnings .= "@_"; };
for my $row (@sigs) {
my ($sig, $msg, $todo) = @{ $row };
TODO: {
$warnings = "";
local $TODO = $todo if $todo;
Parse::Method::Signatures->signature($sig);
is("", $warnings, $msg || "'$sig' generated no warnings");
}
}
}
|
