1 package Devel::Declare;
7 our $VERSION = '0.003002';
9 use constant DECLARE_NAME => 1;
10 use constant DECLARE_PROTO => 2;
11 use constant DECLARE_NONE => 4;
12 use constant DECLARE_PACKAGE => 8+1; # name implicit
14 use vars qw(%declarators %declarator_handlers @ISA);
15 use base qw(DynaLoader);
16 use Scalar::Util 'set_prototype';
17 use B::Hooks::OP::Check;
19 bootstrap Devel::Declare;
24 my ($class, %args) = @_;
26 if (@_ == 1) { # "use Devel::Declare;"
28 foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
29 *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
32 $class->setup_for($target => \%args);
39 $class->teardown_for($target);
43 my ($class, $target, $args) = @_;
45 foreach my $key (keys %$args) {
46 my $info = $args->{$key};
48 if (ref($info) eq 'ARRAY') {
49 ($flags, $sub) = @$info;
50 } elsif (ref($info) eq 'CODE') {
51 $flags = DECLARE_NAME;
53 } elsif (ref($info) eq 'HASH') {
57 die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
59 $declarators{$target}{$key} = $flags;
60 $declarator_handlers{$target}{$key} = $sub;
65 my ($class, $target) = @_;
66 delete $declarators{$target};
67 delete $declarator_handlers{$target};
74 my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
75 my ($name_h, $XX_h, $extra_code)
76 = $declarator_handlers{$usepack}{$use}->(
77 $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
79 ($temp_name, $temp_save) = ([], []);
81 $name = "${inpack}::${name}" unless $name =~ /::/;
82 shadow_sub($name, $name_h);
85 shadow_sub("${inpack}::X", $XX_h);
87 if (defined wantarray) {
88 return $extra_code || '0;';
96 push(@$temp_name, $name);
98 my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
99 push(@$temp_save, $pack->can($pname));
100 no warnings 'redefine';
101 no warnings 'prototype';
103 set_in_declare(~~@{$temp_name||[]});
108 my $name = shift(@{$temp_name||[]});
109 die "done_declare called with no temp_name stack" unless defined($name);
110 my $saved = shift(@$temp_save);
113 delete ${"${temp_pack}::"}{$name};
115 no warnings 'prototype';
116 *{"${temp_pack}::${name}"} = $saved;
118 set_in_declare(~~@{$temp_name||[]});
121 sub build_sub_installer {
122 my ($class, $pack, $name, $proto) = @_;
126 sub ${name} (${proto}) :lvalue {\n"
130 my $ret = $body->(@_);
133 sub { ($body) = @_; };';
136 sub setup_declarators {
137 my ($class, $pack, $to_setup) = @_;
138 die "${class}->setup_declarators(\$pack, \\\%to_setup)"
139 unless defined($pack) && ref($to_setup) eq 'HASH';
141 foreach my $name (keys %$to_setup) {
142 my $info = $to_setup->{$name};
143 my $flags = $info->{flags} || DECLARE_NAME;
144 my $run = $info->{run};
145 my $compile = $info->{compile};
146 my $proto = $info->{proto} || '&';
147 my $sub_proto = $proto;
148 # make all args optional to enable lvalue for DECLARE_NONE
149 $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
150 #my $installer = $class->build_sub_installer($pack, $name, $proto);
151 my $installer = $class->build_sub_installer($pack, $name, '@');
152 $installer->(sub :lvalue {
153 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
155 if (ref $_[0] eq 'HASH') {
158 my @ret = $run->(undef, undef, @_);
161 my $r = $run->(undef, undef, @_);
169 $setup_for_args{$name} = [
172 my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
173 my $extra_code = $compile->($name, $proto, $traits);
174 my $main_handler = sub { shift if $shift_hashref;
175 ("DONE", $run->($name, $proto, @_));
178 if (defined $proto) {
179 $name_h = sub :lvalue { return my $sv; };
181 } elsif (defined $name && length $name) {
182 $name_h = $main_handler;
185 $extra_code = '}, sub {'.$extra_code;
186 return ($name_h, $XX, $extra_code);
190 $class->setup_for($pack, \%setup_for_args);
193 sub install_declarator {
194 my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
195 $class->setup_declarators($target_pack, {
204 sub linestr_callback_rv2cv {
205 my ($name, $offset) = @_;
206 $offset += toke_move_past_token($offset);
207 my $pack = get_curstash_name();
208 my $flags = $declarators{$pack}{$name};
209 my ($found_name, $found_proto);
210 if ($flags & DECLARE_NAME) {
211 $offset += toke_skipspace($offset);
212 my $linestr = get_linestr();
213 if (substr($linestr, $offset, 2) eq '::') {
214 substr($linestr, $offset, 2) = '';
215 set_linestr($linestr);
217 if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
218 $found_name = substr($linestr, $offset, $len);
222 if ($flags & DECLARE_PROTO) {
223 $offset += toke_skipspace($offset);
224 my $linestr = get_linestr();
225 if (substr($linestr, $offset, 1) eq '(') {
226 my $length = toke_scan_str($offset);
227 $found_proto = get_lex_stuff();
230 ($found_name ? ' ' : '=')
231 .'X'.(' ' x length($found_proto));
232 $linestr = get_linestr();
233 substr($linestr, $offset, $length) = $replace;
234 set_linestr($linestr);
238 my @args = ($pack, $name, $pack, $found_name, $found_proto);
239 $offset += toke_skipspace($offset);
240 my $linestr = get_linestr();
241 if (substr($linestr, $offset, 1) eq '{') {
242 my $ret = init_declare(@args);
244 if (defined $ret && length $ret) {
245 substr($linestr, $offset, 0) = $ret;
246 set_linestr($linestr);
251 #warn "linestr now ${linestr}";
254 sub linestr_callback_const {
255 my ($name, $offset) = @_;
256 my $pack = get_curstash_name();
257 my $flags = $declarators{$pack}{$name};
258 if ($flags & DECLARE_NAME) {
259 $offset += toke_move_past_token($offset);
260 $offset += toke_skipspace($offset);
261 if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
262 my $linestr = get_linestr();
263 substr($linestr, $offset, 0) = '::';
264 set_linestr($linestr);
269 sub linestr_callback {
272 my $pack = get_curstash_name();
273 my $handlers = $declarator_handlers{$pack}{$name};
274 if (ref $handlers eq 'CODE') {
275 my $meth = "linestr_callback_${type}";
276 __PACKAGE__->can($meth)->(@_);
277 } elsif (ref $handlers eq 'HASH') {
278 if ($handlers->{$type}) {
279 $handlers->{$type}->(@_);
282 die "PANIC: unknown thing in handlers for $pack $name: $handlers";
288 Devel::Declare - Adding keywords to perl, in perl
292 use Devel::Declare ();
295 package MethodHandlers;
299 use B::Hooks::EndOfScope;
301 our ($Declarator, $Offset);
303 sub skip_declarator {
304 $Offset += Devel::Declare::toke_move_past_token($Offset);
308 $Offset += Devel::Declare::toke_skipspace($Offset);
313 if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
314 my $linestr = Devel::Declare::get_linestr();
315 my $name = substr($linestr, $Offset, $len);
316 substr($linestr, $Offset, $len) = '';
317 Devel::Declare::set_linestr($linestr);
326 my $linestr = Devel::Declare::get_linestr();
327 if (substr($linestr, $Offset, 1) eq '(') {
328 my $length = Devel::Declare::toke_scan_str($Offset);
329 my $proto = Devel::Declare::get_lex_stuff();
330 Devel::Declare::clear_lex_stuff();
331 $linestr = Devel::Declare::get_linestr();
332 substr($linestr, $Offset, $length) = '';
333 Devel::Declare::set_linestr($linestr);
340 my $pack = Devel::Declare::get_curstash_name;
341 Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
344 # undef -> my ($self) = shift;
345 # '' -> my ($self) = @_;
346 # '$foo' -> my ($self, $foo) = @_;
348 sub make_proto_unwrap {
350 my $inject = 'my ($self';
351 if (defined $proto) {
352 $inject .= ", $proto" if length($proto);
353 $inject .= ') = @_; ';
355 $inject .= ') = shift;';
360 sub inject_if_block {
363 my $linestr = Devel::Declare::get_linestr;
364 if (substr($linestr, $Offset, 1) eq '{') {
365 substr($linestr, $Offset+1, 0) = $inject;
366 Devel::Declare::set_linestr($linestr);
370 sub scope_injector_call {
371 return ' BEGIN { MethodHandlers::inject_scope }; ';
375 local ($Declarator, $Offset) = @_;
377 my $name = strip_name;
378 my $proto = strip_proto;
379 my $inject = make_proto_unwrap($proto);
381 $inject = scope_injector_call().$inject;
383 inject_if_block($inject);
385 $name = join('::', Devel::Declare::get_curstash_name(), $name)
386 unless ($name =~ /::/);
387 shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
389 shadow(sub (&) { shift });
395 my $linestr = Devel::Declare::get_linestr;
396 my $offset = Devel::Declare::get_linestr_offset;
397 substr($linestr, $offset, 0) = ';';
398 Devel::Declare::set_linestr($linestr);
403 my ($test_method1, $test_method2, @test_list);
411 Devel::Declare->setup_for(
413 { method => { const => \&MethodHandlers::parser } }
418 my $class = ref $self || $self;
419 return bless({ @_ }, $class);
423 return (ref $self).': Foo: '.$foo;
426 method upgrade(){ # no spaces to make case pathological
427 bless($self, 'DeclareTest2');
430 method DeclareTest2::bar () {
431 return 'DeclareTest2: bar';
434 $test_method1 = method {
435 return join(', ', $self->{attr}, $_[1]);
438 $test_method2 = method ($what) {
439 return join(', ', ref $self, $what);
442 method main () { return "main"; }
444 @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
448 use Test::More 'no_plan';
450 my $o = DeclareTest->new(attr => "value");
452 isa_ok($o, 'DeclareTest');
454 is($o->{attr}, 'value', '@_ args ok');
456 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
458 is($o->main, 'main', 'declaration of package named method ok');
462 isa_ok($o, 'DeclareTest2');
464 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
466 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
468 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
470 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
472 (this is t/method-no-semi.t in this distribution)
478 Devel::Declare->setup_for(
481 $name => { $op_type => $sub }
485 Currently valid op types: 'check', 'rv2cv'
489 Matt S Trout - <mst@shadowcat.co.uk>
491 Company: http://www.shadowcat.co.uk/
492 Blog: http://chainsawblues.vox.com/
494 Florian Ragwitz E<lt>rafl@debian.orgE<gt>
498 This library is free software under the same terms as perl itself