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 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   delete ${"${pack}::"}{$pname};
 101   no warnings 'redefine';
 102   no warnings 'prototype';
 103   *{$name} = $cr;
 104   set_in_declare(~~@{$temp_name||[]});
 105 }
 106
 107 sub done_declare {
 108   no strict 'refs';
 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);
 112   $name =~ s/(.*):://;
 113   my $temp_pack = $1;
 114   delete ${"${temp_pack}::"}{$name};
 115   if ($saved) {
 116     no warnings 'prototype';
 117     *{"${temp_pack}::${name}"} = $saved;
 118   }
 119   set_in_declare(~~@{$temp_name||[]});
 120 }
 121
 122 sub build_sub_installer {
 123   my ($class, $pack, $name, $proto) = @_;
 124   return eval "
 125     package ${pack};
 126     my \$body;
 127     sub ${name} (${proto}) :lvalue {\n"
 128     .'  if (wantarray) {
 129         goto &$body;
 130       }
 131       my $ret = $body->(@_);
 132       return $ret;
 133     };
 134     sub { ($body) = @_; };';
 135 }
 136
 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';
 141   my %setup_for_args;
 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"; }
 155       if (@_) {
 156         if (ref $_[0] eq 'HASH') {
 157           shift;
 158           if (wantarray) {
 159             my @ret = $run->(undef, undef, @_);
 160             return @ret;
 161           }
 162           my $r = $run->(undef, undef, @_);
 163           return $r;
 164         } else {
 165           return @_[1..$#_];
 166         }
 167       }
 168       return my $sv;
 169     });
 170     $setup_for_args{$name} = [
 171       $flags,
 172       sub {
 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, @_));
 177         };
 178         my ($name_h, $XX);
 179         if (defined $proto) {
 180           $name_h = sub :lvalue { return my $sv; };
 181           $XX = $main_handler;
 182         } elsif (defined $name && length $name) {
 183           $name_h = $main_handler;
 184         }
 185         $extra_code ||= '';
 186         $extra_code = '}, sub {'.$extra_code;
 187         return ($name_h, $XX, $extra_code);
 188       }
 189     ];
 190   }
 191   $class->setup_for($pack, \%setup_for_args);
 192 }
 193
 194 sub install_declarator {
 195   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 196   $class->setup_declarators($target_pack, {
 197     $target_name => {
 198       flags => $flags,
 199       compile => $filter,
 200       run => $handler,
 201    }
 202   });
 203 }
 204
 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);
 217     }
 218     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 219       $found_name = substr($linestr, $offset, $len);
 220       $offset += $len;
 221     }
 222   }
 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();
 229       clear_lex_stuff();
 230       my $replace =
 231         ($found_name ? ' ' : '=')
 232         .'X'.(' ' x length($found_proto));
 233       $linestr = get_linestr();
 234       substr($linestr, $offset, $length) = $replace;
 235       set_linestr($linestr);
 236       $offset += $length;
 237     }
 238   }
 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);
 244     $offset++;
 245     if (defined $ret && length $ret) {
 246       substr($linestr, $offset, 0) = $ret;
 247       set_linestr($linestr);
 248     }
 249   } else {
 250     init_declare(@args);
 251   }
 252   #warn "linestr now ${linestr}";
 253 }
 254
 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);
 266     }
 267   }
 268 }
 269
 270 sub linestr_callback {
 271   my $type = shift;
 272   my $name = $_[0];
 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}->(@_);
 281     }
 282   } else {
 283     die "PANIC: unknown thing in handlers for $pack $name: $handlers";
 284   }
 285 }
 286
 287 =head1 NAME
 288
 289 Devel::Declare -
 290
 291 =head1 SYNOPSIS
 292
 293   use Devel::Declare ();
 294   use Scope::Guard;
 295
 296   {
 297     package MethodHandlers;
 298
 299     use strict;
 300     use warnings;
 301
 302     our ($Declarator, $Offset);
 303
 304     sub skip_declarator {
 305       $Offset += Devel::Declare::toke_move_past_token($Offset);
 306     }
 307
 308     sub skipspace {
 309       $Offset += Devel::Declare::toke_skipspace($Offset);
 310     }
 311
 312     sub strip_name {
 313       skipspace;
 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);
 319         return $name;
 320       }
 321       return;
 322     }
 323
 324     sub strip_proto {
 325       skipspace;
 326
 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);
 335         return $proto;
 336       }
 337       return;
 338     }
 339
 340     sub shadow {
 341       my $pack = Devel::Declare::get_curstash_name;
 342       Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
 343     }
 344
 345     # undef  -> my ($self) = shift;
 346     # ''     -> my ($self) = @_;
 347     # '$foo' -> my ($self, $foo) = @_;
 348
 349     sub make_proto_unwrap {
 350       my ($proto) = @_;
 351       my $inject = 'my ($self';
 352       if (defined $proto) {
 353         $inject .= ", $proto" if length($proto);
 354         $inject .= ') = @_; ';
 355       } else {
 356         $inject .= ') = shift;';
 357       }
 358       return $inject;
 359     }
 360
 361     sub inject_if_block {
 362       my $inject = shift;
 363       skipspace;
 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);
 368       }
 369     }
 370
 371     sub scope_injector_call {
 372       return ' BEGIN { MethodHandlers::inject_scope }; ';
 373     }
 374
 375     sub parser {
 376       local ($Declarator, $Offset) = @_;
 377       skip_declarator;
 378       my $name = strip_name;
 379       my $proto = strip_proto;
 380       my $inject = make_proto_unwrap($proto);
 381       if (defined $name) {
 382         $inject = scope_injector_call().$inject;
 383       }
 384       inject_if_block($inject);
 385       if (defined $name) {
 386         $name = join('::', Devel::Declare::get_curstash_name(), $name)
 387           unless ($name =~ /::/);
 388         shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 389       } else {
 390         shadow(sub (&) { shift });
 391       }
 392     }
 393
 394     sub inject_scope {
 395       $^H |= 0x120000;
 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);
 401       });
 402     }
 403   }
 404
 405   my ($test_method1, $test_method2, @test_list);
 406
 407   {
 408     package DeclareTest;
 409
 410     sub method (&);
 411
 412     BEGIN {
 413       Devel::Declare->setup_for(
 414         __PACKAGE__,
 415         { method => { const => \&MethodHandlers::parser } }
 416       );
 417     }
 418
 419     method new {
 420       my $class = ref $self || $self;
 421       return bless({ @_ }, $class);
 422     }
 423
 424     method foo ($foo) {
 425       return (ref $self).': Foo: '.$foo;
 426     }
 427
 428     method upgrade(){ # no spaces to make case pathological
 429       bless($self, 'DeclareTest2');
 430     }
 431
 432     method DeclareTest2::bar () {
 433       return 'DeclareTest2: bar';
 434     }
 435
 436     $test_method1 = method {
 437       return join(', ', $self->{attr}, $_[1]);
 438     };
 439
 440     $test_method2 = method ($what) {
 441       return join(', ', ref $self, $what);
 442     };
 443
 444     method main () { return "main"; }
 445
 446     @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 447
 448   }
 449
 450   use Test::More 'no_plan';
 451
 452   my $o = DeclareTest->new(attr => "value");
 453
 454   isa_ok($o, 'DeclareTest');
 455
 456   is($o->{attr}, 'value', '@_ args ok');
 457
 458   is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 459
 460   is($o->main, 'main', 'declaration of package named method ok');
 461
 462   $o->upgrade;
 463
 464   isa_ok($o, 'DeclareTest2');
 465
 466   is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 467
 468   is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 469
 470   is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 471
 472   is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
 473
 474 (this is t/method-no-semi.t in this distribution)
 475
 476 =head1 DESCRIPTION
 477
 478 =head2 setup_for
 479
 480   Devel::Declare->setup_for(
 481     $package,
 482     {
 483       $name => { $op_type => $sub }
 484     }
 485   );
 486
 487 Currently valid op types: 'check', 'rv2cv'
 488
 489 =head1 AUTHOR
 490
 491 Matt S Trout - <mst@shadowcat.co.uk>
 492
 493 Company: http://www.shadowcat.co.uk/
 494 Blog: http://chainsawblues.vox.com/
 495
 496 =head1 LICENSE
 497
 498 This library is free software under the same terms as perl itself
 499
 500 =cut
 501
 502 1;