Commit | Line | Data |
e7be1784 |
1 | package Devel::Declare::MethodInstaller::Simple; |
2 | |
3 | use base 'Devel::Declare::Context::Simple'; |
4 | |
5 | use Devel::Declare (); |
6 | use Sub::Name; |
7 | use strict; |
8 | use warnings; |
9 | |
10 | sub install_methodhandler { |
5b27c9b2 |
11 | my $class = shift; |
12 | my %args = @_; |
13 | { |
14 | no strict 'refs'; |
15 | *{$args{into}.'::'.$args{name}} = sub (&) {}; |
16 | } |
17 | |
18 | my $ctx = $class->new(%args); |
19 | Devel::Declare->setup_for( |
20 | $args{into}, |
21 | { $args{name} => { const => sub { $ctx->parser(@_) } } } |
22 | ); |
e7be1784 |
23 | } |
24 | |
b0a89632 |
25 | sub strip_attrs { |
26 | my $self = shift; |
27 | $self->skipspace; |
28 | |
b0a89632 |
29 | my $linestr = Devel::Declare::get_linestr; |
30 | my $attrs = ''; |
31 | |
ab449c2e |
32 | if (substr($linestr, $self->offset, 1) eq ':') { |
33 | while (substr($linestr, $self->offset, 1) ne '{') { |
34 | if (substr($linestr, $self->offset, 1) eq ':') { |
35 | substr($linestr, $self->offset, 1) = ''; |
b0a89632 |
36 | Devel::Declare::set_linestr($linestr); |
37 | |
38 | $attrs .= ':'; |
39 | } |
40 | |
41 | $self->skipspace; |
b0a89632 |
42 | $linestr = Devel::Declare::get_linestr(); |
43 | |
ab449c2e |
44 | if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) { |
45 | my $name = substr($linestr, $self->offset, $len); |
46 | substr($linestr, $self->offset, $len) = ''; |
b0a89632 |
47 | Devel::Declare::set_linestr($linestr); |
48 | |
49 | $attrs .= " ${name}"; |
50 | |
ab449c2e |
51 | if (substr($linestr, $self->offset, 1) eq '(') { |
52 | my $length = Devel::Declare::toke_scan_str($self->offset); |
b0a89632 |
53 | my $arg = Devel::Declare::get_lex_stuff(); |
54 | Devel::Declare::clear_lex_stuff(); |
55 | $linestr = Devel::Declare::get_linestr(); |
ab449c2e |
56 | substr($linestr, $self->offset, $length) = ''; |
b0a89632 |
57 | Devel::Declare::set_linestr($linestr); |
58 | |
59 | $attrs .= "(${arg})"; |
60 | } |
61 | } |
62 | } |
63 | |
64 | $linestr = Devel::Declare::get_linestr(); |
65 | } |
66 | |
67 | return $attrs; |
68 | } |
69 | |
a664754d |
70 | sub code_for { |
71 | my ($self, $name) = @_; |
72 | |
73 | if (defined $name) { |
74 | my $pkg = $self->get_curstash_name; |
75 | $name = join( '::', $pkg, $name ) |
76 | unless( $name =~ /::/ ); |
77 | return sub (&) { |
78 | my $code = shift; |
79 | # So caller() gets the subroutine name |
80 | no strict 'refs'; |
81 | *{$name} = subname $name => $code; |
82 | return; |
83 | }; |
84 | } else { |
85 | return sub (&) { shift }; |
86 | } |
87 | } |
88 | |
89 | sub install { |
90 | my ($self, $name ) = @_; |
91 | |
92 | $self->shadow( $self->code_for($name) ); |
93 | } |
94 | |
e7be1784 |
95 | sub parser { |
5b27c9b2 |
96 | my $self = shift; |
97 | $self->init(@_); |
98 | |
99 | $self->skip_declarator; |
100 | my $name = $self->strip_name; |
101 | my $proto = $self->strip_proto; |
b0a89632 |
102 | my $attrs = $self->strip_attrs; |
5b27c9b2 |
103 | my @decl = $self->parse_proto($proto); |
104 | my $inject = $self->inject_parsed_proto(@decl); |
105 | if (defined $name) { |
106 | $inject = $self->scope_injector_call() . $inject; |
107 | } |
b0a89632 |
108 | $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : ''); |
a664754d |
109 | |
110 | $self->install( $name ); |
111 | |
112 | return; |
e7be1784 |
113 | } |
5b27c9b2 |
114 | |
e7be1784 |
115 | sub parse_proto { } |
5b27c9b2 |
116 | |
e7be1784 |
117 | sub inject_parsed_proto { |
5b27c9b2 |
118 | return $_[1]; |
e7be1784 |
119 | } |
120 | |
e7be1784 |
121 | 1; |
122 | |