4 package MethodHandlers;
8 use Devel::Declare::Context::Simple;
10 # undef -> my ($self) = shift;
11 # '' -> my ($self) = @_;
12 # '$foo' -> my ($self, $foo) = @_;
14 sub make_proto_unwrap {
16 my $inject = 'my ($self';
18 $inject .= ", $proto" if length($proto);
19 $inject .= ') = @_; ';
21 $inject .= ') = shift;';
27 my $ctx = Devel::Declare::Context::Simple->new->init(@_);
29 $ctx->skip_declarator;
30 my $name = $ctx->strip_name;
31 my $proto = $ctx->strip_proto;
32 my $inject = make_proto_unwrap($proto);
34 $inject = $ctx->scope_injector_call().$inject;
36 $ctx->inject_if_block($inject);
38 $name = join('::', Devel::Declare::get_curstash_name(), $name)
39 unless ($name =~ /::/);
40 $ctx->shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
42 $ctx->shadow(sub (&) { shift });
48 my ($test_method1, $test_method2, @test_list);
56 Devel::Declare->setup_for(
58 { method => { const => \&MethodHandlers::parser } }
63 my $class = ref $self || $self;
64 return bless({ @_ }, $class);
68 return (ref $self).': Foo: '.$foo;
71 method upgrade(){ # no spaces to make case pathological
72 bless($self, 'DeclareTest2');
75 method DeclareTest2::bar () {
76 return 'DeclareTest2: bar';
79 $test_method1 = method {
80 return join(', ', $self->{attr}, $_[1]);
83 $test_method2 = method ($what) {
84 return join(', ', ref $self, $what);
87 method main () { return "main"; }
89 @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
93 use Test::More 'no_plan';
95 my $o = DeclareTest->new(attr => "value");
97 isa_ok($o, 'DeclareTest');
99 is($o->{attr}, 'value', '@_ args ok');
101 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
103 is($o->main, 'main', 'declaration of package named method ok');
107 isa_ok($o, 'DeclareTest2');
109 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
111 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
113 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
115 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
118 /home/rhesa/perl/t/method-no-semi....
119 ok 1 - The object isa DeclareTest
121 ok 3 - method with argument ok
122 ok 4 - declaration of package named method ok
123 ok 5 - The object isa DeclareTest2
124 ok 6 - absolute method declaration ok
125 ok 7 - anon method with @_ ok
126 ok 8 - anon method with proto ok
130 All tests successful.
131 Files=1, Tests=9, 0 wallclock secs ( 0.04 usr 0.00 sys + 0.05 cusr 0.00 csys = 0.09 CPU)