xt/lib/Devel/Declare/Context/Simple.pm

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