Commit | Line | Data |
8343b16e |
1 | use strict; |
2 | use warnings; |
022eb0cc |
3 | use Devel::Declare (); |
faaf0544 |
4 | use Test::More 0.88; |
022eb0cc |
5 | |
6 | { |
7 | package FoomHandlers; |
8 | |
9 | use strict; |
10 | use warnings; |
11 | |
12 | our ($Declarator, $Offset); |
13 | |
14 | sub skip_declarator { |
15 | $Offset += Devel::Declare::toke_move_past_token($Offset); |
16 | } |
17 | |
18 | sub skipspace { |
19 | $Offset += Devel::Declare::toke_skipspace($Offset); |
20 | } |
21 | |
22 | sub strip_name { |
23 | skipspace; |
24 | if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { |
25 | my $linestr = Devel::Declare::get_linestr(); |
26 | my $name = substr($linestr, $Offset, $len); |
27 | substr($linestr, $Offset, $len) = ''; |
28 | Devel::Declare::set_linestr($linestr); |
29 | return $name; |
30 | } |
31 | return; |
32 | } |
33 | |
34 | sub strip_proto { |
35 | skipspace; |
36 | |
37 | my $linestr = Devel::Declare::get_linestr(); |
38 | if (substr($linestr, $Offset, 1) eq '(') { |
39 | my $length = Devel::Declare::toke_scan_str($Offset); |
40 | my $proto = Devel::Declare::get_lex_stuff(); |
41 | Devel::Declare::clear_lex_stuff(); |
42 | $linestr = Devel::Declare::get_linestr(); |
43 | substr($linestr, $Offset, $length) = ''; |
44 | Devel::Declare::set_linestr($linestr); |
45 | return $proto; |
46 | } |
47 | return; |
48 | } |
49 | |
50 | sub shadow { |
51 | my $pack = Devel::Declare::get_curstash_name; |
52 | Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); |
53 | } |
54 | |
55 | sub inject_str { |
56 | my $linestr = Devel::Declare::get_linestr; |
57 | substr($linestr, $Offset, 0) = $_[0]; |
58 | Devel::Declare::set_linestr($linestr); |
59 | } |
60 | |
61 | sub strip_str { |
62 | my $linestr = Devel::Declare::get_linestr; |
63 | if (substr($linestr, $Offset, length($_[0])) eq $_[0]) { |
64 | substr($linestr, $Offset, length($_[0])) = ''; |
65 | Devel::Declare::set_linestr($linestr); |
66 | return 1; |
67 | } |
68 | return 0; |
69 | } |
70 | |
71 | sub const { |
72 | local ($Declarator, $Offset) = @_; |
73 | skip_declarator; |
74 | my $name = strip_name; |
75 | my $str = "happy ".(defined $name ? "foom: ${name}" : "anonymous foom"); |
76 | if (defined(my $proto = strip_proto)) { |
77 | $str .= "; ${proto}"; |
78 | } |
79 | shadow(sub { $str }); |
80 | } |
81 | |
82 | package Foo; |
83 | |
84 | use strict; |
85 | use warnings; |
86 | |
87 | sub foom { } |
88 | |
89 | BEGIN { |
90 | Devel::Declare->setup_for( |
91 | __PACKAGE__, |
92 | { foom => { |
93 | const => \&FoomHandlers::const, |
94 | } } |
95 | ); |
96 | } |
97 | |
98 | ::is(foom, "happy anonymous foom", "foom"); |
99 | |
100 | ::is(foom KABOOM, "happy foom: KABOOM", "foom KABOOM"); |
101 | |
102 | ::is(foom (zoom), "happy anonymous foom; zoom", "foom (zoom)"); |
103 | |
104 | ::is(foom KABOOM (zoom), "happy foom: KABOOM; zoom", "foom KABOOM (zoom)"); |
105 | } |
b52072dc |
106 | |
107 | done_testing; |