Commit | Line | Data |
94caac6e |
1 | package Devel::Declare; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use 5.008001; |
6 | |
7347020e |
7 | our $VERSION = '0.002002'; |
0ba8c7aa |
8 | |
9 | use constant DECLARE_NAME => 1; |
10 | use constant DECLARE_PROTO => 2; |
53e3ab32 |
11 | use constant DECLARE_NONE => 4; |
15d0d014 |
12 | use constant DECLARE_PACKAGE => 8+1; # name implicit |
0ba8c7aa |
13 | |
86c3de80 |
14 | use vars qw(%declarators %declarator_handlers @ISA); |
94caac6e |
15 | use base qw(DynaLoader); |
323ae557 |
16 | use Scalar::Util 'set_prototype'; |
b15aa864 |
17 | use B::Hooks::OP::Check; |
88cc8039 |
18 | use B::Hooks::Parser; |
94caac6e |
19 | |
20 | bootstrap Devel::Declare; |
21 | |
86c3de80 |
22 | @ISA = (); |
23 | |
88cc8039 |
24 | # temporary backcompat |
25 | { |
26 | for (qw/get_linestr get_linestr_offset set_linestr/) { |
27 | no strict 'refs'; |
28 | *{ $_ } = B::Hooks::Parser->can($_); |
29 | } |
30 | } |
31 | |
94caac6e |
32 | sub import { |
0ba8c7aa |
33 | my ($class, %args) = @_; |
94caac6e |
34 | my $target = caller; |
0ba8c7aa |
35 | if (@_ == 1) { # "use Devel::Declare;" |
36 | no strict 'refs'; |
15d0d014 |
37 | foreach my $name (qw(NAME PROTO NONE PACKAGE)) { |
53e3ab32 |
38 | *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"}; |
0ba8c7aa |
39 | } |
40 | } else { |
41 | $class->setup_for($target => \%args); |
42 | } |
94caac6e |
43 | } |
44 | |
45 | sub unimport { |
46 | my ($class) = @_; |
47 | my $target = caller; |
48 | $class->teardown_for($target); |
49 | } |
50 | |
51 | sub setup_for { |
52 | my ($class, $target, $args) = @_; |
53 | setup(); |
0ba8c7aa |
54 | foreach my $key (keys %$args) { |
55 | my $info = $args->{$key}; |
56 | my ($flags, $sub); |
57 | if (ref($info) eq 'ARRAY') { |
58 | ($flags, $sub) = @$info; |
59 | } elsif (ref($info) eq 'CODE') { |
60 | $flags = DECLARE_NAME; |
61 | $sub = $info; |
840ebcbb |
62 | } elsif (ref($info) eq 'HASH') { |
63 | $flags = 1; |
64 | $sub = $info; |
0ba8c7aa |
65 | } else { |
840ebcbb |
66 | die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref"; |
0ba8c7aa |
67 | } |
68 | $declarators{$target}{$key} = $flags; |
69 | $declarator_handlers{$target}{$key} = $sub; |
70 | } |
94caac6e |
71 | } |
72 | |
73 | sub teardown_for { |
74 | my ($class, $target) = @_; |
75 | delete $declarators{$target}; |
0ba8c7aa |
76 | delete $declarator_handlers{$target}; |
94caac6e |
77 | } |
78 | |
94caac6e |
79 | my $temp_name; |
0ba8c7aa |
80 | my $temp_save; |
94caac6e |
81 | |
82 | sub init_declare { |
0f070758 |
83 | my ($usepack, $use, $inpack, $name, $proto, $traits) = @_; |
53e3ab32 |
84 | my ($name_h, $XX_h, $extra_code) |
9026391e |
85 | = $declarator_handlers{$usepack}{$use}->( |
0f070758 |
86 | $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits |
53e3ab32 |
87 | ); |
15d0d014 |
88 | ($temp_name, $temp_save) = ([], []); |
0ba8c7aa |
89 | if ($name) { |
9026391e |
90 | $name = "${inpack}::${name}" unless $name =~ /::/; |
840ebcbb |
91 | shadow_sub($name, $name_h); |
0ba8c7aa |
92 | } |
93 | if ($XX_h) { |
840ebcbb |
94 | shadow_sub("${inpack}::X", $XX_h); |
0ba8c7aa |
95 | } |
53e3ab32 |
96 | if (defined wantarray) { |
97 | return $extra_code || '0;'; |
98 | } else { |
99 | return; |
100 | } |
94caac6e |
101 | } |
102 | |
840ebcbb |
103 | sub shadow_sub { |
104 | my ($name, $cr) = @_; |
105 | push(@$temp_name, $name); |
106 | no strict 'refs'; |
107 | my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/); |
108 | push(@$temp_save, $pack->can($pname)); |
109 | delete ${"${pack}::"}{$pname}; |
110 | no warnings 'redefine'; |
111 | no warnings 'prototype'; |
112 | *{$name} = $cr; |
113 | set_in_declare(~~@{$temp_name||[]}); |
114 | } |
115 | |
94caac6e |
116 | sub done_declare { |
117 | no strict 'refs'; |
86c3de80 |
118 | my $name = shift(@{$temp_name||[]}); |
0ba8c7aa |
119 | die "done_declare called with no temp_name stack" unless defined($name); |
86c3de80 |
120 | my $saved = shift(@$temp_save); |
15d0d014 |
121 | $name =~ s/(.*):://; |
122 | my $temp_pack = $1; |
0ba8c7aa |
123 | delete ${"${temp_pack}::"}{$name}; |
124 | if ($saved) { |
125 | no warnings 'prototype'; |
126 | *{"${temp_pack}::${name}"} = $saved; |
127 | } |
840ebcbb |
128 | set_in_declare(~~@{$temp_name||[]}); |
94caac6e |
129 | } |
130 | |
323ae557 |
131 | sub build_sub_installer { |
132 | my ($class, $pack, $name, $proto) = @_; |
133 | return eval " |
134 | package ${pack}; |
135 | my \$body; |
136 | sub ${name} (${proto}) :lvalue {\n" |
003ac394 |
137 | .' if (wantarray) { |
c5912dc7 |
138 | goto &$body; |
003ac394 |
139 | } |
140 | my $ret = $body->(@_); |
86c3de80 |
141 | return $ret; |
323ae557 |
142 | }; |
143 | sub { ($body) = @_; };'; |
144 | } |
145 | |
146 | sub setup_declarators { |
147 | my ($class, $pack, $to_setup) = @_; |
86c3de80 |
148 | die "${class}->setup_declarators(\$pack, \\\%to_setup)" |
149 | unless defined($pack) && ref($to_setup) eq 'HASH'; |
150 | my %setup_for_args; |
323ae557 |
151 | foreach my $name (keys %$to_setup) { |
152 | my $info = $to_setup->{$name}; |
153 | my $flags = $info->{flags} || DECLARE_NAME; |
154 | my $run = $info->{run}; |
155 | my $compile = $info->{compile}; |
156 | my $proto = $info->{proto} || '&'; |
157 | my $sub_proto = $proto; |
158 | # make all args optional to enable lvalue for DECLARE_NONE |
159 | $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto; |
86c3de80 |
160 | #my $installer = $class->build_sub_installer($pack, $name, $proto); |
161 | my $installer = $class->build_sub_installer($pack, $name, '@'); |
86c3de80 |
162 | $installer->(sub :lvalue { |
003ac394 |
163 | #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; } |
c5534496 |
164 | if (@_) { |
165 | if (ref $_[0] eq 'HASH') { |
166 | shift; |
003ac394 |
167 | if (wantarray) { |
168 | my @ret = $run->(undef, undef, @_); |
169 | return @ret; |
170 | } |
c5534496 |
171 | my $r = $run->(undef, undef, @_); |
172 | return $r; |
173 | } else { |
003ac394 |
174 | return @_[1..$#_]; |
c5534496 |
175 | } |
86c3de80 |
176 | } |
177 | return my $sv; |
178 | }); |
179 | $setup_for_args{$name} = [ |
180 | $flags, |
181 | sub { |
0f070758 |
182 | my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_; |
183 | my $extra_code = $compile->($name, $proto, $traits); |
003ac394 |
184 | my $main_handler = sub { shift if $shift_hashref; |
c5534496 |
185 | ("DONE", $run->($name, $proto, @_)); |
003ac394 |
186 | }; |
86c3de80 |
187 | my ($name_h, $XX); |
188 | if (defined $proto) { |
189 | $name_h = sub :lvalue { return my $sv; }; |
190 | $XX = $main_handler; |
c5534496 |
191 | } elsif (defined $name && length $name) { |
86c3de80 |
192 | $name_h = $main_handler; |
193 | } |
003ac394 |
194 | $extra_code ||= ''; |
195 | $extra_code = '}, sub {'.$extra_code; |
86c3de80 |
196 | return ($name_h, $XX, $extra_code); |
197 | } |
198 | ]; |
323ae557 |
199 | } |
86c3de80 |
200 | $class->setup_for($pack, \%setup_for_args); |
201 | } |
202 | |
203 | sub install_declarator { |
204 | my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_; |
205 | $class->setup_declarators($target_pack, { |
206 | $target_name => { |
207 | flags => $flags, |
208 | compile => $filter, |
209 | run => $handler, |
210 | } |
211 | }); |
323ae557 |
212 | } |
213 | |
04a8a223 |
214 | sub linestr_callback_rv2cv { |
215 | my ($name, $offset) = @_; |
216 | $offset += toke_move_past_token($offset); |
217 | my $pack = get_curstash_name(); |
218 | my $flags = $declarators{$pack}{$name}; |
219 | my ($found_name, $found_proto); |
04a8a223 |
220 | if ($flags & DECLARE_NAME) { |
221 | $offset += toke_skipspace($offset); |
222 | my $linestr = get_linestr(); |
223 | if (substr($linestr, $offset, 2) eq '::') { |
224 | substr($linestr, $offset, 2) = ''; |
225 | set_linestr($linestr); |
226 | } |
227 | if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { |
228 | $found_name = substr($linestr, $offset, $len); |
229 | $offset += $len; |
04a8a223 |
230 | } |
231 | } |
232 | if ($flags & DECLARE_PROTO) { |
233 | $offset += toke_skipspace($offset); |
234 | my $linestr = get_linestr(); |
235 | if (substr($linestr, $offset, 1) eq '(') { |
236 | my $length = toke_scan_str($offset); |
237 | $found_proto = get_lex_stuff(); |
238 | clear_lex_stuff(); |
239 | my $replace = |
240 | ($found_name ? ' ' : '=') |
241 | .'X'.(' ' x length($found_proto)); |
242 | $linestr = get_linestr(); |
243 | substr($linestr, $offset, $length) = $replace; |
244 | set_linestr($linestr); |
245 | $offset += $length; |
04a8a223 |
246 | } |
247 | } |
248 | my @args = ($pack, $name, $pack, $found_name, $found_proto); |
04a8a223 |
249 | $offset += toke_skipspace($offset); |
250 | my $linestr = get_linestr(); |
251 | if (substr($linestr, $offset, 1) eq '{') { |
252 | my $ret = init_declare(@args); |
253 | $offset++; |
254 | if (defined $ret && length $ret) { |
255 | substr($linestr, $offset, 0) = $ret; |
256 | set_linestr($linestr); |
257 | } |
258 | } else { |
259 | init_declare(@args); |
260 | } |
261 | #warn "linestr now ${linestr}"; |
262 | } |
263 | |
569ac469 |
264 | sub linestr_callback_const { |
04a8a223 |
265 | my ($name, $offset) = @_; |
266 | my $pack = get_curstash_name(); |
267 | my $flags = $declarators{$pack}{$name}; |
268 | if ($flags & DECLARE_NAME) { |
269 | $offset += toke_move_past_token($offset); |
270 | $offset += toke_skipspace($offset); |
271 | if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { |
272 | my $linestr = get_linestr(); |
273 | substr($linestr, $offset, 0) = '::'; |
274 | set_linestr($linestr); |
275 | } |
276 | } |
569ac469 |
277 | } |
278 | |
279 | sub linestr_callback { |
280 | my $type = shift; |
840ebcbb |
281 | my $name = $_[0]; |
282 | my $pack = get_curstash_name(); |
283 | my $handlers = $declarator_handlers{$pack}{$name}; |
284 | if (ref $handlers eq 'CODE') { |
285 | my $meth = "linestr_callback_${type}"; |
286 | __PACKAGE__->can($meth)->(@_); |
287 | } elsif (ref $handlers eq 'HASH') { |
288 | if ($handlers->{$type}) { |
289 | $handlers->{$type}->(@_); |
290 | } |
291 | } else { |
292 | die "PANIC: unknown thing in handlers for $pack $name: $handlers"; |
293 | } |
569ac469 |
294 | } |
295 | |
94caac6e |
296 | =head1 NAME |
297 | |
298 | Devel::Declare - |
299 | |
300 | =head1 SYNOPSIS |
301 | |
2ee34f20 |
302 | use Devel::Declare (); |
2ee34f20 |
303 | |
304 | { |
305 | package MethodHandlers; |
306 | |
307 | use strict; |
308 | use warnings; |
b9a35c84 |
309 | use B::Hooks::EndOfScope; |
2ee34f20 |
310 | |
311 | our ($Declarator, $Offset); |
312 | |
313 | sub skip_declarator { |
314 | $Offset += Devel::Declare::toke_move_past_token($Offset); |
315 | } |
316 | |
317 | sub skipspace { |
318 | $Offset += Devel::Declare::toke_skipspace($Offset); |
319 | } |
320 | |
321 | sub strip_name { |
322 | skipspace; |
323 | if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { |
324 | my $linestr = Devel::Declare::get_linestr(); |
325 | my $name = substr($linestr, $Offset, $len); |
326 | substr($linestr, $Offset, $len) = ''; |
327 | Devel::Declare::set_linestr($linestr); |
328 | return $name; |
329 | } |
330 | return; |
331 | } |
332 | |
333 | sub strip_proto { |
334 | skipspace; |
335 | |
336 | my $linestr = Devel::Declare::get_linestr(); |
337 | if (substr($linestr, $Offset, 1) eq '(') { |
338 | my $length = Devel::Declare::toke_scan_str($Offset); |
339 | my $proto = Devel::Declare::get_lex_stuff(); |
340 | Devel::Declare::clear_lex_stuff(); |
341 | $linestr = Devel::Declare::get_linestr(); |
342 | substr($linestr, $Offset, $length) = ''; |
343 | Devel::Declare::set_linestr($linestr); |
344 | return $proto; |
345 | } |
346 | return; |
347 | } |
348 | |
349 | sub shadow { |
350 | my $pack = Devel::Declare::get_curstash_name; |
351 | Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); |
352 | } |
353 | |
354 | # undef -> my ($self) = shift; |
355 | # '' -> my ($self) = @_; |
356 | # '$foo' -> my ($self, $foo) = @_; |
357 | |
358 | sub make_proto_unwrap { |
359 | my ($proto) = @_; |
360 | my $inject = 'my ($self'; |
361 | if (defined $proto) { |
362 | $inject .= ", $proto" if length($proto); |
363 | $inject .= ') = @_; '; |
364 | } else { |
365 | $inject .= ') = shift;'; |
366 | } |
367 | return $inject; |
368 | } |
369 | |
370 | sub inject_if_block { |
371 | my $inject = shift; |
372 | skipspace; |
373 | my $linestr = Devel::Declare::get_linestr; |
374 | if (substr($linestr, $Offset, 1) eq '{') { |
375 | substr($linestr, $Offset+1, 0) = $inject; |
376 | Devel::Declare::set_linestr($linestr); |
377 | } |
378 | } |
94caac6e |
379 | |
2ee34f20 |
380 | sub scope_injector_call { |
381 | return ' BEGIN { MethodHandlers::inject_scope }; '; |
382 | } |
383 | |
384 | sub parser { |
385 | local ($Declarator, $Offset) = @_; |
386 | skip_declarator; |
387 | my $name = strip_name; |
388 | my $proto = strip_proto; |
389 | my $inject = make_proto_unwrap($proto); |
390 | if (defined $name) { |
391 | $inject = scope_injector_call().$inject; |
392 | } |
393 | inject_if_block($inject); |
394 | if (defined $name) { |
395 | $name = join('::', Devel::Declare::get_curstash_name(), $name) |
396 | unless ($name =~ /::/); |
397 | shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); |
398 | } else { |
399 | shadow(sub (&) { shift }); |
400 | } |
401 | } |
402 | |
403 | sub inject_scope { |
b9a35c84 |
404 | on_scope_end { |
2ee34f20 |
405 | my $linestr = Devel::Declare::get_linestr; |
406 | my $offset = Devel::Declare::get_linestr_offset; |
407 | substr($linestr, $offset, 0) = ';'; |
408 | Devel::Declare::set_linestr($linestr); |
b9a35c84 |
409 | }; |
2ee34f20 |
410 | } |
411 | } |
412 | |
413 | my ($test_method1, $test_method2, @test_list); |
414 | |
415 | { |
416 | package DeclareTest; |
417 | |
418 | sub method (&); |
419 | |
420 | BEGIN { |
421 | Devel::Declare->setup_for( |
422 | __PACKAGE__, |
423 | { method => { const => \&MethodHandlers::parser } } |
424 | ); |
425 | } |
426 | |
427 | method new { |
428 | my $class = ref $self || $self; |
429 | return bless({ @_ }, $class); |
430 | } |
431 | |
432 | method foo ($foo) { |
433 | return (ref $self).': Foo: '.$foo; |
434 | } |
435 | |
436 | method upgrade(){ # no spaces to make case pathological |
437 | bless($self, 'DeclareTest2'); |
438 | } |
439 | |
440 | method DeclareTest2::bar () { |
441 | return 'DeclareTest2: bar'; |
442 | } |
443 | |
444 | $test_method1 = method { |
445 | return join(', ', $self->{attr}, $_[1]); |
446 | }; |
447 | |
448 | $test_method2 = method ($what) { |
449 | return join(', ', ref $self, $what); |
450 | }; |
451 | |
452 | method main () { return "main"; } |
453 | |
454 | @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 }); |
455 | |
456 | } |
457 | |
458 | use Test::More 'no_plan'; |
459 | |
460 | my $o = DeclareTest->new(attr => "value"); |
461 | |
462 | isa_ok($o, 'DeclareTest'); |
463 | |
464 | is($o->{attr}, 'value', '@_ args ok'); |
465 | |
466 | is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok'); |
467 | |
468 | is($o->main, 'main', 'declaration of package named method ok'); |
469 | |
470 | $o->upgrade; |
471 | |
472 | isa_ok($o, 'DeclareTest2'); |
473 | |
474 | is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok'); |
475 | |
476 | is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok'); |
477 | |
478 | is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok'); |
479 | |
480 | is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok'); |
481 | |
482 | (this is t/method-no-semi.t in this distribution) |
94caac6e |
483 | |
2ee34f20 |
484 | =head1 DESCRIPTION |
94caac6e |
485 | |
486 | =head2 setup_for |
487 | |
2ee34f20 |
488 | Devel::Declare->setup_for( |
489 | $package, |
490 | { |
491 | $name => { $op_type => $sub } |
492 | } |
493 | ); |
94caac6e |
494 | |
2ee34f20 |
495 | Currently valid op types: 'check', 'rv2cv' |
94caac6e |
496 | |
dcf29eb6 |
497 | =head1 AUTHORS |
94caac6e |
498 | |
02f5a508 |
499 | Matt S Trout - <mst@shadowcat.co.uk> |
94caac6e |
500 | |
02f5a508 |
501 | Company: http://www.shadowcat.co.uk/ |
94caac6e |
502 | Blog: http://chainsawblues.vox.com/ |
503 | |
dcf29eb6 |
504 | Florian Ragwitz E<lt>rafl@debian.orgE<gt> |
505 | |
94caac6e |
506 | =head1 LICENSE |
507 | |
508 | This library is free software under the same terms as perl itself |
509 | |
510 | =cut |
511 | |
512 | 1; |