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; |
33 | my $inject = make_proto_unwrap($proto); |
34 | if (defined $name) { |
35 | $inject = $ctx->scope_injector_call().$inject; |
36 | } |
37 | $ctx->inject_if_block($inject); |
38 | if (defined $name) { |
39 | $name = join('::', Devel::Declare::get_curstash_name(), $name) |
40 | unless ($name =~ /::/); |
41 | $ctx->shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); |
42 | } else { |
43 | $ctx->shadow(sub (&) { shift }); |
44 | } |
45 | } |
46 | |
47 | } |
48 | |
49 | my ($test_method1, $test_method2, @test_list); |
50 | |
51 | { |
52 | package DeclareTest; |
53 | |
54 | sub method (&); |
55 | |
56 | BEGIN { |
57 | Devel::Declare->setup_for( |
58 | __PACKAGE__, |
59 | { method => { const => \&MethodHandlers::parser } } |
60 | ); |
61 | } |
62 | |
63 | method new { |
64 | my $class = ref $self || $self; |
65 | return bless({ @_ }, $class); |
66 | } |
67 | |
68 | method foo ($foo) { |
69 | return (ref $self).': Foo: '.$foo; |
70 | } |
71 | |
72 | method upgrade(){ # no spaces to make case pathological |
73 | bless($self, 'DeclareTest2'); |
74 | } |
75 | |
76 | method DeclareTest2::bar () { |
77 | return 'DeclareTest2: bar'; |
78 | } |
79 | |
80 | $test_method1 = method { |
81 | return join(', ', $self->{attr}, $_[1]); |
82 | }; |
83 | |
84 | $test_method2 = method ($what) { |
85 | return join(', ', ref $self, $what); |
86 | }; |
87 | |
88 | method main () { return "main"; } |
89 | |
90 | @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); |
91 | |
7a3f5539 |
92 | method multiline1( |
93 | $foo |
94 | ) |
95 | { |
96 | return "$foo$foo"; |
97 | } |
98 | |
99 | method multiline2( |
100 | $foo, $bar |
101 | ) { return "$foo $bar"; } |
102 | |
103 | method |
104 | multiline3 ($foo, |
105 | $bar) { |
106 | return "$bar $foo"; |
107 | } |
108 | |
e7be1784 |
109 | } |
110 | |
111 | use Test::More 'no_plan'; |
112 | |
113 | my $o = DeclareTest->new(attr => "value"); |
114 | |
115 | isa_ok($o, 'DeclareTest'); |
116 | |
117 | is($o->{attr}, 'value', '@_ args ok'); |
118 | |
119 | is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); |
120 | |
121 | is($o->main, 'main', 'declaration of package named method ok'); |
122 | |
7a3f5539 |
123 | is($o->multiline1(3), '33', 'multiline1 proto ok'); |
124 | is($o->multiline2(1,2), '1 2', 'multiline2 proto ok'); |
125 | is($o->multiline3(4,5), '5 4', 'multiline3 proto ok'); |
126 | |
e7be1784 |
127 | $o->upgrade; |
128 | |
129 | isa_ok($o, 'DeclareTest2'); |
130 | |
131 | is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); |
132 | |
133 | is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); |
134 | |
135 | is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); |
136 | |
137 | is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); |
138 | |