Commit | Line | Data |
a664754d |
1 | use strict; |
04f5c3c0 |
2 | use warnings; |
b52072dc |
3 | use Test::More; |
a664754d |
4 | |
5 | my $Have_Devel_BeginLift; |
6 | BEGIN { |
7 | # setup_for_cv() introduced in 0.001001 |
8 | $Have_Devel_BeginLift = eval q{ use Devel::BeginLift 0.001001; 1 }; |
9 | } |
10 | |
e7be1784 |
11 | |
12 | { |
13 | package MethodHandlers; |
14 | |
15 | use strict; |
16 | use warnings; |
17 | use base 'Devel::Declare::MethodInstaller::Simple'; |
18 | |
19 | # undef -> my ($self) = shift; |
20 | # '' -> my ($self) = @_; |
21 | # '$foo' -> my ($self, $foo) = @_; |
22 | |
23 | sub parse_proto { |
24 | my $ctx = shift; |
25 | my ($proto) = @_; |
26 | my $inject = 'my ($self'; |
27 | if (defined $proto) { |
28 | $inject .= ", $proto" if length($proto); |
29 | $inject .= ') = @_; '; |
30 | } else { |
31 | $inject .= ') = shift;'; |
32 | } |
33 | return $inject; |
34 | } |
35 | |
a664754d |
36 | sub code_for { |
37 | my($self, $name) = @_; |
38 | |
39 | my $code = $self->SUPER::code_for($name); |
40 | |
41 | if( defined $name and $Have_Devel_BeginLift ) { |
42 | Devel::BeginLift->setup_for_cv($code); |
43 | } |
44 | |
45 | return $code; |
46 | } |
e7be1784 |
47 | } |
48 | |
49 | my ($test_method1, $test_method2, @test_list); |
50 | |
51 | { |
52 | package DeclareTest; |
53 | |
54 | BEGIN { # normally, this'd go in MethodHandlers::import |
55 | MethodHandlers->install_methodhandler( |
56 | name => 'method', |
57 | into => __PACKAGE__, |
5b27c9b2 |
58 | ); |
e7be1784 |
59 | } |
60 | |
a664754d |
61 | # Test at_BEGIN |
62 | SKIP: { |
63 | ::skip "Need Devel::BeginLift for compile time methods", 1 |
64 | unless $Have_Devel_BeginLift; |
65 | ::can_ok( "DeclareTest", qw(new foo upgrade) ); |
66 | } |
67 | |
e7be1784 |
68 | method new { |
69 | my $class = ref $self || $self; |
70 | return bless({ @_ }, $class); |
71 | } |
72 | |
73 | method foo ($foo) { |
74 | return (ref $self).': Foo: '.$foo; |
75 | } |
76 | |
77 | method upgrade(){ # no spaces to make case pathological |
78 | bless($self, 'DeclareTest2'); |
79 | } |
80 | |
81 | method DeclareTest2::bar () { |
82 | return 'DeclareTest2: bar'; |
83 | } |
84 | |
85 | $test_method1 = method { |
86 | return join(', ', $self->{attr}, $_[1]); |
87 | }; |
88 | |
89 | $test_method2 = method ($what) { |
90 | return join(', ', ref $self, $what); |
91 | }; |
92 | |
93 | method main () { return "main"; } |
94 | |
95 | @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); |
96 | |
ab449c2e |
97 | method leftie($left) : method { $self->{left} ||= $left; $self->{left} }; |
e7be1784 |
98 | } |
99 | |
e7be1784 |
100 | |
101 | my $o = DeclareTest->new(attr => "value"); |
102 | |
103 | isa_ok($o, 'DeclareTest'); |
104 | |
105 | is($o->{attr}, 'value', '@_ args ok'); |
106 | |
107 | is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); |
108 | |
109 | is($o->main, 'main', 'declaration of package named method ok'); |
110 | |
ab449c2e |
111 | $o->leftie( 'attributes work' ); |
b0a89632 |
112 | is($o->leftie, 'attributes work', 'code attributes intact'); |
113 | |
e7be1784 |
114 | $o->upgrade; |
115 | |
116 | isa_ok($o, 'DeclareTest2'); |
117 | |
118 | is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); |
119 | |
120 | is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); |
121 | |
122 | is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); |
123 | |
124 | is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); |
125 | |
b52072dc |
126 | done_testing; |