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