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 WarningOnRedefined) } = @_;
  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 warning_on_redefine {
  36   my $self = shift;
  37   return $self->{WarningOnRedefined}
  38 }
  39
  40 sub skip_declarator {
  41   my $self = shift;
  42   my $decl = $self->declarator;
  43   my $len = Devel::Declare::toke_scan_word($self->offset, 0);
  44   confess "Couldn't find declarator '$decl'"
  45     unless $len;
  46
  47   my $linestr = $self->get_linestr;
  48   my $name = substr($linestr, $self->offset, $len);
  49   confess "Expected declarator '$decl', got '${name}'"
  50     unless $name eq $decl;
  51
  52   $self->inc_offset($len);
  53 }
  54
  55 sub skipspace {
  56   my $self = shift;
  57   $self->inc_offset(Devel::Declare::toke_skipspace($self->offset));
  58 }
  59
  60 sub get_linestr {
  61   my $self = shift;
  62   my $line = Devel::Declare::get_linestr();
  63   return $line;
  64 }
  65
  66 sub set_linestr {
  67   my $self = shift;
  68   my ($line) = @_;
  69   Devel::Declare::set_linestr($line);
  70 }
  71
  72 sub strip_name {
  73   my $self = shift;
  74   $self->skipspace;
  75   if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) {
  76     my $linestr = $self->get_linestr();
  77     my $name = substr( $linestr, $self->offset, $len );
  78     substr( $linestr, $self->offset, $len ) = '';
  79     $self->set_linestr($linestr);
  80     return $name;
  81   }
  82
  83   $self->skipspace;
  84   return;
  85 }
  86
  87 sub strip_ident {
  88   my $self = shift;
  89   $self->skipspace;
  90   if (my $len = Devel::Declare::toke_scan_ident( $self->offset )) {
  91     my $linestr = $self->get_linestr();
  92     my $ident = substr( $linestr, $self->offset, $len );
  93     substr( $linestr, $self->offset, $len ) = '';
  94     $self->set_linestr($linestr);
  95     return $ident;
  96   }
  97
  98   $self->skipspace;
  99   return;
 100 }
 101
 102 sub strip_proto {
 103   my $self = shift;
 104   $self->skipspace;
 105
 106   my $linestr = $self->get_linestr();
 107   if (substr($linestr, $self->offset, 1) eq '(') {
 108     my $length = Devel::Declare::toke_scan_str($self->offset);
 109     my $proto = Devel::Declare::get_lex_stuff();
 110     Devel::Declare::clear_lex_stuff();
 111     $linestr = $self->get_linestr();
 112
 113     substr($linestr, $self->offset, $length) = '';
 114     $self->set_linestr($linestr);
 115
 116     return $proto;
 117   }
 118   return;
 119 }
 120
 121 sub strip_names_and_args {
 122   my $self = shift;
 123   $self->skipspace;
 124
 125   my @args;
 126
 127   my $linestr = $self->get_linestr;
 128   if (substr($linestr, $self->offset, 1) eq '(') {
 129     # We had a leading paren, so we will now expect comma separated
 130     # arguments
 131     substr($linestr, $self->offset, 1) = '';
 132     $self->set_linestr($linestr);
 133     $self->skipspace;
 134
 135     # At this point we expect to have a comma-separated list of
 136     # barewords with optional protos afterward, so loop until we
 137     # run out of comma-separated values
 138     while (1) {
 139       # Get the bareword
 140       my $thing = $self->strip_name;
 141       # If there's no bareword here, bail
 142       confess "failed to parse bareword. found ${linestr}"
 143         unless defined $thing;
 144
 145       $linestr = $self->get_linestr;
 146       if (substr($linestr, $self->offset, 1) eq '(') {
 147         # This one had a proto, pull it out
 148         push(@args, [ $thing, $self->strip_proto ]);
 149       } else {
 150         # This had no proto, so store it with an undef
 151         push(@args, [ $thing, undef ]);
 152       }
 153       $self->skipspace;
 154       $linestr = $self->get_linestr;
 155
 156       if (substr($linestr, $self->offset, 1) eq ',') {
 157         # We found a comma, strip it out and set things up for
 158         # another iteration
 159         substr($linestr, $self->offset, 1) = '';
 160         $self->set_linestr($linestr);
 161         $self->skipspace;
 162       } else {
 163         # No comma, get outta here
 164         last;
 165       }
 166     }
 167
 168     # look for the final closing paren of the list
 169     if (substr($linestr, $self->offset, 1) eq ')') {
 170       substr($linestr, $self->offset, 1) = '';
 171       $self->set_linestr($linestr);
 172       $self->skipspace;
 173     }
 174     else {
 175       # fail if it isn't there
 176       confess "couldn't find closing paren for argument. found ${linestr}"
 177     }
 178   } else {
 179     # No parens, so expect a single arg
 180     my $thing = $self->strip_name;
 181     # If there's no bareword here, bail
 182     confess "failed to parse bareword. found ${linestr}"
 183       unless defined $thing;
 184     $linestr = $self->get_linestr;
 185     if (substr($linestr, $self->offset, 1) eq '(') {
 186       # This one had a proto, pull it out
 187       push(@args, [ $thing, $self->strip_proto ]);
 188     } else {
 189       # This had no proto, so store it with an undef
 190       push(@args, [ $thing, undef ]);
 191     }
 192   }
 193
 194   return \@args;
 195 }
 196
 197 sub strip_attrs {
 198   my $self = shift;
 199   $self->skipspace;
 200
 201   my $linestr = Devel::Declare::get_linestr;
 202   my $attrs   = '';
 203
 204   if (substr($linestr, $self->offset, 1) eq ':') {
 205     while (substr($linestr, $self->offset, 1) ne '{') {
 206       if (substr($linestr, $self->offset, 1) eq ':') {
 207         substr($linestr, $self->offset, 1) = '';
 208         Devel::Declare::set_linestr($linestr);
 209
 210         $attrs .= ':';
 211       }
 212
 213       $self->skipspace;
 214       $linestr = Devel::Declare::get_linestr();
 215
 216       if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) {
 217         my $name = substr($linestr, $self->offset, $len);
 218         substr($linestr, $self->offset, $len) = '';
 219         Devel::Declare::set_linestr($linestr);
 220
 221         $attrs .= " ${name}";
 222
 223         if (substr($linestr, $self->offset, 1) eq '(') {
 224           my $length = Devel::Declare::toke_scan_str($self->offset);
 225           my $arg    = Devel::Declare::get_lex_stuff();
 226           Devel::Declare::clear_lex_stuff();
 227           $linestr = Devel::Declare::get_linestr();
 228           substr($linestr, $self->offset, $length) = '';
 229           Devel::Declare::set_linestr($linestr);
 230
 231           $attrs .= "(${arg})";
 232         }
 233       }
 234     }
 235
 236     $linestr = Devel::Declare::get_linestr();
 237   }
 238
 239   return $attrs;
 240 }
 241
 242
 243 sub get_curstash_name {
 244   return Devel::Declare::get_curstash_name;
 245 }
 246
 247 sub shadow {
 248   my $self = shift;
 249   my $pack = $self->get_curstash_name;
 250   Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
 251 }
 252
 253 sub inject_if_block {
 254   my $self   = shift;
 255   my $inject = shift;
 256   my $before = shift || '';
 257
 258   $self->skipspace;
 259
 260   my $linestr = $self->get_linestr;
 261   if (substr($linestr, $self->offset, 1) eq '{') {
 262     substr($linestr, $self->offset + 1, 0) = $inject;
 263     substr($linestr, $self->offset, 0) = $before;
 264     $self->set_linestr($linestr);
 265     return 1;
 266   }
 267   return 0;
 268 }
 269
 270 sub scope_injector_call {
 271   my $self = shift;
 272   my $inject = shift || '';
 273   return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
 274 }
 275
 276 sub inject_scope {
 277   my $class = shift;
 278   my $inject = shift;
 279   on_scope_end {
 280       my $linestr = Devel::Declare::get_linestr;
 281       return unless defined $linestr;
 282       my $offset  = Devel::Declare::get_linestr_offset;
 283       substr( $linestr, $offset, 0 ) = ';' . $inject;
 284       Devel::Declare::set_linestr($linestr);
 285   };
 286 }
 287
 288 1;
 289 # vi:sw=2 ts=2