lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.003002';
   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 use B::Hooks::OP::Check;
  18
  19 bootstrap Devel::Declare;
  20
  21 @ISA = ();
  22
  23 sub import {
  24   my ($class, %args) = @_;
  25   my $target = caller;
  26   if (@_ == 1) { # "use Devel::Declare;"
  27     no strict 'refs';
  28     foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
  29       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  30     }
  31   } else {
  32     $class->setup_for($target => \%args);
  33   }
  34 }
  35
  36 sub unimport {
  37   my ($class) = @_;
  38   my $target = caller;
  39   $class->teardown_for($target);
  40 }
  41
  42 sub setup_for {
  43   my ($class, $target, $args) = @_;
  44   setup();
  45   foreach my $key (keys %$args) {
  46     my $info = $args->{$key};
  47     my ($flags, $sub);
  48     if (ref($info) eq 'ARRAY') {
  49       ($flags, $sub) = @$info;
  50     } elsif (ref($info) eq 'CODE') {
  51       $flags = DECLARE_NAME;
  52       $sub = $info;
  53     } elsif (ref($info) eq 'HASH') {
  54       $flags = 1;
  55       $sub = $info;
  56     } else {
  57       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
  58     }
  59     $declarators{$target}{$key} = $flags;
  60     $declarator_handlers{$target}{$key} = $sub;
  61   }
  62 }
  63
  64 sub teardown_for {
  65   my ($class, $target) = @_;
  66   delete $declarators{$target};
  67   delete $declarator_handlers{$target};
  68 }
  69
  70 my $temp_name;
  71 my $temp_save;
  72
  73 sub init_declare {
  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
  78          );
  79   ($temp_name, $temp_save) = ([], []);
  80   if ($name) {
  81     $name = "${inpack}::${name}" unless $name =~ /::/;
  82     shadow_sub($name, $name_h);
  83   }
  84   if ($XX_h) {
  85     shadow_sub("${inpack}::X", $XX_h);
  86   }
  87   if (defined wantarray) {
  88     return $extra_code || '0;';
  89   } else {
  90     return;
  91   }
  92 }
  93
  94 sub shadow_sub {
  95   my ($name, $cr) = @_;
  96   push(@$temp_name, $name);
  97   no strict 'refs';
  98   my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
  99   push(@$temp_save, $pack->can($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 - Adding keywords to perl, in perl
 289
 290 =head1 SYNOPSIS
 291
 292   use Devel::Declare ();
 293
 294   {
 295     package MethodHandlers;
 296
 297     use strict;
 298     use warnings;
 299     use B::Hooks::EndOfScope;
 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       on_scope_end {
 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);
 399       };
 400     }
 401   }
 402
 403   my ($test_method1, $test_method2, @test_list);
 404
 405   {
 406     package DeclareTest;
 407
 408     sub method (&);
 409
 410     BEGIN {
 411       Devel::Declare->setup_for(
 412         __PACKAGE__,
 413         { method => { const => \&MethodHandlers::parser } }
 414       );
 415     }
 416
 417     method new {
 418       my $class = ref $self || $self;
 419       return bless({ @_ }, $class);
 420     }
 421
 422     method foo ($foo) {
 423       return (ref $self).': Foo: '.$foo;
 424     }
 425
 426     method upgrade(){ # no spaces to make case pathological
 427       bless($self, 'DeclareTest2');
 428     }
 429
 430     method DeclareTest2::bar () {
 431       return 'DeclareTest2: bar';
 432     }
 433
 434     $test_method1 = method {
 435       return join(', ', $self->{attr}, $_[1]);
 436     };
 437
 438     $test_method2 = method ($what) {
 439       return join(', ', ref $self, $what);
 440     };
 441
 442     method main () { return "main"; }
 443
 444     @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 445
 446   }
 447
 448   use Test::More 'no_plan';
 449
 450   my $o = DeclareTest->new(attr => "value");
 451
 452   isa_ok($o, 'DeclareTest');
 453
 454   is($o->{attr}, 'value', '@_ args ok');
 455
 456   is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 457
 458   is($o->main, 'main', 'declaration of package named method ok');
 459
 460   $o->upgrade;
 461
 462   isa_ok($o, 'DeclareTest2');
 463
 464   is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 465
 466   is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 467
 468   is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 469
 470   is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
 471
 472 (this is t/method-no-semi.t in this distribution)
 473
 474 =head1 DESCRIPTION
 475
 476 =head2 setup_for
 477
 478   Devel::Declare->setup_for(
 479     $package,
 480     {
 481       $name => { $op_type => $sub }
 482     }
 483   );
 484
 485 Currently valid op types: 'check', 'rv2cv'
 486
 487 =head1 AUTHORS
 488
 489 Matt S Trout - <mst@shadowcat.co.uk>
 490
 491 Company: http://www.shadowcat.co.uk/
 492 Blog: http://chainsawblues.vox.com/
 493
 494 Florian Ragwitz E<lt>rafl@debian.orgE<gt>
 495
 496 =head1 LICENSE
 497
 498 This library is free software under the same terms as perl itself
 499
 500 =cut
 501
 502 1;