#!/usr/bin/perl
package Devel::Assert::Parser;
use strict;
use Devel::Declare ();
sub DEBUG() { 0 }
our $VERSION = '0.01';
sub new{
my ($class, $offset) = @_;
print STDERR "new called at $offset\n" if DEBUG;
bless {
offset => $offset,
}, $class;
}
#token manip
sub skip_word{
my $self = shift;
print STDERR "skip_word called at $self->{offset}\n" if DEBUG;
if (my $len = Devel::Declare::toke_scan_word($self->{'offset'}, 1)) {
$self->{'offset'} += $len;
}
}
sub get_word{
my $self = shift;
print STDERR "get_word called at $self->{offset}\n" if DEBUG;
if (my $len = Devel::Declare::toke_scan_word($self->{'offset'}, 1)) {
return substr(Devel::Declare::get_linestr(), $self->{'offset'}, $len);
}
return '';
}
sub skip_spaces{
my $self = shift;
print STDERR "skip_spaces called at $self->{offset}\n" if DEBUG;
$self->{'offset'} += Devel::Declare::toke_skipspace($self->{'offset'});
}
sub get_symbols{
my ($self, $len) = @_;
print STDERR "get_symbols called at $self->{offset} for $len\n" if DEBUG;
return substr(Devel::Declare::get_linestr(), $self->{'offset'}, $len);
}
sub extract_args{
my $self = shift;
print STDERR "extract_args called at $self->{offset}\n" if DEBUG;
my $linestr = Devel::Declare::get_linestr();
if (substr($linestr, $self->{'offset'}, 1) eq '(') {
my $length = Devel::Declare::toke_scan_str($self->{'offset'});
my $proto = Devel::Declare::get_lex_stuff();
Devel::Declare::clear_lex_stuff();
$linestr = Devel::Declare::get_linestr();
if (
$length < 0
||
$self->{'offset'} + $length > length($linestr)
){
require Carp;
Carp::croak("Unbalanced text supplied for assert");
}
substr($linestr, $self->{'offset'}, $length) = '';
Devel::Declare::set_linestr($linestr);
return $proto;
}
return '';
}
#injectors
sub inject{
my ($self, $inject) = @_;
print STDERR "inject called at $self->{offset} for '$inject'\n" if DEBUG;
my $linestr = Devel::Declare::get_linestr;
if ($self->{'offset'} > length($linestr)){
require Carp;
Carp::croak("Parser tried to inject data outside program source, stopping");
}
substr($linestr, $self->{'offset'}, 0) = $inject;
Devel::Declare::set_linestr($linestr);
$self->{'offset'} += length($inject);
}
sub shadow{
my $pack = Devel::Declare::get_curstash_name;
print STDERR "shadow'ing for '${pack}::assert'\n" if DEBUG;
Devel::Declare::shadow_sub("${pack}::assert", $_[1]);
}
1;
__END__
=head1 NAME
Devel::Assert::Parser - parses source for L<Devel::Assert> and is not intended for external use.
=head1 AUTHOR
Copyright (c) 2009 by Sergey Aleynikov.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=cut