use B::Hooks::EndOfScope;
use Data::Dumper;
use Keyword::Parser;
+use Keyword::Parse::Ident;
+use Keyword::Parse::Proto;
+use Keyword::Parse::Block;
our $VERSION = '0.01';
-
our $KW_MODULE = caller;
#setup parser for keyword syntax
{ keyword => { const => \&sig_parser } }
);
no strict 'refs';
- *{$KW_MODULE.'::keyword'} = sub (&) {};
+ *{$KW_MODULE.'::keyword'} = sub (&) {
+ no strict 'refs';
+ $Keyword::__keyword_block = shift;
+ };
strict->import;
warnings->import;
#parses keyword signature
sub sig_parser {
- my $parser = new Keyword::Parser;
+ my $parser = Keyword::Parser->new;
$parser->next_token;
$parser->skip_ws;
#strip out the name of new keyword
- my $name;
- 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 {
- die "expecting identifier for keyword near:\n".$parser->line;
- }
+ my $keyword = Keyword::Parse::Ident::match($parser) or
+ die "expecting identifier for keyword near:\n".$parser->line;
$parser->skip_ws;
#extract the prototype
- my $proto;
- 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".$parser->line;
- }
+ my $proto = Keyword::Parse::Proto::match($parser) or
+ die "expecting prototype for keyword at:\n".$parser->line;
+
+ #produce list of parse routines and there actions from prototype
+ my $plist = proto_to_parselist($proto);
- #produce list of executable rules from prototype
- my $rule = proto_to_rule($proto);
+ #produce sub that executes these routines
+ my $psub = mk_parser($plist,$keyword);
+
+ no strict 'refs';
+ *{$KW_MODULE."::import"} = mk_import($psub, $keyword);
- #produce sub that executes these rules
- my $new_parser = rule_to_parser($rule,$name);
+ $parser->skip_ws;
+ my $l = $parser->line;
+ substr($l, $parser->offset+1, 0) = proto_to_code($proto);
+ $parser->line($l);
#construct shadow sub
- my $shadow = sub (&) {
- my $block = shift;
+ my $shadow = sub (&) { no strict 'refs'; *{$KW_MODULE."::$keyword"} = shift };
- no strict 'refs';
- #install new keyword module import routine
- *{$KW_MODULE."::import"} = mk_import($name, $new_parser);
+ #install shadow for keyword routine
+ $parser->shadow($keyword, $shadow);
+}
- #install new keyword sub
- *{$KW_MODULE."::$name"} = sub { &$block(); };
- };
+sub proto_to_code {
+ my ($proto) = @_;
+ my $inject = " my (";
+ $proto =~ s/\?//g;
+ $proto =~ s/\s//g;
+ $proto =~ s/\,/\,\$/g;
+ $proto = "\$".$proto if length $proto;
+ $inject .= $proto.') = @_; ';
- #install shadow for keyword routine
- Devel::Declare::shadow_sub($parser->package."::keyword", $shadow);
+ return $inject;
}
-#converts prototype to a list of rules and actions to be invoked by the parser
-sub proto_to_rule {
- my $proto = shift;
- $proto =~ s/\s+//g;
- my @rules;
+#converts prototype to a list of parse and action subs
+sub proto_to_parselist {
+ my $proto = shift;
+ $proto =~ s/\s+//g; #
+
+ my @pa;
- for my $rule (split /\,/, $proto){
- $rule =~ /^[a-z]{1}\w+[\?]?$/i or die "bad identifier '$rule' for rule in prototype.";
+ for my $ident (split /\,/, $proto){
+ $ident =~ /^[a-z]{1}\w+[\?]?$/i or
+ die "bad identifier '$ident' in prototype.";
- #flag as optional should it be postfixed with a '?'
+ #foptional if ident postfixed with a '?'
my $opt;
- $rule =~ s/\?//g and $opt = 1 if $rule =~ /\?$/;
+ $ident =~ s/\?//g and $opt = 1 if $ident =~ /\?$/;
- #TODO should check for local rule, if not attempt to load one
- #append to list of rules matching builtin rules
- no strict 'refs';
- switch($rule) {
- case 'identifier' {
- push @rules,
- {name=>$rule, rule=>\&{'Keyword::Rules::identifier'},
- action=>\&{$KW_MODULE."::action_$rule"},
+ # I should NOT be prefix subs with action_ / rule_
+ switch($ident) {
+ no strict 'refs';
+
+ #builtin
+ case 'ident' {
+ push @pa,
+ {name=>$ident, parse=>\&{'Keyword::Parse::Ident::match'},
+ action=>\&{$KW_MODULE."::action_ident"},
opt=>$opt, builtin=>1}
}
- case 'prototype' {
- push @rules,
- {name=>$rule, rule=>\&{'Keyword::Rules::prototype'},
- action=>\&{$KW_MODULE."::action_$rule"},
+
+ case 'proto' {
+ push @pa,
+ {name=>$ident, parse=>\&{'Keyword::Parse::Proto::match'},
+ action=>\&{$KW_MODULE."::action_proto"},
opt=>$opt, builtin=>1}
}
- #TODO check this code exists
- else { push @rules, {name=>$rule, rule=>\&{$KW_MODULE."::rule_$rule"},
- action=>\&{$KW_MODULE."::action_$rule"},
- opt=>$opt}; };
+
+ case 'block' {
+ push @pa,
+ {name=>$ident, parse=>\&{'Keyword::Parse::Block::new'},
+ action=>sub{return @_}, #returns block object
+ opt=>$opt, builtin=>1}
+ }
+
+ #custom parse routine
+ else {
+ push @pa,
+ {name=>$ident, parse=>\&{$KW_MODULE."::parse_$ident"},
+ action=>\&{$KW_MODULE."::action_$ident"},
+ opt=>$opt};
+ };
}
}
- return \@rules
+ return \@pa;
}
-sub rule_to_parser {
- my ($rule,$keyword) = @_;
+sub mk_parser {
+ my ($plist,$keyword) = @_;
return sub {
- my $parser = new Keyword::Parser;
+ my $parser = Keyword::Parser->new;
$parser->next_token; # skip keyword
$parser->skip_ws;
+ my @arg;
- my $result;
-
- #call each rule
- for my $r (@$rule) {
- my $match = &{$r->{rule}}($parser); # call rule
+ #call each parse routine and action
+ for my $r (@$plist) {
+ #TODO: add evals
+ my $match = &{$r->{parse}}($parser);
$parser->skip_ws;
- die "failed to match rule $r->{name}" unless $match or $r->{opt};
- my $code = &{$r->{action}}($match); # call action
+ die "failed to match parse action $r->{name}" unless $match or $r->{opt};
+ push @arg, &{$r->{action}}($match);
}
- my $name = $parser->package."::$keyword";
-
- #setup shadow sub
- my $shadow = sub (&) {
- no strict 'refs';
- *{$name} = shift;
- };
- Devel::Declare::shadow_sub($name, $shadow);
+ &{$Keyword::__keyword_block}(@arg);
};
}
# build import routine for new keyword module
sub mk_import {
- my ($keyword, $parser) = @_;
+ my ($pb, $keyword) = @_;
return sub {
# module_user is the user of your Keyword based module
my $module_user = caller();
Devel::Declare->setup_for(
$module_user,
- { $keyword => { const => $parser } }
+ { $keyword => { const => $pb } }
);
# setup prototype for there keyword into modules namespace
no strict 'refs';
*{$module_user."::$keyword"} = sub (&) {};
-
- # remove need for semi colon
- *{$KW_MODULE."::inject_scope"} = sub {
- on_scope_end {
- my $l = $parser->line;
- my $loffset = $parser->line_offset;
- substr($l, $loffset, 0) = ';';
- $parser->line($l);
- };
- }
};
}
-#inject into block
-sub inject_if_block {
- my ($parser, $code) = @_;
- $parser->skip_ws;
- my $l = $parser->line;
- if (substr($l, $parser->offset, 1) eq '{') {
- substr($l, $parser->offset+1, 0) = $code;
- $parser->line($l);
- }
- else {
- die "expecting a block";
- }
-}
1;
projects / p5sagit/Devel-Declare-Keyword.git / commitdiff