6 package MethodHandlers;
11 our ($Declarator, $Offset);
14 $Offset += Devel::Declare::toke_move_past_token($Offset);
18 $Offset += Devel::Declare::toke_skipspace($Offset);
23 if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
24 my $linestr = Devel::Declare::get_linestr();
25 my $name = substr($linestr, $Offset, $len);
26 substr($linestr, $Offset, $len) = '';
27 Devel::Declare::set_linestr($linestr);
36 my $linestr = Devel::Declare::get_linestr();
37 if (substr($linestr, $Offset, 1) eq '(') {
38 my $length = Devel::Declare::toke_scan_str($Offset);
39 my $proto = Devel::Declare::get_lex_stuff();
40 Devel::Declare::clear_lex_stuff();
41 $linestr = Devel::Declare::get_linestr();
42 substr($linestr, $Offset, $length) = '';
43 Devel::Declare::set_linestr($linestr);
50 my $pack = Devel::Declare::get_curstash_name;
51 Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
54 # undef -> my ($self) = shift;
55 # '' -> my ($self) = @_;
56 # '$foo' -> my ($self, $foo) = @_;
58 sub make_proto_unwrap {
60 my $inject = 'my ($self';
62 $inject .= ", $proto" if length($proto);
63 $inject .= ') = @_; ';
65 $inject .= ') = shift;';
73 my $linestr = Devel::Declare::get_linestr;
74 if (substr($linestr, $Offset, 1) eq '{') {
75 substr($linestr, $Offset+1, 0) = $inject;
76 Devel::Declare::set_linestr($linestr);
81 local ($Declarator, $Offset) = @_;
83 my $name = strip_name;
84 my $proto = strip_proto;
86 make_proto_unwrap($proto)
89 $name = join('::', Devel::Declare::get_curstash_name(), $name)
90 unless ($name =~ /::/);
91 shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
93 shadow(sub (&) { shift });
98 my ($test_method1, $test_method2, @test_list);
106 Devel::Declare->setup_for(
108 { method => { const => \&MethodHandlers::parser } }
113 my $class = ref $self || $self;
114 return bless({ @_ }, $class);
118 return (ref $self).': Foo: '.$foo;
121 method upgrade(){ # no spaces to make case pathological
122 bless($self, 'DeclareTest2');
125 method DeclareTest2::bar () {
126 return 'DeclareTest2: bar';
129 $test_method1 = method {
130 return join(', ', $self->{attr}, $_[1]);
133 $test_method2 = method ($what) {
134 return join(', ', ref $self, $what);
137 method main () { return "main"; };
139 @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
145 my $o = DeclareTest->new(attr => "value");
147 isa_ok($o, 'DeclareTest');
149 is($o->{attr}, 'value', '@_ args ok');
151 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
153 is($o->main, 'main', 'declaration of package named method ok');
157 isa_ok($o, 'DeclareTest2');
159 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
161 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
163 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
165 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');