lib/Devel/Declare.pm

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