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,
 114       defined($length) ? $length : length($linestr)) = '';
 115     $self->set_linestr($linestr);
 116
 117     return $proto;
 118   }
 119   return;
 120 }
 121
 122 sub strip_names_and_args {
 123   my $self = shift;
 124   $self->skipspace;
 125
 126   my @args;
 127
 128   my $linestr = $self->get_linestr;
 129   if (substr($linestr, $self->offset, 1) eq '(') {
 130     # We had a leading paren, so we will now expect comma separated
 131     # arguments
 132     substr($linestr, $self->offset, 1) = '';
 133     $self->set_linestr($linestr);
 134     $self->skipspace;
 135
 136     # At this point we expect to have a comma-separated list of
 137     # barewords with optional protos afterward, so loop until we
 138     # run out of comma-separated values
 139     while (1) {
 140       # Get the bareword
 141       my $thing = $self->strip_name;
 142       # If there's no bareword here, bail
 143       confess "failed to parse bareword. found ${linestr}"
 144         unless defined $thing;
 145
 146       $linestr = $self->get_linestr;
 147       if (substr($linestr, $self->offset, 1) eq '(') {
 148         # This one had a proto, pull it out
 149         push(@args, [ $thing, $self->strip_proto ]);
 150       } else {
 151         # This had no proto, so store it with an undef
 152         push(@args, [ $thing, undef ]);
 153       }
 154       $self->skipspace;
 155       $linestr = $self->get_linestr;
 156
 157       if (substr($linestr, $self->offset, 1) eq ',') {
 158         # We found a comma, strip it out and set things up for
 159         # another iteration
 160         substr($linestr, $self->offset, 1) = '';
 161         $self->set_linestr($linestr);
 162         $self->skipspace;
 163       } else {
 164         # No comma, get outta here
 165         last;
 166       }
 167     }
 168
 169     # look for the final closing paren of the list
 170     if (substr($linestr, $self->offset, 1) eq ')') {
 171       substr($linestr, $self->offset, 1) = '';
 172       $self->set_linestr($linestr);
 173       $self->skipspace;
 174     }
 175     else {
 176       # fail if it isn't there
 177       confess "couldn't find closing paren for argument. found ${linestr}"
 178     }
 179   } else {
 180     # No parens, so expect a single arg
 181     my $thing = $self->strip_name;
 182     # If there's no bareword here, bail
 183     confess "failed to parse bareword. found ${linestr}"
 184       unless defined $thing;
 185     $linestr = $self->get_linestr;
 186     if (substr($linestr, $self->offset, 1) eq '(') {
 187       # This one had a proto, pull it out
 188       push(@args, [ $thing, $self->strip_proto ]);
 189     } else {
 190       # This had no proto, so store it with an undef
 191       push(@args, [ $thing, undef ]);
 192     }
 193   }
 194
 195   return \@args;
 196 }
 197
 198 sub strip_attrs {
 199   my $self = shift;
 200   $self->skipspace;
 201
 202   my $linestr = Devel::Declare::get_linestr;
 203   my $attrs   = '';
 204
 205   if (substr($linestr, $self->offset, 1) eq ':') {
 206     while (substr($linestr, $self->offset, 1) ne '{') {
 207       if (substr($linestr, $self->offset, 1) eq ':') {
 208         substr($linestr, $self->offset, 1) = '';
 209         Devel::Declare::set_linestr($linestr);
 210
 211         $attrs .= ':';
 212       }
 213
 214       $self->skipspace;
 215       $linestr = Devel::Declare::get_linestr();
 216
 217       if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) {
 218         my $name = substr($linestr, $self->offset, $len);
 219         substr($linestr, $self->offset, $len) = '';
 220         Devel::Declare::set_linestr($linestr);
 221
 222         $attrs .= " ${name}";
 223
 224         if (substr($linestr, $self->offset, 1) eq '(') {
 225           my $length = Devel::Declare::toke_scan_str($self->offset);
 226           my $arg    = Devel::Declare::get_lex_stuff();
 227           Devel::Declare::clear_lex_stuff();
 228           $linestr = Devel::Declare::get_linestr();
 229           substr($linestr, $self->offset, $length) = '';
 230           Devel::Declare::set_linestr($linestr);
 231
 232           $attrs .= "(${arg})";
 233         }
 234       }
 235     }
 236
 237     $linestr = Devel::Declare::get_linestr();
 238   }
 239
 240   return $attrs;
 241 }
 242
 243
 244 sub get_curstash_name {
 245   return Devel::Declare::get_curstash_name;
 246 }
 247
 248 sub shadow {
 249   my $self = shift;
 250   my $pack = $self->get_curstash_name;
 251   Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
 252 }
 253
 254 sub inject_if_block {
 255   my $self   = shift;
 256   my $inject = shift;
 257   my $before = shift || '';
 258
 259   $self->skipspace;
 260
 261   my $linestr = $self->get_linestr;
 262   if (substr($linestr, $self->offset, 1) eq '{') {
 263     substr($linestr, $self->offset + 1, 0) = $inject;
 264     substr($linestr, $self->offset, 0) = $before;
 265     $self->set_linestr($linestr);
 266     return 1;
 267   }
 268   return 0;
 269 }
 270
 271 sub scope_injector_call {
 272   my $self = shift;
 273   my $inject = shift || '';
 274   return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
 275 }
 276
 277 sub inject_scope {
 278   my $class = shift;
 279   my $inject = shift;
 280   on_scope_end {
 281       my $linestr = Devel::Declare::get_linestr;
 282       return unless defined $linestr;
 283       my $offset  = Devel::Declare::get_linestr_offset;
 284       substr( $linestr, $offset, 0 ) = ';' . $inject;
 285       Devel::Declare::set_linestr($linestr);
 286   };
 287 }
 288
 289 1;
 290 # vi:sw=2 ts=2