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