6 package MethodHandlers;
10 use B::Hooks::EndOfScope;
12 our ($Declarator, $Offset);
15 $Offset += Devel::Declare::toke_move_past_token($Offset);
19 $Offset += Devel::Declare::toke_skipspace($Offset);
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);
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);
51 my $pack = Devel::Declare::get_curstash_name;
52 Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
55 # undef -> my ($self) = shift;
56 # '' -> my ($self) = @_;
57 # '$foo' -> my ($self, $foo) = @_;
59 sub make_proto_unwrap {
61 my $inject = 'my ($self';
63 $inject .= ", $proto" if length($proto);
64 $inject .= ') = @_; ';
66 $inject .= ') = shift;';
74 my $linestr = Devel::Declare::get_linestr;
75 if (substr($linestr, $Offset, 1) eq '{') {
76 substr($linestr, $Offset+1, 0) = $inject;
77 Devel::Declare::set_linestr($linestr);
81 sub scope_injector_call {
82 return ' BEGIN { MethodHandlers::inject_scope }; ';
86 local ($Declarator, $Offset) = @_;
88 my $name = strip_name;
89 my $proto = strip_proto;
90 my $inject = make_proto_unwrap($proto);
92 $inject = scope_injector_call().$inject;
94 inject_if_block($inject);
96 $name = join('::', Devel::Declare::get_curstash_name(), $name)
97 unless ($name =~ /::/);
98 shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
100 shadow(sub (&) { shift });
106 my $linestr = Devel::Declare::get_linestr;
107 my $offset = Devel::Declare::get_linestr_offset;
108 substr($linestr, $offset, 0) = ';';
109 Devel::Declare::set_linestr($linestr);
114 my ($test_method1, $test_method2, @test_list);
122 Devel::Declare->setup_for(
124 { method => { const => \&MethodHandlers::parser } }
129 my $class = ref $self || $self;
130 return bless({ @_ }, $class);
134 return (ref $self).': Foo: '.$foo;
137 method upgrade(){ # no spaces to make case pathological
138 bless($self, 'DeclareTest2');
141 method DeclareTest2::bar () {
142 return 'DeclareTest2: bar';
145 $test_method1 = method {
146 return join(', ', $self->{attr}, $_[1]);
149 $test_method2 = method ($what) {
150 return join(', ', ref $self, $what);
153 method main () { return "main"; }
155 @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
161 my $o = DeclareTest->new(attr => "value");
163 isa_ok($o, 'DeclareTest');
165 is($o->{attr}, 'value', '@_ args ok');
167 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
169 is($o->main, 'main', 'declaration of package named method ok');
173 isa_ok($o, 'DeclareTest2');
175 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
177 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
179 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
181 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');