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 strip_attrs {
 193   my $self = shift;
 194   $self->skipspace;
 195
 196   my $linestr = Devel::Declare::get_linestr;
 197   my $attrs   = '';
 198
 199   if (substr($linestr, $self->offset, 1) eq ':') {
 200     while (substr($linestr, $self->offset, 1) ne '{') {
 201       if (substr($linestr, $self->offset, 1) eq ':') {
 202         substr($linestr, $self->offset, 1) = '';
 203         Devel::Declare::set_linestr($linestr);
 204
 205         $attrs .= ':';
 206       }
 207
 208       $self->skipspace;
 209       $linestr = Devel::Declare::get_linestr();
 210
 211       if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) {
 212         my $name = substr($linestr, $self->offset, $len);
 213         substr($linestr, $self->offset, $len) = '';
 214         Devel::Declare::set_linestr($linestr);
 215
 216         $attrs .= " ${name}";
 217
 218         if (substr($linestr, $self->offset, 1) eq '(') {
 219           my $length = Devel::Declare::toke_scan_str($self->offset);
 220           my $arg    = Devel::Declare::get_lex_stuff();
 221           Devel::Declare::clear_lex_stuff();
 222           $linestr = Devel::Declare::get_linestr();
 223           substr($linestr, $self->offset, $length) = '';
 224           Devel::Declare::set_linestr($linestr);
 225
 226           $attrs .= "(${arg})";
 227         }
 228       }
 229     }
 230
 231     $linestr = Devel::Declare::get_linestr();
 232   }
 233
 234   return $attrs;
 235 }
 236
 237
 238 sub get_curstash_name {
 239   return Devel::Declare::get_curstash_name;
 240 }
 241
 242 sub shadow {
 243   my $self = shift;
 244   my $pack = $self->get_curstash_name;
 245   Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
 246 }
 247
 248 sub inject_if_block {
 249   my $self   = shift;
 250   my $inject = shift;
 251   my $before = shift || '';
 252
 253   $self->skipspace;
 254
 255   my $linestr = $self->get_linestr;
 256   if (substr($linestr, $self->offset, 1) eq '{') {
 257     substr($linestr, $self->offset + 1, 0) = $inject;
 258     substr($linestr, $self->offset, 0) = $before;
 259     $self->set_linestr($linestr);
 260     return 1;
 261   }
 262   return 0;
 263 }
 264
 265 sub scope_injector_call {
 266   my $self = shift;
 267   my $inject = shift || '';
 268   return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
 269 }
 270
 271 sub inject_scope {
 272   my $class = shift;
 273   my $inject = shift;
 274   on_scope_end {
 275       my $linestr = Devel::Declare::get_linestr;
 276       return unless defined $linestr;
 277       my $offset  = Devel::Declare::get_linestr_offset;
 278       substr( $linestr, $offset, 0 ) = ';' . $inject;
 279       Devel::Declare::set_linestr($linestr);
 280   };
 281 }
 282
 283 1;
 284 # vi:sw=2 ts=2