lib/Devel/Declare/Context/Simple.pm

   1 package Devel::Declare::Context::Simple;
   2
   3 use strict;
   4 use warnings;
   5 use Devel::Declare ();
   6 use B::Hooks::EndOfScope;
   7 use Carp qw/confess/;
   8
   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   return $self;
  18 }
  19
  20 sub offset {
  21   my $self = shift;
  22   return $self->{Offset}
  23 }
  24
  25 sub inc_offset {
  26   my $self = shift;
  27   $self->{Offset} += shift;
  28 }
  29
  30 sub declarator {
  31   my $self = shift;
  32   return $self->{Declarator}
  33 }
  34
  35 sub skip_declarator {
  36   my $self = shift;
  37   my $decl = $self->declarator;
  38   my $len = Devel::Declare::toke_scan_word($self->offset, 0);
  39   confess "Couldn't find declarator '$decl'"
  40     unless $len;
  41
  42   my $linestr = $self->get_linestr;
  43   my $name = substr($linestr, $self->offset, $len);
  44   confess "Expected declarator '$decl', got '${name}'"
  45     unless $name eq $decl;
  46
  47   $self->inc_offset($len);
  48 }
  49
  50 sub skipspace {
  51   my $self = shift;
  52   $self->inc_offset(Devel::Declare::toke_skipspace($self->offset));
  53 }
  54
  55 sub get_linestr {
  56   my $self = shift;
  57   my $line = Devel::Declare::get_linestr();
  58   return $line;
  59 }
  60
  61 sub set_linestr {
  62   my $self = shift;
  63   my ($line) = @_;
  64   Devel::Declare::set_linestr($line);
  65 }
  66
  67 sub strip_name {
  68   my $self = shift;
  69   $self->skipspace;
  70   if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) {
  71     my $linestr = $self->get_linestr();
  72     my $name = substr( $linestr, $self->offset, $len );
  73     substr( $linestr, $self->offset, $len ) = '';
  74     $self->set_linestr($linestr);
  75     return $name;
  76   }
  77
  78   $self->skipspace;
  79   return;
  80 }
  81
  82 sub strip_ident {
  83   my $self = shift;
  84   $self->skipspace;
  85   if (my $len = Devel::Declare::toke_scan_ident( $self->offset )) {
  86     my $linestr = $self->get_linestr();
  87     my $ident = substr( $linestr, $self->offset, $len );
  88     substr( $linestr, $self->offset, $len ) = '';
  89     $self->set_linestr($linestr);
  90     return $ident;
  91   }
  92
  93   $self->skipspace;
  94   return;
  95 }
  96
  97 sub strip_proto {
  98   my $self = shift;
  99   $self->skipspace;
 100
 101   my $linestr = $self->get_linestr();
 102   if (substr($linestr, $self->offset, 1) eq '(') {
 103     my $length = Devel::Declare::toke_scan_str($self->offset);
 104     my $proto = Devel::Declare::get_lex_stuff();
 105     Devel::Declare::clear_lex_stuff();
 106     $linestr = $self->get_linestr();
 107
 108     substr($linestr, $self->offset, $length) = '';
 109     $self->set_linestr($linestr);
 110
 111     return $proto;
 112   }
 113   return;
 114 }
 115
 116 sub strip_names_and_args {
 117   my $self = shift;
 118   $self->skipspace;
 119
 120   my @args;
 121
 122   my $linestr = $self->get_linestr;
 123   if (substr($linestr, $self->offset, 1) eq '(') {
 124     # We had a leading paren, so we will now expect comma separated
 125     # arguments
 126     substr($linestr, $self->offset, 1) = '';
 127     $self->set_linestr($linestr);
 128     $self->skipspace;
 129
 130     # At this point we expect to have a comma-separated list of
 131     # barewords with optional protos afterward, so loop until we
 132     # run out of comma-separated values
 133     while (1) {
 134       # Get the bareword
 135       my $thing = $self->strip_name;
 136       # If there's no bareword here, bail
 137       confess "failed to parse bareword. found ${linestr}"
 138         unless defined $thing;
 139
 140       $linestr = $self->get_linestr;
 141       if (substr($linestr, $self->offset, 1) eq '(') {
 142         # This one had a proto, pull it out
 143         push(@args, [ $thing, $self->strip_proto ]);
 144       } else {
 145         # This had no proto, so store it with an undef
 146         push(@args, [ $thing, undef ]);
 147       }
 148       $self->skipspace;
 149       $linestr = $self->get_linestr;
 150
 151       if (substr($linestr, $self->offset, 1) eq ',') {
 152         # We found a comma, strip it out and set things up for
 153         # another iteration
 154         substr($linestr, $self->offset, 1) = '';
 155         $self->set_linestr($linestr);
 156         $self->skipspace;
 157       } else {
 158         # No comma, get outta here
 159         last;
 160       }
 161     }
 162
 163     # look for the final closing paren of the list
 164     if (substr($linestr, $self->offset, 1) eq ')') {
 165       substr($linestr, $self->offset, 1) = '';
 166       $self->set_linestr($linestr);
 167       $self->skipspace;
 168     }
 169     else {
 170       # fail if it isn't there
 171       confess "couldn't find closing paren for argument. found ${linestr}"
 172     }
 173   } else {
 174     # No parens, so expect a single arg
 175     my $thing = $self->strip_name;
 176     # If there's no bareword here, bail
 177     confess "failed to parse bareword. found ${linestr}"
 178       unless defined $thing;
 179     $linestr = $self->get_linestr;
 180     if (substr($linestr, $self->offset, 1) eq '(') {
 181       # This one had a proto, pull it out
 182       push(@args, [ $thing, $self->strip_proto ]);
 183     } else {
 184       # This had no proto, so store it with an undef
 185       push(@args, [ $thing, undef ]);
 186     }
 187   }
 188
 189   return \@args;
 190 }
 191
 192 sub get_curstash_name {
 193   return Devel::Declare::get_curstash_name;
 194 }
 195
 196 sub shadow {
 197   my $self = shift;
 198   my $pack = $self->get_curstash_name;
 199   Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
 200 }
 201
 202 sub inject_if_block {
 203   my $self   = shift;
 204   my $inject = shift;
 205   my $before = shift || '';
 206
 207   $self->skipspace;
 208
 209   my $linestr = $self->get_linestr;
 210   if (substr($linestr, $self->offset, 1) eq '{') {
 211     substr($linestr, $self->offset + 1, 0) = $inject;
 212     substr($linestr, $self->offset, 0) = $before;
 213     $self->set_linestr($linestr);
 214     return 1;
 215   }
 216   return 0;
 217 }
 218
 219 sub scope_injector_call {
 220   my $self = shift;
 221   my $inject = shift || '';
 222   return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
 223 }
 224
 225 sub inject_scope {
 226   my $class = shift;
 227   my $inject = shift;
 228   on_scope_end {
 229       my $linestr = Devel::Declare::get_linestr;
 230       return unless defined $linestr;
 231       my $offset  = Devel::Declare::get_linestr_offset;
 232       substr( $linestr, $offset, 0 ) = ';' . $inject;
 233       Devel::Declare::set_linestr($linestr);
 234   };
 235 }
 236
 237 1;
 238 # vi:sw=2 ts=2