view release on metacpan or  search on metacpan

lib/Devel/Declare/Lexer.pm  view on Meta::CPAN

    no strict 'refs';

    my %subinject = ();
    if(ref($args[0]) =~ /HASH/) {
        $DEBUG and print STDERR "Using hash for import\n";
        %subinject = %{$args[0]};
        @args = keys %subinject;
    }

    my @consts;

    my %tags = map { $_ => 1 } @args;
    if($tags{":debug"}) {
        $DEBUG = 1;
    }
    if($tags{":lexer_test"}) {
        $DEBUG and print STDERR "Adding 'lexer_test' to keyword list\n";

        push @consts, "lexer_test";
    }

    my @names = @args;
    for my $name (@names) {
        next if $name =~ /:/;
        $DEBUG and print STDERR "Adding '$name' to keyword list\n";

        push @consts, $name;
    }

    for my $word (@consts) {
        $DEBUG and print STDERR "Injecting '$word' into '$caller'\n";
        Devel::Declare->setup_for(
            $caller,
            {
                $word => { const => \&lexer }
            }
        );
        if($subinject{$word}) {
            $DEBUG and print STDERR "- Using sub provided in import\n";
            *{$caller.'::'.$word} = $subinject{$word};
        } else {
            $DEBUG and print STDERR "- Using default sub\n";
            *{$caller.'::'.$word} = sub () { 1; };
        }
    }
}

my %named_lexed_stack = ();
sub lexed
{
    my ($key, $callback) = @_;
    $DEBUG and print STDERR "Registered callback for keyword '$key'\n";
    $named_lexed_stack{$key} = $callback;
}

sub call_lexed
{
    my ($name, $stream) = @_;

    $DEBUG and print STDERR "Checking for callbacks for keyword '$name'\n";
    $DEBUG and print STDERR Dumper($stream) . "\n";

    my $callback = $named_lexed_stack{$name};
    if($callback) {
        $DEBUG and print STDERR "Found callback '$callback' for keyword '$name'\n";
        $stream = &$callback($stream);
    }

    $DEBUG and print STDERR Dumper($stream) . "\n";

    return $stream;
}

sub lexer
{
    my ($symbol, $offset) = @_;

    $DEBUG and print "=" x 80, "\n";

    my $linestr = Devel::Declare::get_linestr;
    my $original_linestr = $linestr;
    my $original_offset = $offset;
    $DEBUG and print STDERR "Starting with linestr '$linestr'\n";

    my @tokens = ();
    tie @tokens, "Devel::Declare::Lexer::Stream";
    my ($len, $tok);
    my $eoleos = 0;
    my $line = 1;

    # Skip the declarator
    $offset += Devel::Declare::toke_move_past_token($offset);
    push @tokens, new Devel::Declare::Lexer::Token::Declarator( value => $symbol );
    $DEBUG and print STDERR "Skipped declarator '$symbol'\n";

    my %lineoffsets = ( 1 => $offset );

    # We call this from a few places inside the loop
    my $skipspace = sub {
        # Move past any whitespace
        $len = Devel::Declare::toke_skipspace($offset);
        if($len > 0) {
            $tok = substr($linestr, $offset, $len);
            $DEBUG and print STDERR "Skipped whitespace '$tok', length [$len]\n";
            push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => $tok );
            $offset += $len;

            if($tok =~ /\n/) {
                # its odd that this works without handling any line numbering
                # I think we end up here when an end of line is found after a bareword (e.g. print\n"something")
                # It probably still needs some work on line numbering, but everything just seems to work! 
                $DEBUG and print STDERR "Got end of line in skipspace, probable bareword preceeding EOL\n";
                Devel::Declare::clear_lex_stuff;

                # We've got a new line so we need to refresh our linestr
                $linestr = Devel::Declare::get_linestr;
                $original_linestr = $linestr;

                $DEBUG and print STDERR "Refreshed linestr [$linestr]\n";
            }