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