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