From: Robin Edwards Date: Fri, 4 Dec 2009 20:29:29 +0000 (+0000) Subject: rules are now called by parser X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1e6f2675c3482ba065a151a2ff0645f9beade65c;p=p5sagit%2FDevel-Declare-Keyword.git rules are now called by parser --- diff --git a/examples/DevelDeclareExample.pm b/examples/DevelDeclareExample.pm index a7798cb..dc030bd 100644 --- a/examples/DevelDeclareExample.pm +++ b/examples/DevelDeclareExample.pm @@ -17,7 +17,6 @@ sub import { ); no strict 'refs'; *{$caller.'::method'} = sub (&) {}; - use strict; use warnings; } @@ -104,7 +103,7 @@ sub inject_if_block { } sub inject_scope { - on_scope_end { + on_scope_end {# my $linestr = Devel::Declare::get_linestr; my $offset = Devel::Declare::get_linestr_offset; substr($linestr, $offset, 0) = ';'; diff --git a/examples/KeywordMethod.pm b/examples/KeywordMethod.pm index ba570f3..17a68b2 100644 --- a/examples/KeywordMethod.pm +++ b/examples/KeywordMethod.pm @@ -7,7 +7,7 @@ our $OFFSET; keyword method => { name=>{parse=>\&parse_name}, - proto=>{parse=>\&parse_proto, action=>\&proto_action, eos=>\&proto_eos}}; + proto=>{parse=>\&parse_proto, action=>\&proto_action}}; #parse method name sub parse_name { @@ -48,12 +48,6 @@ sub proto_action { return $inject; } -sub proto_eos { - my $linestr = get_line; - my $loffset = get_line_offset; - substr($linestr, $loffset, 0) = ';'; - set_line($linestr); -} 1; diff --git a/examples/Method2.pm b/examples/Method2.pm new file mode 100644 index 0000000..07d4ea3 --- /dev/null +++ b/examples/Method2.pm @@ -0,0 +1,39 @@ +package Method2; +use lib 'lib/'; +use Keyword; +use Data::Dumper; + +keyword method (ident?, proto?, something) { + warn Dumper @_; +}; + +sub ident { + my $parser = ${shift()}; + if (my $len = $parser->scan_word(1)) { + my $l = $parser->line; + my $ident = substr($l, $parser->offset, $len); + substr($l, $parser->offset, $len) = ''; + $parser->line($l); + return $ident; + } +} + +sub proto { + my $parser = ${shift()}; + my $l = $parser->line; + if (substr($l, $parser->offset, 1) eq '(') { + my $length = $parser->scan_string; + my $proto = $parser->scanned; + $l = $parser->line; + substr($l, $parser->offset, $length) = ''; + $parser->line($l); + return $proto; + } +} + +sub something { + my $parser = ${shift()}; + warn "heyho"; +} + +1; diff --git a/lib/Keyword.pm b/lib/Keyword.pm index 66689cc..0857fbd 100644 --- a/lib/Keyword.pm +++ b/lib/Keyword.pm @@ -1,26 +1,21 @@ 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(@_); }; @@ -29,115 +24,127 @@ sub 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 { @@ -151,25 +158,13 @@ sub mk_import { }; } -=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() }; "; @@ -185,7 +180,7 @@ sub mk_parser { } }; } - +=cut #shadow sub shadow { my $sub = shift; diff --git a/lib/Keyword/Rule/Prototype.pm b/lib/Keyword/Rule/Prototype.pm new file mode 100644 index 0000000..5f5ce26 --- /dev/null +++ b/lib/Keyword/Rule/Prototype.pm @@ -0,0 +1,3 @@ +package Keyword::Rule::Prototype; + +1;