From: Robin Edwards Date: Mon, 7 Dec 2009 13:49:13 +0000 (+0000) Subject: boing X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e27f1c003e4ea95e93fc88148537b4d663256c76;p=p5sagit%2FDevel-Declare-Keyword.git boing --- diff --git a/README b/README index c5b6355..ecafc13 100644 --- a/README +++ b/README @@ -1,7 +1,25 @@ TODO -* create rule keyword -* figure out why the parser is loosing its position +* create rule and actions keyword * write builtin rules +* decide on injection api + +SYNTAX + +keyword method (identifier, prototype?) { + inject($identifer->begin_code); + inject($prototype->begin_code); + inject_end($identifer->end_code); + inject_end($prototype->end_code); +} + +rule prototype { + return $parser->line; +} + +action prototype { + my $match; + return $code; +} INFO rob: hey, we were talking about this diff --git a/examples/Method2.pm b/examples/Method2.pm index 07038e8..b77279e 100644 --- a/examples/Method2.pm +++ b/examples/Method2.pm @@ -7,7 +7,7 @@ keyword method (ident?, proto?) { warn "hello"; }; -sub ident { +sub rule_ident { my $parser = shift; if (my $len = $parser->scan_word(1)) { my $l = $parser->line; @@ -18,7 +18,11 @@ sub ident { } } -sub proto { +sub action_ident { + my $match = shift; +} + +sub rule_proto { my $parser = shift; my $l = $parser->line; if (substr($l, $parser->offset, 1) eq '(') { @@ -31,4 +35,8 @@ sub proto { } } +sub action_proto { + my $match = shift; +} + 1; diff --git a/lib/Keyword.pm b/lib/Keyword.pm index 38a9d8c..3cbad28 100644 --- a/lib/Keyword.pm +++ b/lib/Keyword.pm @@ -18,7 +18,7 @@ sub import { { keyword => { const => \&sig_parser } } ); no strict 'refs'; - *{$KW_MODULE.'::keyword'} = sub (&) { &{$KW_MODULE."::import"} = mk_import(@_); }; + *{$KW_MODULE.'::keyword'} = sub (&) {}; strict->import; warnings->import; @@ -59,7 +59,7 @@ sub sig_parser { my $rule = proto_to_rule($proto); #produce sub that executes these rules - my $new_parser = rule_to_parser($rule); + my $new_parser = rule_to_parser($rule,$name); #construct shadow sub my $shadow = sub (&) { @@ -73,11 +73,12 @@ sub sig_parser { *{$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 invoked by the parserparser +#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; @@ -91,19 +92,27 @@ sub proto_to_rule { my $opt; $rule =~ s/\?//g and $opt = 1 if $rule =~ /\?$/; + #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::Rule::Identifier::parse'},opt=>$opt, builtin=>1} + {name=>$rule, rule=>\&{'Keyword::Rules::identifier'}, + action=>\&{$KW_MODULE."::action_$rule"}, + opt=>$opt, builtin=>1} } case 'prototype' { push @rules, - {name=>$rule, rule=>\&{'Keyword::Rule::Prototype::parse'},opt=>$opt, builtin=>1} + {name=>$rule, rule=>\&{'Keyword::Rules::prototype'}, + action=>\&{$KW_MODULE."::action_$rule"}, + opt=>$opt, builtin=>1} } #TODO check this code exists - else { push @rules, {name=>$rule, rule=>\&{$KW_MODULE."::$rule"},opt=>$opt}; }; + else { push @rules, {name=>$rule, rule=>\&{$KW_MODULE."::rule_$rule"}, + action=>\&{$KW_MODULE."::action_$rule"}, + opt=>$opt}; }; } } @@ -111,7 +120,7 @@ sub proto_to_rule { } sub rule_to_parser { - my $rule = shift; + my ($rule,$keyword) = @_; return sub { my $parser = new Keyword::Parser; $parser->next_token; # skip keyword @@ -119,12 +128,22 @@ sub rule_to_parser { my $result; + #call each rule for my $r (@$rule) { - my $match = &{$r->{rule}}($parser); + my $match = &{$r->{rule}}($parser); # call rule $parser->skip_ws; die "failed to match rule $r->{name}" unless $match or $r->{opt}; + my $code = &{$r->{action}}($match); # call action } + my $name = $parser->package."::$keyword"; + + #setup shadow sub + my $shadow = sub (&) { + no strict 'refs'; + *{$name} = shift; + }; + Devel::Declare::shadow_sub($name, $shadow); }; } @@ -140,59 +159,33 @@ sub mk_import { { $keyword => { const => $parser } } ); - #setup prototype for there keyword into modules namespace + # setup prototype for there keyword into modules namespace no strict 'refs'; *{$module_user."::$keyword"} = sub (&) {}; - # create scope inject sub - # *{$KW_MODULE."::inject_scope"} = sub { - # on_scope_end { - # my $linestr = get_line; - # my $loffset = get_line_offset; - # substr($linestr, $loffset, 0) = ';'; - # set_line($linestr); - # }; - #} - }; -} - -# Constructs a parser for the new keyword -=cut -sub mk_parser { - my ($name, $rule) = @_; - - - #skip keyword - - my $code = " BEGIN { $KW_MODULE\::inject_scope() }; "; - - #inject block - inject_block($code); - - if (defined $name) { - $name = join('::', Devel::Declare::get_curstash_name() , $name) - unless ($name =~ /::/); - shadow(sub (&) { no strict 'refs'; *{$name} = shift; }); - } else { - shadow(sub (&) { shift }); + # 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); + }; } }; } -=cut -#shadow -sub shadow { - my $sub = shift; - Devel::Declare::shadow_sub(Devel::Declare::get_curstash_name()."::".${$KW_MODULE."::DECL"}, $sub); -} #inject into block -sub inject_block { - my $inject = shift; - ${$KW_MODULE."::OFFSET"} += Devel::Declare::toke_skipspace(${$KW_MODULE."::OFFSET"}); - my $linestr = Devel::Declare::get_linestr; - if (substr($linestr, ${$KW_MODULE."::OFFSET"}, 1) eq '{') { - substr($linestr, ${$KW_MODULE."::OFFSET"}+1, 0) = $inject; - Devel::Declare::set_linestr($linestr); +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"; } } diff --git a/t/02-keyword-method.t b/t/02-keyword-method.t index 78f439b..a7cca25 100644 --- a/t/02-keyword-method.t +++ b/t/02-keyword-method.t @@ -4,9 +4,7 @@ use warnings; use lib 'examples/'; use Method2; -method name ($a, $b, $c) { - warn "hello"; -}; +method name ($a, $b, $c) { warn "hello"; }; 1;