package Keyword;
use strict;
use warnings;
+use Switch;
use Devel::Declare;
use B::Hooks::EndOfScope;
use Data::Dumper;
+use Keyword::Parser;
our $VERSION = '0.01';
our $KW_MODULE = caller;
-our $OFFSET;
-our $DECLARATOR;
-
-=head1 Stuff for parsing keyword syntax
-=cut
-
+#setup parser for keyword syntax
sub import {
- my $class = shift;
-
Devel::Declare->setup_for(
$KW_MODULE,
- { keyword => { const => \&keyword_parser } }
+ { keyword => { const => \&sig_parser } }
);
no strict 'refs';
*{$KW_MODULE.'::keyword'} = sub (&) { &{$KW_MODULE."::import"} = mk_import(@_); };
warnings->import;
}
-sub keyword_parser {
- local ($DECLARATOR, $OFFSET) = @_;
-
- #skip keyword
- $OFFSET += Devel::Declare::toke_move_past_token($OFFSET);
-
- #skip ws
- $OFFSET += Devel::Declare::toke_skipspace($OFFSET);
-
+#parses keyword signature
+sub sig_parser {
+ my $parser = new Keyword::Parser;
+ $parser->next_token;
+ $parser->skip_ws;
#strip out the name of new keyword
my $name;
-
- if (my $len = Devel::Declare::toke_scan_word($OFFSET, 1)) {
- my $linestr = Devel::Declare::get_linestr();
- $name = substr($linestr, $OFFSET, $len);
- substr($linestr, $OFFSET, $len) = '';
- Devel::Declare::set_linestr($linestr);
+ if (my $len = $parser->scan_word(1)) {
+ my $l = $parser->line;
+ $name = substr($l, $parser->offset, $len);
+ substr($l, $parser->offset, $len) = '';
+ $parser->line($l);
} else {
- my $line = Devel::Declare::get_linestr;
- die "expecting identifier for keyword near:\n\t$line";
+ die "expecting identifier for keyword near:\n".$parser->line;
}
- #skip ws
- $OFFSET += Devel::Declare::toke_skipspace($OFFSET);
+ $parser->skip_ws;
#extract the prototype
my $proto;
- my $linestr = Devel::Declare::get_linestr();
- if (substr($linestr, $OFFSET, 1) eq '(') {
- my $length = Devel::Declare::toke_scan_str($OFFSET);
- $proto = Devel::Declare::get_lex_stuff();
- Devel::Declare::clear_lex_stuff();
- $linestr = Devel::Declare::get_linestr();
- substr($linestr, $OFFSET, $length) = '';
- Devel::Declare::set_linestr($linestr);
+ my $l = $parser->line;
+ if (substr($l, $parser->offset, 1) eq '(') {
+ my $length = $parser->scan_string;
+ $proto = $parser->scanned;
+ substr($l, $parser->offset, $length) = '';
+ $parser->line($l);
} else {
- die "expecting prototype for keyword at:\n\t$linestr";
+ die "expecting prototype for keyword at:\n".$parser->line;
}
- #produce rules from prototype
+ #produce list of executable rules from prototype
my $rule = proto_to_rule($proto);
- my $fullname = $name =~ /::/ ? $name :
- join('::', Devel::Declare::get_curstash_name(), $name);
-
- shadow_keyword(sub (&) {
- my $block = shift;
-
- no strict 'refs';
- #install import routine
- *{$KW_MODULE."::import"} = mk_import($name, $rule);
-
- *{$fullname} = sub {
- #call main block
- &$block();
- };
- });
-}
+ #produce sub that executes these rules
+ my $new_parser = rule_to_parser($rule);
+
+ #construct shadow sub
+ my $shadow = sub (&) {
+ my $block = shift;
+
+ no strict 'refs';
+ #install new keyword module import routine
+ *{$KW_MODULE."::import"} = mk_import($name, $new_parser);
-sub shadow_keyword {
- my $pack = Devel::Declare::get_curstash_name;
- Devel::Declare::shadow_sub("${pack}::${DECLARATOR}", $_[0]);
+ #install new keyword sub
+ *{$KW_MODULE."::$name"} = sub { &$block(); };
+ };
+
+ #install shadow for keyword routine
+ Devel::Declare::shadow_sub($parser->package."::keyword", $shadow);
}
-#converts prototype to a list of rules to be called by parser
+#converts prototype to a list of rules to be invoked by the parserparser
sub proto_to_rule {
my $proto = shift;
$proto =~ s/\s+//g;
- my @rule;
-
- for my $ident (split /\,/, $proto){
- die "parsing prototype failed, bad identifier '$ident'" unless $ident =~ /^[a-z]{1}\w+[\?]?$/i;
-
- #TODO check if code is defined
- # then
- # check if it matches built-in rule
- # then provide ref to right bit of code.
- if ($ident =~ /\?$/) { # optional match
- $ident =~ s/\?//g;
- push @rule, { code=>"$KW_MODULE\::$ident", optional=>1};
- }
- else { # essential match
- push @rule, { code=>"$KW_MODULE\::$ident"};
+ my @rules;
+
+ for my $rule (split /\,/, $proto){
+ $rule =~ /^[a-z]{1}\w+[\?]?$/i or die "bad identifier '$rule' for rule in prototype.";
+
+ #flag as optional should it be postfixed with a '?'
+ my $opt;
+ $rule =~ s/\?//g and $opt = 1 if $rule =~ /\?$/;
+
+ #append to list of rules matching builtin rules
+ no strict 'refs';
+ switch($rule) {
+ case 'identifier' {
+ push @rules,
+ {name=>$rule, rule=>\&{'Keyword::Rule::Identifier::parse'},opt=>$opt, builtin=>1}
+ }
+ case 'prototype' {
+ push @rules,
+ {name=>$rule, rule=>\&{'Keyword::Rule::Prototype::parse'},opt=>$opt, builtin=>1}
+ }
+ #TODO check this code exists
+ else { push @rules, {name=>$rule, rule=>\&{$KW_MODULE."::$rule"},opt=>$opt}; };
}
}
- return \@rule;
+ return \@rules
}
-=head1 Internals used by new keywords
-=cut
+sub rule_to_parser {
+ my $rule = shift;
+ return sub {
+ my $parser = new Keyword::Parser;
+ $parser->next_token; # skip keyword
+ $parser->skip_ws;
+
+ my $result;
+
+ for my $r (@$rule) {
+ warn Dumper $r;
+ my $match = &{$r->{rule}}(\$parser);
+ warn "$r->{name} matched:\n$match\n";
+ #die "failed to match rule $r->{name}" unless $matched or $r->{opt};
+ #$result->{$r->{name}} = &{$r->{action}}($matched); #call rules action
+ }
-=head2 mk_import
-Constructs an import for subroutine for the new keyword
-=cut
+ };
+}
+# build import routine for new keyword module
sub mk_import {
- my ($keyword, $rule) = @_;
+ my ($keyword, $parser) = @_;
+
return sub {
- #modcaller is the user of *your* Keyword based module
- my $modcaller = caller();
- my $class = shift;
+ # module_user is the user of your Keyword based module
+ my $module_user = caller();
Devel::Declare->setup_for(
- $modcaller,
- { $keyword => { const => mk_parser($keyword, $rule) } }
+ $module_user,
+ { $keyword => { const => $parser } }
);
- *{$modcaller."::$keyword"} = sub (&) {};
+
+ #setup prototype for there keyword into modules namespace
+ no strict 'refs';
+ *{$module_user."::$keyword"} = sub (&) {};
# create scope inject sub
# *{$KW_MODULE."::inject_scope"} = sub {
};
}
-=head2 mk_parser
-Constructs a parser for the new keyword
+# Constructs a parser for the new keyword
=cut
-
sub mk_parser {
my ($name, $rule) = @_;
- return sub {
- (${$KW_MODULE."::DECL"}, ${$KW_MODULE."::OFFSET"}) = @_;
#skip keyword
- my $OFFSET = Devel::Declare::toke_move_past_token($OFFSET);
-
- my @matched;
-
- #execute each rule
-# for my $r (@$rule) {
- #push @matched, \*{"$r->{code}"}();
-# }
my $code = " BEGIN { $KW_MODULE\::inject_scope() }; ";
}
};
}
-
+=cut
#shadow
sub shadow {
my $sub = shift;
projects / p5sagit/Devel-Declare-Keyword.git / commitdiff