using :lvalue subs breaks the debugger, so I added a inc_offset method to Context...
[p5sagit/Devel-Declare.git] / lib / Devel / Declare / MethodInstaller / Simple.pm
CommitLineData
e7be1784 1package Devel::Declare::MethodInstaller::Simple;
2
3use base 'Devel::Declare::Context::Simple';
4
5use Devel::Declare ();
6use Sub::Name;
7use strict;
8use warnings;
9
10sub 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 25sub 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
e7be1784 70sub parser {
5b27c9b2 71 my $self = shift;
72 $self->init(@_);
73
74 $self->skip_declarator;
75 my $name = $self->strip_name;
76 my $proto = $self->strip_proto;
b0a89632 77 my $attrs = $self->strip_attrs;
5b27c9b2 78 my @decl = $self->parse_proto($proto);
79 my $inject = $self->inject_parsed_proto(@decl);
80 if (defined $name) {
81 $inject = $self->scope_injector_call() . $inject;
82 }
b0a89632 83 $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : '');
5b27c9b2 84 if (defined $name) {
85 my $pkg = $self->get_curstash_name;
86 $name = join( '::', $pkg, $name )
87 unless( $name =~ /::/ );
88 $self->shadow( sub (&) {
89 my $code = shift;
90 # So caller() gets the subroutine name
91 no strict 'refs';
92 *{$name} = subname $name => $code;
93 });
94 } else {
95 $self->shadow(sub (&) { shift });
96 }
e7be1784 97}
5b27c9b2 98
e7be1784 99sub parse_proto { }
5b27c9b2 100
e7be1784 101sub inject_parsed_proto {
5b27c9b2 102 return $_[1];
e7be1784 103}
104
e7be1784 1051;
106