1 package Devel::Declare;
7 our $VERSION = '0.002000';
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 delete ${"${pack}::"}{$pname};
101 no warnings 'redefine';
102 no warnings 'prototype';
104 set_in_declare(~~@{$temp_name||[]});
109 my $name = shift(@{$temp_name||[]});
110 die "done_declare called with no temp_name stack" unless defined($name);
111 my $saved = shift(@$temp_save);
114 delete ${"${temp_pack}::"}{$name};
116 no warnings 'prototype';
117 *{"${temp_pack}::${name}"} = $saved;
119 set_in_declare(~~@{$temp_name||[]});
122 sub build_sub_installer {
123 my ($class, $pack, $name, $proto) = @_;
127 sub ${name} (${proto}) :lvalue {\n"
131 my $ret = $body->(@_);
134 sub { ($body) = @_; };';
137 sub setup_declarators {
138 my ($class, $pack, $to_setup) = @_;
139 die "${class}->setup_declarators(\$pack, \\\%to_setup)"
140 unless defined($pack) && ref($to_setup) eq 'HASH';
142 foreach my $name (keys %$to_setup) {
143 my $info = $to_setup->{$name};
144 my $flags = $info->{flags} || DECLARE_NAME;
145 my $run = $info->{run};
146 my $compile = $info->{compile};
147 my $proto = $info->{proto} || '&';
148 my $sub_proto = $proto;
149 # make all args optional to enable lvalue for DECLARE_NONE
150 $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
151 #my $installer = $class->build_sub_installer($pack, $name, $proto);
152 my $installer = $class->build_sub_installer($pack, $name, '@');
153 $installer->(sub :lvalue {
154 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
156 if (ref $_[0] eq 'HASH') {
159 my @ret = $run->(undef, undef, @_);
162 my $r = $run->(undef, undef, @_);
170 $setup_for_args{$name} = [
173 my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
174 my $extra_code = $compile->($name, $proto, $traits);
175 my $main_handler = sub { shift if $shift_hashref;
176 ("DONE", $run->($name, $proto, @_));
179 if (defined $proto) {
180 $name_h = sub :lvalue { return my $sv; };
182 } elsif (defined $name && length $name) {
183 $name_h = $main_handler;
186 $extra_code = '}, sub {'.$extra_code;
187 return ($name_h, $XX, $extra_code);
191 $class->setup_for($pack, \%setup_for_args);
194 sub install_declarator {
195 my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
196 $class->setup_declarators($target_pack, {
205 sub linestr_callback_rv2cv {
206 my ($name, $offset) = @_;
207 $offset += toke_move_past_token($offset);
208 my $pack = get_curstash_name();
209 my $flags = $declarators{$pack}{$name};
210 my ($found_name, $found_proto);
211 if ($flags & DECLARE_NAME) {
212 $offset += toke_skipspace($offset);
213 my $linestr = get_linestr();
214 if (substr($linestr, $offset, 2) eq '::') {
215 substr($linestr, $offset, 2) = '';
216 set_linestr($linestr);
218 if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
219 $found_name = substr($linestr, $offset, $len);
223 if ($flags & DECLARE_PROTO) {
224 $offset += toke_skipspace($offset);
225 my $linestr = get_linestr();
226 if (substr($linestr, $offset, 1) eq '(') {
227 my $length = toke_scan_str($offset);
228 $found_proto = get_lex_stuff();
231 ($found_name ? ' ' : '=')
232 .'X'.(' ' x length($found_proto));
233 $linestr = get_linestr();
234 substr($linestr, $offset, $length) = $replace;
235 set_linestr($linestr);
239 my @args = ($pack, $name, $pack, $found_name, $found_proto);
240 $offset += toke_skipspace($offset);
241 my $linestr = get_linestr();
242 if (substr($linestr, $offset, 1) eq '{') {
243 my $ret = init_declare(@args);
245 if (defined $ret && length $ret) {
246 substr($linestr, $offset, 0) = $ret;
247 set_linestr($linestr);
252 #warn "linestr now ${linestr}";
255 sub linestr_callback_const {
256 my ($name, $offset) = @_;
257 my $pack = get_curstash_name();
258 my $flags = $declarators{$pack}{$name};
259 if ($flags & DECLARE_NAME) {
260 $offset += toke_move_past_token($offset);
261 $offset += toke_skipspace($offset);
262 if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
263 my $linestr = get_linestr();
264 substr($linestr, $offset, 0) = '::';
265 set_linestr($linestr);
270 sub linestr_callback {
273 my $pack = get_curstash_name();
274 my $handlers = $declarator_handlers{$pack}{$name};
275 if (ref $handlers eq 'CODE') {
276 my $meth = "linestr_callback_${type}";
277 __PACKAGE__->can($meth)->(@_);
278 } elsif (ref $handlers eq 'HASH') {
279 if ($handlers->{$type}) {
280 $handlers->{$type}->(@_);
283 die "PANIC: unknown thing in handlers for $pack $name: $handlers";
293 use Devel::Declare ();
297 package MethodHandlers;
302 our ($Declarator, $Offset);
304 sub skip_declarator {
305 $Offset += Devel::Declare::toke_move_past_token($Offset);
309 $Offset += Devel::Declare::toke_skipspace($Offset);
314 if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
315 my $linestr = Devel::Declare::get_linestr();
316 my $name = substr($linestr, $Offset, $len);
317 substr($linestr, $Offset, $len) = '';
318 Devel::Declare::set_linestr($linestr);
327 my $linestr = Devel::Declare::get_linestr();
328 if (substr($linestr, $Offset, 1) eq '(') {
329 my $length = Devel::Declare::toke_scan_str($Offset);
330 my $proto = Devel::Declare::get_lex_stuff();
331 Devel::Declare::clear_lex_stuff();
332 $linestr = Devel::Declare::get_linestr();
333 substr($linestr, $Offset, $length) = '';
334 Devel::Declare::set_linestr($linestr);
341 my $pack = Devel::Declare::get_curstash_name;
342 Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
345 # undef -> my ($self) = shift;
346 # '' -> my ($self) = @_;
347 # '$foo' -> my ($self, $foo) = @_;
349 sub make_proto_unwrap {
351 my $inject = 'my ($self';
352 if (defined $proto) {
353 $inject .= ", $proto" if length($proto);
354 $inject .= ') = @_; ';
356 $inject .= ') = shift;';
361 sub inject_if_block {
364 my $linestr = Devel::Declare::get_linestr;
365 if (substr($linestr, $Offset, 1) eq '{') {
366 substr($linestr, $Offset+1, 0) = $inject;
367 Devel::Declare::set_linestr($linestr);
371 sub scope_injector_call {
372 return ' BEGIN { MethodHandlers::inject_scope }; ';
376 local ($Declarator, $Offset) = @_;
378 my $name = strip_name;
379 my $proto = strip_proto;
380 my $inject = make_proto_unwrap($proto);
382 $inject = scope_injector_call().$inject;
384 inject_if_block($inject);
386 $name = join('::', Devel::Declare::get_curstash_name(), $name)
387 unless ($name =~ /::/);
388 shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
390 shadow(sub (&) { shift });
396 $^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
397 my $linestr = Devel::Declare::get_linestr;
398 my $offset = Devel::Declare::get_linestr_offset;
399 substr($linestr, $offset, 0) = ';';
400 Devel::Declare::set_linestr($linestr);
405 my ($test_method1, $test_method2, @test_list);
413 Devel::Declare->setup_for(
415 { method => { const => \&MethodHandlers::parser } }
420 my $class = ref $self || $self;
421 return bless({ @_ }, $class);
425 return (ref $self).': Foo: '.$foo;
428 method upgrade(){ # no spaces to make case pathological
429 bless($self, 'DeclareTest2');
432 method DeclareTest2::bar () {
433 return 'DeclareTest2: bar';
436 $test_method1 = method {
437 return join(', ', $self->{attr}, $_[1]);
440 $test_method2 = method ($what) {
441 return join(', ', ref $self, $what);
444 method main () { return "main"; }
446 @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
450 use Test::More 'no_plan';
452 my $o = DeclareTest->new(attr => "value");
454 isa_ok($o, 'DeclareTest');
456 is($o->{attr}, 'value', '@_ args ok');
458 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
460 is($o->main, 'main', 'declaration of package named method ok');
464 isa_ok($o, 'DeclareTest2');
466 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
468 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
470 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
472 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
474 (this is t/method-no-semi.t in this distribution)
480 Devel::Declare->setup_for(
483 $name => { $op_type => $sub }
487 Currently valid op types: 'check', 'rv2cv'
491 Matt S Trout - <mst@shadowcat.co.uk>
493 Company: http://www.shadowcat.co.uk/
494 Blog: http://chainsawblues.vox.com/
498 This library is free software under the same terms as perl itself