Commit | Line | Data |
94caac6e |
1 | package Devel::Declare; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use 5.008001; |
6 | |
8aa609ae |
7 | our $VERSION = '0.006022'; |
b7f6e45e |
8 | |
9 | bootstrap Devel::Declare; |
55c6e859 |
10 | $VERSION =~ tr/_//d; |
0ba8c7aa |
11 | |
12 | use constant DECLARE_NAME => 1; |
13 | use constant DECLARE_PROTO => 2; |
53e3ab32 |
14 | use constant DECLARE_NONE => 4; |
15d0d014 |
15 | use constant DECLARE_PACKAGE => 8+1; # name implicit |
0ba8c7aa |
16 | |
3ed12788 |
17 | our (%declarators, %declarator_handlers, @ISA); |
94caac6e |
18 | use base qw(DynaLoader); |
323ae557 |
19 | use Scalar::Util 'set_prototype'; |
39801454 |
20 | use B::Hooks::OP::Check 0.19; |
94caac6e |
21 | |
86c3de80 |
22 | @ISA = (); |
23 | |
8ec78a85 |
24 | initialize(); |
25 | |
94caac6e |
26 | sub import { |
0ba8c7aa |
27 | my ($class, %args) = @_; |
94caac6e |
28 | my $target = caller; |
0ba8c7aa |
29 | if (@_ == 1) { # "use Devel::Declare;" |
30 | no strict 'refs'; |
15d0d014 |
31 | foreach my $name (qw(NAME PROTO NONE PACKAGE)) { |
53e3ab32 |
32 | *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"}; |
0ba8c7aa |
33 | } |
34 | } else { |
35 | $class->setup_for($target => \%args); |
36 | } |
94caac6e |
37 | } |
38 | |
39 | sub unimport { |
40 | my ($class) = @_; |
41 | my $target = caller; |
42 | $class->teardown_for($target); |
43 | } |
44 | |
45 | sub setup_for { |
46 | my ($class, $target, $args) = @_; |
47 | setup(); |
0ba8c7aa |
48 | foreach my $key (keys %$args) { |
49 | my $info = $args->{$key}; |
50 | my ($flags, $sub); |
51 | if (ref($info) eq 'ARRAY') { |
52 | ($flags, $sub) = @$info; |
53 | } elsif (ref($info) eq 'CODE') { |
54 | $flags = DECLARE_NAME; |
55 | $sub = $info; |
840ebcbb |
56 | } elsif (ref($info) eq 'HASH') { |
57 | $flags = 1; |
58 | $sub = $info; |
0ba8c7aa |
59 | } else { |
840ebcbb |
60 | die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref"; |
0ba8c7aa |
61 | } |
62 | $declarators{$target}{$key} = $flags; |
63 | $declarator_handlers{$target}{$key} = $sub; |
64 | } |
94caac6e |
65 | } |
66 | |
67 | sub teardown_for { |
68 | my ($class, $target) = @_; |
69 | delete $declarators{$target}; |
0ba8c7aa |
70 | delete $declarator_handlers{$target}; |
94caac6e |
71 | } |
72 | |
94caac6e |
73 | my $temp_name; |
0ba8c7aa |
74 | my $temp_save; |
94caac6e |
75 | |
76 | sub init_declare { |
0f070758 |
77 | my ($usepack, $use, $inpack, $name, $proto, $traits) = @_; |
53e3ab32 |
78 | my ($name_h, $XX_h, $extra_code) |
9026391e |
79 | = $declarator_handlers{$usepack}{$use}->( |
0f070758 |
80 | $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits |
53e3ab32 |
81 | ); |
15d0d014 |
82 | ($temp_name, $temp_save) = ([], []); |
0ba8c7aa |
83 | if ($name) { |
9026391e |
84 | $name = "${inpack}::${name}" unless $name =~ /::/; |
840ebcbb |
85 | shadow_sub($name, $name_h); |
0ba8c7aa |
86 | } |
87 | if ($XX_h) { |
840ebcbb |
88 | shadow_sub("${inpack}::X", $XX_h); |
0ba8c7aa |
89 | } |
53e3ab32 |
90 | if (defined wantarray) { |
91 | return $extra_code || '0;'; |
92 | } else { |
93 | return; |
94 | } |
94caac6e |
95 | } |
96 | |
840ebcbb |
97 | sub shadow_sub { |
98 | my ($name, $cr) = @_; |
99 | push(@$temp_name, $name); |
100 | no strict 'refs'; |
101 | my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/); |
102 | push(@$temp_save, $pack->can($pname)); |
840ebcbb |
103 | no warnings 'redefine'; |
104 | no warnings 'prototype'; |
105 | *{$name} = $cr; |
106 | set_in_declare(~~@{$temp_name||[]}); |
107 | } |
108 | |
94caac6e |
109 | sub done_declare { |
110 | no strict 'refs'; |
86c3de80 |
111 | my $name = shift(@{$temp_name||[]}); |
0ba8c7aa |
112 | die "done_declare called with no temp_name stack" unless defined($name); |
86c3de80 |
113 | my $saved = shift(@$temp_save); |
15d0d014 |
114 | $name =~ s/(.*):://; |
115 | my $temp_pack = $1; |
0ba8c7aa |
116 | delete ${"${temp_pack}::"}{$name}; |
117 | if ($saved) { |
118 | no warnings 'prototype'; |
119 | *{"${temp_pack}::${name}"} = $saved; |
120 | } |
840ebcbb |
121 | set_in_declare(~~@{$temp_name||[]}); |
94caac6e |
122 | } |
123 | |
323ae557 |
124 | sub build_sub_installer { |
125 | my ($class, $pack, $name, $proto) = @_; |
126 | return eval " |
127 | package ${pack}; |
128 | my \$body; |
129 | sub ${name} (${proto}) :lvalue {\n" |
003ac394 |
130 | .' if (wantarray) { |
c5912dc7 |
131 | goto &$body; |
003ac394 |
132 | } |
133 | my $ret = $body->(@_); |
86c3de80 |
134 | return $ret; |
323ae557 |
135 | }; |
136 | sub { ($body) = @_; };'; |
137 | } |
138 | |
139 | sub setup_declarators { |
140 | my ($class, $pack, $to_setup) = @_; |
86c3de80 |
141 | die "${class}->setup_declarators(\$pack, \\\%to_setup)" |
142 | unless defined($pack) && ref($to_setup) eq 'HASH'; |
143 | my %setup_for_args; |
323ae557 |
144 | foreach my $name (keys %$to_setup) { |
145 | my $info = $to_setup->{$name}; |
146 | my $flags = $info->{flags} || DECLARE_NAME; |
147 | my $run = $info->{run}; |
148 | my $compile = $info->{compile}; |
149 | my $proto = $info->{proto} || '&'; |
150 | my $sub_proto = $proto; |
151 | # make all args optional to enable lvalue for DECLARE_NONE |
152 | $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto; |
86c3de80 |
153 | #my $installer = $class->build_sub_installer($pack, $name, $proto); |
154 | my $installer = $class->build_sub_installer($pack, $name, '@'); |
86c3de80 |
155 | $installer->(sub :lvalue { |
003ac394 |
156 | #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; } |
c5534496 |
157 | if (@_) { |
158 | if (ref $_[0] eq 'HASH') { |
159 | shift; |
003ac394 |
160 | if (wantarray) { |
161 | my @ret = $run->(undef, undef, @_); |
162 | return @ret; |
163 | } |
c5534496 |
164 | my $r = $run->(undef, undef, @_); |
165 | return $r; |
166 | } else { |
003ac394 |
167 | return @_[1..$#_]; |
c5534496 |
168 | } |
86c3de80 |
169 | } |
170 | return my $sv; |
171 | }); |
172 | $setup_for_args{$name} = [ |
173 | $flags, |
174 | sub { |
0f070758 |
175 | my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_; |
176 | my $extra_code = $compile->($name, $proto, $traits); |
003ac394 |
177 | my $main_handler = sub { shift if $shift_hashref; |
c5534496 |
178 | ("DONE", $run->($name, $proto, @_)); |
003ac394 |
179 | }; |
86c3de80 |
180 | my ($name_h, $XX); |
181 | if (defined $proto) { |
182 | $name_h = sub :lvalue { return my $sv; }; |
183 | $XX = $main_handler; |
c5534496 |
184 | } elsif (defined $name && length $name) { |
86c3de80 |
185 | $name_h = $main_handler; |
186 | } |
003ac394 |
187 | $extra_code ||= ''; |
188 | $extra_code = '}, sub {'.$extra_code; |
86c3de80 |
189 | return ($name_h, $XX, $extra_code); |
190 | } |
191 | ]; |
323ae557 |
192 | } |
86c3de80 |
193 | $class->setup_for($pack, \%setup_for_args); |
194 | } |
195 | |
196 | sub install_declarator { |
197 | my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_; |
198 | $class->setup_declarators($target_pack, { |
199 | $target_name => { |
200 | flags => $flags, |
201 | compile => $filter, |
202 | run => $handler, |
203 | } |
204 | }); |
323ae557 |
205 | } |
206 | |
04a8a223 |
207 | sub linestr_callback_rv2cv { |
208 | my ($name, $offset) = @_; |
209 | $offset += toke_move_past_token($offset); |
210 | my $pack = get_curstash_name(); |
211 | my $flags = $declarators{$pack}{$name}; |
212 | my ($found_name, $found_proto); |
04a8a223 |
213 | if ($flags & DECLARE_NAME) { |
214 | $offset += toke_skipspace($offset); |
215 | my $linestr = get_linestr(); |
216 | if (substr($linestr, $offset, 2) eq '::') { |
217 | substr($linestr, $offset, 2) = ''; |
218 | set_linestr($linestr); |
219 | } |
220 | if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { |
221 | $found_name = substr($linestr, $offset, $len); |
222 | $offset += $len; |
04a8a223 |
223 | } |
224 | } |
225 | if ($flags & DECLARE_PROTO) { |
226 | $offset += toke_skipspace($offset); |
227 | my $linestr = get_linestr(); |
228 | if (substr($linestr, $offset, 1) eq '(') { |
229 | my $length = toke_scan_str($offset); |
230 | $found_proto = get_lex_stuff(); |
231 | clear_lex_stuff(); |
232 | my $replace = |
233 | ($found_name ? ' ' : '=') |
234 | .'X'.(' ' x length($found_proto)); |
235 | $linestr = get_linestr(); |
236 | substr($linestr, $offset, $length) = $replace; |
237 | set_linestr($linestr); |
238 | $offset += $length; |
04a8a223 |
239 | } |
240 | } |
241 | my @args = ($pack, $name, $pack, $found_name, $found_proto); |
04a8a223 |
242 | $offset += toke_skipspace($offset); |
243 | my $linestr = get_linestr(); |
244 | if (substr($linestr, $offset, 1) eq '{') { |
245 | my $ret = init_declare(@args); |
246 | $offset++; |
247 | if (defined $ret && length $ret) { |
248 | substr($linestr, $offset, 0) = $ret; |
249 | set_linestr($linestr); |
250 | } |
251 | } else { |
252 | init_declare(@args); |
253 | } |
254 | #warn "linestr now ${linestr}"; |
255 | } |
256 | |
569ac469 |
257 | sub linestr_callback_const { |
04a8a223 |
258 | my ($name, $offset) = @_; |
259 | my $pack = get_curstash_name(); |
260 | my $flags = $declarators{$pack}{$name}; |
261 | if ($flags & DECLARE_NAME) { |
262 | $offset += toke_move_past_token($offset); |
263 | $offset += toke_skipspace($offset); |
264 | if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) { |
265 | my $linestr = get_linestr(); |
266 | substr($linestr, $offset, 0) = '::'; |
267 | set_linestr($linestr); |
268 | } |
269 | } |
569ac469 |
270 | } |
271 | |
272 | sub linestr_callback { |
273 | my $type = shift; |
840ebcbb |
274 | my $name = $_[0]; |
275 | my $pack = get_curstash_name(); |
276 | my $handlers = $declarator_handlers{$pack}{$name}; |
277 | if (ref $handlers eq 'CODE') { |
278 | my $meth = "linestr_callback_${type}"; |
279 | __PACKAGE__->can($meth)->(@_); |
280 | } elsif (ref $handlers eq 'HASH') { |
281 | if ($handlers->{$type}) { |
282 | $handlers->{$type}->(@_); |
283 | } |
284 | } else { |
285 | die "PANIC: unknown thing in handlers for $pack $name: $handlers"; |
286 | } |
569ac469 |
287 | } |
288 | |
94caac6e |
289 | =head1 NAME |
290 | |
48e462a5 |
291 | Devel::Declare - (DEPRECATED) Adding keywords to perl, in perl |
94caac6e |
292 | |
293 | =head1 SYNOPSIS |
294 | |
1795217c |
295 | use Method::Signatures; |
296 | # or ... |
297 | use MooseX::Declare; |
298 | # etc. |
299 | |
300 | # Use some new and exciting syntax like: |
301 | method hello (Str :$who, Int :$age where { $_ > 0 }) { |
302 | $self->say("Hello ${who}, I am ${age} years old!"); |
303 | } |
304 | |
305 | =head1 DESCRIPTION |
306 | |
307 | L<Devel::Declare> can install subroutines called declarators which locally take |
308 | over Perl's parser, allowing the creation of new syntax. |
309 | |
310 | This document describes how to create a simple declarator. |
311 | |
1adc7e7c |
312 | =head1 WARNING |
313 | |
314 | =for comment mst wrote this warning for MooseX::Declare, and ether adapted it for here: |
315 | |
316 | B<Warning:> Devel::Declare is a giant bag of crack |
317 | originally implemented by mst with the goal of upsetting the perl core |
318 | developers so much by its very existence that they implemented proper |
319 | keyword handling in the core. |
320 | |
321 | As of perl5 version 14, this goal has been achieved, and modules such |
322 | as L<Devel::CallParser>, L<Function::Parameters>, and L<Keyword::Simple> provide |
323 | mechanisms to mangle perl syntax that don't require hallucinogenic |
324 | drugs to interpret the error messages they produce. |
325 | |
326 | If you are using something that uses Devel::Declare, please for the love |
327 | of kittens use something else: |
328 | |
329 | =over 4 |
330 | |
331 | =item * |
332 | |
02f26dca |
333 | Instead of L<TryCatch>, use L<Syntax::Keyword::Try> or L<Try::Tiny> |
1adc7e7c |
334 | |
335 | =item * |
336 | |
337 | Instead of L<Method::Signatures>, use |
338 | L<real subroutine signatures|perlsub/Signatures> (requires perl 5.22) or L<Moops> |
339 | |
340 | =back |
341 | |
02f26dca |
342 | If you are a maintainer of something that uses Devel::Declare itself, please take a look at the |
343 | more modern and robust alternatives, such as L<Keyword::Declare>, L<Keyword::Simple> or using |
344 | L<perlapi/PL_keyword_plugin> in XS directly. |
345 | |
1795217c |
346 | =head1 USAGE |
347 | |
348 | We'll demonstrate the usage of C<Devel::Declare> with a motivating example: a new |
349 | C<method> keyword, which acts like the builtin C<sub>, but automatically unpacks |
350 | C<$self> and the other arguments. |
351 | |
352 | package My::Methods; |
353 | use Devel::Declare; |
354 | |
355 | =head2 Creating a declarator with C<setup_for> |
356 | |
357 | You will typically create |
358 | |
359 | sub import { |
360 | my $class = shift; |
361 | my $caller = caller; |
362 | |
363 | Devel::Declare->setup_for( |
364 | $caller, |
365 | { method => { const => \&parser } } |
366 | ); |
367 | no strict 'refs'; |
368 | *{$caller.'::method'} = sub (&) {}; |
369 | } |
370 | |
371 | Starting from the end of this import routine, you'll see that we're creating a |
372 | subroutine called C<method> in the caller's namespace. Yes, that's just a normal |
373 | subroutine, and it does nothing at all (yet!) Note the prototype C<(&)> which means |
374 | that the caller would call it like so: |
375 | |
376 | method { |
377 | my ($self, $arg1, $arg2) = @_; |
378 | ... |
379 | } |
380 | |
381 | However we want to be able to call it like this |
382 | |
383 | method foo ($arg1, $arg2) { |
384 | ... |
385 | } |
386 | |
387 | That's why we call C<setup_for> above, to register the declarator 'method' with a custom |
388 | parser, as per the next section. It acts on an optype, usually C<'const'> as above. |
389 | (Other valid values are C<'check'> and C<'rv2cv'>). |
390 | |
391 | For a simpler way to install new methods, see also L<Devel::Declare::MethodInstaller::Simple> |
392 | |
393 | =head2 Writing a parser subroutine |
394 | |
395 | This subroutine is called at I<compilation> time, and allows you to read the custom |
396 | syntaxes that we want (in a syntax that may or may not be valid core Perl 5) and |
397 | munge it so that the result will be parsed by the C<perl> compiler. |
398 | |
399 | For this example, we're defining some globals for convenience: |
400 | |
2ee34f20 |
401 | our ($Declarator, $Offset); |
1795217c |
402 | |
403 | Then we define a parser subroutine to handle our declarator. We'll look at this in |
404 | a few chunks. |
405 | |
406 | sub parser { |
407 | local ($Declarator, $Offset) = @_; |
408 | |
409 | C<Devel::Declare> provides some very low level utility methods to parse character |
410 | strings. We'll define some useful higher level routines below for convenience, |
411 | and we can use these to parse the various elements in our new syntax. |
412 | |
413 | Notice how our parser subroutine is invoked at compile time, |
414 | when the C<perl> parser is pointed just I<before> the declarator name. |
415 | |
416 | skip_declarator; # step past 'method' |
417 | my $name = strip_name; # strip out the name 'foo', if present |
418 | my $proto = strip_proto; # strip out the prototype '($arg1, $arg2)', if present |
419 | |
420 | Now we can prepare some code to 'inject' into the new subroutine. For example we |
421 | might want the method as above to have C<my ($self, $arg1, $arg2) = @_> injected at |
422 | the beginning of it. We also do some clever stuff with scopes that we'll look |
423 | at shortly. |
424 | |
425 | my $inject = make_proto_unwrap($proto); |
426 | if (defined $name) { |
427 | $inject = scope_injector_call().$inject; |
428 | } |
429 | inject_if_block($inject); |
430 | |
431 | We've now managed to change C<method ($arg1, $arg2) { ... }> into C<method { |
432 | injected_code; ... }>. This will compile... but we've lost the name of the |
433 | method! |
434 | |
435 | In a cute (or horrifying, depending on your perspective) trick, we temporarily |
436 | change the definition of the subroutine C<method> itself, to specialise it with |
437 | the C<$name> we stripped, so that it assigns the code block to that name. |
438 | |
439 | Even though the I<next> time C<method> is compiled, it will be |
440 | redefined again, C<perl> caches these definitions in its parse |
441 | tree, so we'll always get the right one! |
442 | |
443 | Note that we also handle the case where there was no name, allowing |
444 | an anonymous method analogous to an anonymous subroutine. |
445 | |
446 | if (defined $name) { |
447 | $name = join('::', Devel::Declare::get_curstash_name(), $name) |
448 | unless ($name =~ /::/); |
449 | shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); |
450 | } else { |
451 | shadow(sub (&) { shift }); |
452 | } |
453 | } |
454 | |
455 | |
456 | =head2 Parser utilities in detail |
457 | |
458 | For simplicity, we're using global variables like C<$Offset> in these examples. |
459 | You may prefer to look at L<Devel::Declare::Context::Simple>, which |
460 | encapsulates the context much more cleanly. |
461 | |
462 | =head3 C<skip_declarator> |
463 | |
464 | This simple parser just moves across a 'token'. The common case is |
465 | to skip the declarator, i.e. to move to the end of the string |
466 | 'method' and before the prototype and code block. |
467 | |
2ee34f20 |
468 | sub skip_declarator { |
469 | $Offset += Devel::Declare::toke_move_past_token($Offset); |
470 | } |
1795217c |
471 | |
472 | =head4 C<toke_move_past_token> |
473 | |
474 | This builtin parser simply moves past a 'token' (matching C</[a-zA-Z_]\w*/>) |
475 | It takes an offset into the source document, and skips past the token. |
476 | It returns the number of characters skipped. |
477 | |
478 | =head3 C<strip_name> |
479 | |
480 | This parser skips any whitespace, then scans the next word (again matching a |
481 | 'token'). We can then analyse the current line, and manipulate it (using pure |
482 | Perl). In this case we take the name of the method out, and return it. |
483 | |
2ee34f20 |
484 | sub strip_name { |
485 | skipspace; |
486 | if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) { |
487 | my $linestr = Devel::Declare::get_linestr(); |
488 | my $name = substr($linestr, $Offset, $len); |
489 | substr($linestr, $Offset, $len) = ''; |
490 | Devel::Declare::set_linestr($linestr); |
491 | return $name; |
492 | } |
493 | return; |
494 | } |
1795217c |
495 | |
496 | =head4 C<toke_scan_word> |
497 | |
498 | This builtin parser, given an offset into the source document, |
499 | matches a 'token' as above but does not skip. It returns the |
500 | length of the token matched, if any. |
501 | |
502 | =head4 C<get_linestr> |
503 | |
504 | This builtin returns the full text of the current line of the source document. |
505 | |
506 | =head4 C<set_linestr> |
507 | |
508 | This builtin sets the full text of the current line of the source document. |
2627a85c |
509 | Beware that injecting a newline into the middle of the line is likely |
510 | to fail in surprising ways. Generally, Perl's parser can rely on the |
511 | `current line' actually being only a single line. Use other kinds of |
512 | whitespace instead, in the code that you inject. |
1795217c |
513 | |
514 | =head3 C<skipspace> |
515 | |
516 | This parser skips whitsepace. |
517 | |
518 | sub skipspace { |
519 | $Offset += Devel::Declare::toke_skipspace($Offset); |
520 | } |
521 | |
522 | =head4 C<toke_skipspace> |
523 | |
524 | This builtin parser, given an offset into the source document, |
525 | skips over any whitespace, and returns the number of characters |
526 | skipped. |
527 | |
528 | =head3 C<strip_proto> |
529 | |
530 | This is a more complex parser that checks if it's found something that |
531 | starts with C<'('> and returns everything till the matching C<')'>. |
532 | |
2ee34f20 |
533 | sub strip_proto { |
534 | skipspace; |
1795217c |
535 | |
2ee34f20 |
536 | my $linestr = Devel::Declare::get_linestr(); |
537 | if (substr($linestr, $Offset, 1) eq '(') { |
538 | my $length = Devel::Declare::toke_scan_str($Offset); |
539 | my $proto = Devel::Declare::get_lex_stuff(); |
540 | Devel::Declare::clear_lex_stuff(); |
541 | $linestr = Devel::Declare::get_linestr(); |
542 | substr($linestr, $Offset, $length) = ''; |
543 | Devel::Declare::set_linestr($linestr); |
544 | return $proto; |
545 | } |
546 | return; |
547 | } |
1795217c |
548 | |
549 | =head4 C<toke_scan_str> |
550 | |
551 | This builtin parser uses Perl's own parsing routines to match a "stringlike" |
552 | expression. Handily, this includes bracketed expressions (just think about |
553 | things like C<q(this is a quote)>). |
554 | |
555 | Also it Does The Right Thing with nested delimiters (like C<q(this (is (a) quote))>). |
556 | |
78bb475d |
557 | It returns the effective length of the expression matched. Really, what |
558 | it returns is the difference in position between where the string started, |
559 | within the buffer, and where it finished. If the string extended across |
560 | multiple lines then the contents of the buffer may have been completely |
561 | replaced by the new lines, so this position difference is not the same |
562 | thing as the actual length of the expression matched. However, because |
563 | moving backward in the buffer causes problems, the function arranges |
564 | for the effective length to always be positive, padding the start of |
565 | the buffer if necessary. |
566 | |
567 | Use C<get_lex_stuff> to get the actual matched text, the content of |
568 | the string. Because of the behaviour around multiline strings, you |
569 | can't reliably get this from the buffer. In fact, after the function |
570 | returns, you can't rely on any content of the buffer preceding the end |
571 | of the string. |
1795217c |
572 | |
8449c31f |
573 | If the string being scanned is not well formed (has no closing delimiter), |
574 | C<toke_scan_str> returns C<undef>. In this case you cannot rely on the |
575 | contents of the buffer. |
576 | |
1795217c |
577 | =head4 C<get_lex_stuff> |
578 | |
579 | This builtin returns what was matched by C<toke_scan_str>. To avoid segfaults, |
580 | you should call C<clear_lex_stuff> immediately afterwards. |
581 | |
582 | =head2 Munging the subroutine |
583 | |
584 | Let's look at what we need to do in detail. |
585 | |
586 | =head3 C<make_proto_unwrap> |
587 | |
588 | We may have defined our method in different ways, which will result |
589 | in a different value for our prototype, as parsed above. For example: |
590 | |
591 | method foo { # undefined |
592 | method foo () { # '' |
593 | method foo ($arg1) { # '$arg1' |
594 | |
595 | We deal with them as follows, and return the appropriate C<my ($self, ...) = @_;> |
596 | string. |
597 | |
2ee34f20 |
598 | sub make_proto_unwrap { |
599 | my ($proto) = @_; |
600 | my $inject = 'my ($self'; |
601 | if (defined $proto) { |
602 | $inject .= ", $proto" if length($proto); |
603 | $inject .= ') = @_; '; |
604 | } else { |
605 | $inject .= ') = shift;'; |
606 | } |
607 | return $inject; |
608 | } |
1795217c |
609 | |
610 | =head3 C<inject_if_block> |
611 | |
612 | Now we need to inject it after the opening C<'{'> of the method body. |
613 | We can do this with the building blocks we defined above like C<skipspace> |
614 | and C<get_linestr>. |
615 | |
2ee34f20 |
616 | sub inject_if_block { |
617 | my $inject = shift; |
618 | skipspace; |
619 | my $linestr = Devel::Declare::get_linestr; |
620 | if (substr($linestr, $Offset, 1) eq '{') { |
621 | substr($linestr, $Offset+1, 0) = $inject; |
622 | Devel::Declare::set_linestr($linestr); |
623 | } |
624 | } |
94caac6e |
625 | |
1795217c |
626 | =head3 C<scope_injector_call> |
627 | |
628 | We want to be able to handle both named and anonymous methods. i.e. |
629 | |
630 | method foo () { ... } |
631 | my $meth = method () { ... }; |
632 | |
633 | These will then get rewritten as |
634 | |
635 | method { ... } |
636 | my $meth = method { ... }; |
637 | |
638 | where 'method' is a subroutine that takes a code block. Spot the problem? |
639 | The first one doesn't have a semicolon at the end of it! Unlike 'sub' which |
640 | is a builtin, this is just a normal statement, so we need to terminate it. |
6c1cecd4 |
641 | Luckily, using C<B::Hooks::EndOfScope>, we can do this! |
1795217c |
642 | |
6c1cecd4 |
643 | use B::Hooks::EndOfScope; |
1795217c |
644 | |
645 | We'll add this to what gets 'injected' at the beginning of the method source. |
646 | |
647 | sub scope_injector_call { |
648 | return ' BEGIN { MethodHandlers::inject_scope }; '; |
2ee34f20 |
649 | } |
1795217c |
650 | |
5bcdf810 |
651 | So at the beginning of every method, we are passing a callback that will get invoked |
1795217c |
652 | at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'> |
653 | is compiled. |
654 | |
655 | sub inject_scope { |
6c1cecd4 |
656 | on_scope_end { |
1795217c |
657 | my $linestr = Devel::Declare::get_linestr; |
658 | my $offset = Devel::Declare::get_linestr_offset; |
659 | substr($linestr, $offset, 0) = ';'; |
660 | Devel::Declare::set_linestr($linestr); |
6c1cecd4 |
661 | }; |
2ee34f20 |
662 | } |
94caac6e |
663 | |
1795217c |
664 | =head2 Shadowing each method. |
665 | |
666 | =head3 C<shadow> |
94caac6e |
667 | |
1795217c |
668 | We override the current definition of 'method' using C<shadow>. |
94caac6e |
669 | |
1795217c |
670 | sub shadow { |
671 | my $pack = Devel::Declare::get_curstash_name; |
672 | Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]); |
2ee34f20 |
673 | } |
94caac6e |
674 | |
1795217c |
675 | For a named method we invoked like this: |
676 | |
677 | shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); |
678 | |
679 | So in the case of a C<method foo { ... }>, this call would redefine C<method> |
680 | to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>. |
681 | |
682 | The case of an anonymous method is also cute: |
683 | |
684 | shadow(sub (&) { shift }); |
685 | |
686 | This means that |
687 | |
688 | my $meth = method () { ... }; |
689 | |
690 | is rewritten with C<method> taking the codeblock, and returning it as is to become |
691 | the value of C<$meth>. |
692 | |
693 | =head4 C<get_curstash_name> |
694 | |
695 | This returns the package name I<currently being compiled>. |
696 | |
697 | =head4 C<shadow_sub> |
698 | |
699 | Handles the details of redefining the subroutine. |
700 | |
701 | =head1 SEE ALSO |
702 | |
703 | One of the best ways to learn C<Devel::Declare> is still to look at |
704 | modules that use it: |
705 | |
706 | L<http://cpants.perl.org/dist/used_by/Devel-Declare>. |
94caac6e |
707 | |
dcf29eb6 |
708 | =head1 AUTHORS |
94caac6e |
709 | |
502ba90e |
710 | Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author |
94caac6e |
711 | |
02f5a508 |
712 | Company: http://www.shadowcat.co.uk/ |
94caac6e |
713 | Blog: http://chainsawblues.vox.com/ |
714 | |
1795217c |
715 | Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer |
716 | |
0df492b9 |
717 | osfameron E<lt>osfameron@cpan.orgE<gt> - first draft of documentation |
dcf29eb6 |
718 | |
107322d1 |
719 | =head1 COPYRIGHT AND LICENSE |
720 | |
09addf7a |
721 | This library is free software under the same terms as perl itself |
722 | |
107322d1 |
723 | Copyright (c) 2007, 2008, 2009 Matt S Trout |
724 | |
725 | Copyright (c) 2008, 2009 Florian Ragwitz |
94caac6e |
726 | |
09addf7a |
727 | stolen_chunk_of_toke.c based on toke.c from the perl core, which is |
728 | |
729 | Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, |
730 | 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others |
94caac6e |
731 | |
732 | =cut |
733 | |
734 | 1; |