lib/Devel/Declare/Context/Simple.pm

   1 package Devel::Declare::Context::Simple;
   2
   3 use Devel::Declare ();
   4 use Scope::Guard;
   5 use strict;
   6 use warnings;
   7
   8 sub new {
   9     my $class = shift;
  10     bless {@_}, $class;
  11 }
  12
  13 sub init {
  14     my $ctx = shift;
  15     @{$ctx}{ qw(Declarator Offset) } = @_;
  16     $ctx;
  17 }
  18
  19 sub offset : lvalue { shift->{Offset}; }
  20 sub declarator { shift->{Declarator} }
  21
  22 sub skip_declarator {
  23     my $ctx = shift;
  24     $ctx->offset += Devel::Declare::toke_move_past_token( $ctx->offset );
  25 }
  26
  27 sub skipspace {
  28     my $ctx = shift;
  29     $ctx->offset += Devel::Declare::toke_skipspace( $ctx->offset );
  30 }
  31
  32 sub strip_name {
  33     my $ctx = shift;
  34     $ctx->skipspace;
  35     if( my $len = Devel::Declare::toke_scan_word( $ctx->offset, 1 ) ) {
  36         my $linestr = Devel::Declare::get_linestr();
  37         my $name = substr( $linestr, $ctx->offset, $len );
  38         substr( $linestr, $ctx->offset, $len ) = '';
  39         Devel::Declare::set_linestr($linestr);
  40         return $name;
  41     }
  42     return;
  43 }
  44
  45 sub strip_proto {
  46     my $ctx = shift;
  47     $ctx->skipspace;
  48
  49     my $linestr = Devel::Declare::get_linestr();
  50     if( substr( $linestr, $ctx->offset, 1 ) eq '(' ) {
  51         my $length = Devel::Declare::toke_scan_str( $ctx->offset );
  52         my $proto  = Devel::Declare::get_lex_stuff();
  53         Devel::Declare::clear_lex_stuff();
  54         $linestr = Devel::Declare::get_linestr();
  55         substr( $linestr, $ctx->offset, $length ) = '';
  56         Devel::Declare::set_linestr($linestr);
  57         return $proto;
  58     }
  59     return;
  60 }
  61
  62 sub get_curstash_name {
  63     return Devel::Declare::get_curstash_name;
  64 }
  65
  66 sub shadow {
  67     my $ctx  = shift;
  68     my $pack = $ctx->get_curstash_name;
  69     Devel::Declare::shadow_sub( $pack . '::' . $ctx->declarator, $_[0] );
  70 }
  71
  72 sub inject_if_block {
  73     my $ctx    = shift;
  74     my $inject = shift;
  75     $ctx->skipspace;
  76     my $linestr = Devel::Declare::get_linestr;
  77     if( substr( $linestr, $ctx->offset, 1 ) eq '{' ) {
  78         substr( $linestr, $ctx->offset + 1, 0 ) = $inject;
  79         Devel::Declare::set_linestr($linestr);
  80     }
  81 }
  82
  83 sub scope_injector_call {
  84     return ' BEGIN { ' . __PACKAGE__ . '::inject_scope }; ';
  85 }
  86
  87 sub inject_scope {
  88     my $ctx = shift;
  89     $^H |= 0x120000;
  90     $^H{DD_METHODHANDLERS} = Scope::Guard->new(
  91         sub {
  92             my $linestr = Devel::Declare::get_linestr;
  93             my $offset  = Devel::Declare::get_linestr_offset;
  94             substr( $linestr, $offset, 0 ) = ';';
  95             Devel::Declare::set_linestr($linestr);
  96         }
  97     );
  98 }
  99
 100 1;
 101