Commit | Line | Data |
8343b16e |
1 | use strict; |
2 | use warnings; |
e7be1784 |
3 | use Devel::Declare (); |
4 | |
5 | { |
6 | package MethodHandlers; |
7 | |
8 | use strict; |
9 | use warnings; |
10 | use Devel::Declare::Context::Simple; |
11 | |
12 | # undef -> my ($self) = shift; |
13 | # '' -> my ($self) = @_; |
14 | # '$foo' -> my ($self, $foo) = @_; |
15 | |
16 | sub make_proto_unwrap { |
17 | my ($proto) = @_; |
18 | my $inject = 'my ($self'; |
19 | if (defined $proto) { |
7a3f5539 |
20 | $proto =~ s/[\r\n\s]+/ /g; |
e7be1784 |
21 | $inject .= ", $proto" if length($proto); |
22 | $inject .= ') = @_; '; |
23 | } else { |
24 | $inject .= ') = shift;'; |
25 | } |
26 | return $inject; |
27 | } |
28 | |
29 | sub parser { |
30 | my $ctx = Devel::Declare::Context::Simple->new->init(@_); |
31 | |
32 | $ctx->skip_declarator; |
33 | my $name = $ctx->strip_name; |
34 | my $proto = $ctx->strip_proto; |
01fadf71 |
35 | |
36 | # Check for an 'is' to test strip_name_and_args |
37 | my $word = $ctx->strip_name; |
38 | my $traits; |
39 | if (defined($word) && ($word eq 'is')) { |
40 | $traits = $ctx->strip_names_and_args; |
41 | } |
42 | |
e7be1784 |
43 | my $inject = make_proto_unwrap($proto); |
44 | if (defined $name) { |
45 | $inject = $ctx->scope_injector_call().$inject; |
46 | } |
47 | $ctx->inject_if_block($inject); |
48 | if (defined $name) { |
49 | $name = join('::', Devel::Declare::get_curstash_name(), $name) |
50 | unless ($name =~ /::/); |
01fadf71 |
51 | # for trait testing we're just interested in the trait parse result, not |
52 | # the method body and its injections |
53 | $ctx->shadow(sub (&) { |
54 | no strict 'refs'; |
55 | *{$name} = $traits |
56 | ? sub { $traits } |
57 | : shift; |
58 | }); |
e7be1784 |
59 | } else { |
60 | $ctx->shadow(sub (&) { shift }); |
61 | } |
62 | } |
63 | |
64 | } |
65 | |
66 | my ($test_method1, $test_method2, @test_list); |
67 | |
68 | { |
69 | package DeclareTest; |
70 | |
71 | sub method (&); |
72 | |
73 | BEGIN { |
74 | Devel::Declare->setup_for( |
75 | __PACKAGE__, |
76 | { method => { const => \&MethodHandlers::parser } } |
77 | ); |
78 | } |
79 | |
80 | method new { |
81 | my $class = ref $self || $self; |
82 | return bless({ @_ }, $class); |
83 | } |
84 | |
85 | method foo ($foo) { |
86 | return (ref $self).': Foo: '.$foo; |
87 | } |
88 | |
01fadf71 |
89 | method has_many_traits() is (Trait1, Trait2(foo => 'bar'), Baz(one, two)) { |
90 | return 1; |
91 | } |
92 | |
93 | method has_a_trait() is Foo1 { |
94 | return 1; |
95 | } |
96 | |
e7be1784 |
97 | method upgrade(){ # no spaces to make case pathological |
98 | bless($self, 'DeclareTest2'); |
99 | } |
100 | |
101 | method DeclareTest2::bar () { |
102 | return 'DeclareTest2: bar'; |
103 | } |
104 | |
105 | $test_method1 = method { |
106 | return join(', ', $self->{attr}, $_[1]); |
107 | }; |
108 | |
109 | $test_method2 = method ($what) { |
110 | return join(', ', ref $self, $what); |
111 | }; |
112 | |
113 | method main () { return "main"; } |
114 | |
115 | @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); |
116 | |
7a3f5539 |
117 | method multiline1( |
118 | $foo |
119 | ) |
120 | { |
121 | return "$foo$foo"; |
122 | } |
123 | |
124 | method multiline2( |
125 | $foo, $bar |
126 | ) { return "$foo $bar"; } |
127 | |
128 | method |
129 | multiline3 ($foo, |
130 | $bar) { |
131 | return "$bar $foo"; |
132 | } |
133 | |
e7be1784 |
134 | } |
135 | |
b52072dc |
136 | use Test::More; |
e7be1784 |
137 | |
138 | my $o = DeclareTest->new(attr => "value"); |
139 | |
140 | isa_ok($o, 'DeclareTest'); |
141 | |
142 | is($o->{attr}, 'value', '@_ args ok'); |
143 | |
144 | is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); |
145 | |
146 | is($o->main, 'main', 'declaration of package named method ok'); |
147 | |
7a3f5539 |
148 | is($o->multiline1(3), '33', 'multiline1 proto ok'); |
149 | is($o->multiline2(1,2), '1 2', 'multiline2 proto ok'); |
150 | is($o->multiline3(4,5), '5 4', 'multiline3 proto ok'); |
151 | |
01fadf71 |
152 | is_deeply( |
153 | $o->has_many_traits, |
154 | [['Trait1', undef], ['Trait2', q[foo => 'bar']], ['Baz', 'one, two']], |
155 | 'extracting multiple traits', |
156 | ); |
157 | |
158 | is_deeply( |
159 | $o->has_a_trait, |
160 | [['Foo1', undef]], |
161 | 'extract one trait without arguments', |
162 | ); |
163 | |
e7be1784 |
164 | $o->upgrade; |
165 | |
166 | isa_ok($o, 'DeclareTest2'); |
167 | |
168 | is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); |
169 | |
170 | is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); |
171 | |
172 | is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); |
173 | |
174 | is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); |
175 | |
b52072dc |
176 | done_testing; |