From: Robin Edwards <robin.ge@gmail.com>
Date: Thu, 10 Dec 2009 12:22:34 +0000 (+0000)
Subject: renamed rules to parse routines
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eb16341e056d783f44a708edde69ef455089b947;p=p5sagit%2FDevel-Declare-Keyword.git

renamed rules to parse routines
---

diff --git a/README b/README
index 811e7a3..9418b04 100644
--- a/README
+++ b/README
@@ -1,22 +1,23 @@
 TODO
-* create rule and actions keyword
-* write builtin rules
+* fix sub shadowing / installation
+* add end of scope hooks
+* write more tests and examples
 
 SYNTAX
 # just an idea.
 
-keyword method (identifier, prototype?) {
-	$block->end($prototype);
-	$block->begin($prototype);
+keyword method (identifier?, prototype?, block) {
+	$block->end($prototype->{end_code});
+	$block->begin($prototype->{begin_code});
 	$block->name($identifier);
-	$block->write;
 }
 
-rule prototype {
-	return $parser->line;
+#passed a Keyword::Parser object
+parse prototype ($parser) {
 }
 
-action prototype {
+#passed whatever rule returns
+action prototype ($match) {
 	my $match;
 	return $code;
 }
diff --git a/examples/DevelDeclareExample.pm b/examples/DevelDeclareExample.pm
index dc030bd..80500d8 100644
--- a/examples/DevelDeclareExample.pm
+++ b/examples/DevelDeclareExample.pm
@@ -35,7 +35,7 @@ sub parser {
 	if (defined $name) {
 		$name = join('::', Devel::Declare::get_curstash_name(), $name)
 		unless ($name =~ /::/);
-		shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+		shadow(sub (&) { no strict 'refs'; warn; *{$name} = shift; });
 	} else {
 		shadow(sub (&) { shift });
 	}
diff --git a/examples/KeywordMethod.pm b/examples/KeywordMethod.pm
deleted file mode 100644
index 17a68b2..0000000
--- a/examples/KeywordMethod.pm
+++ /dev/null
@@ -1,54 +0,0 @@
-package KeywordMethod;
-use strict;
-use warnings;
-use Keyword;
-
-our $OFFSET;
-
-keyword method => {
-		name=>{parse=>\&parse_name}, 
-		proto=>{parse=>\&parse_proto, action=>\&proto_action}};
-
-#parse method name
-sub parse_name {
-	if (my $len = scan_word(1)) {
-		my $line = get_line;
-		my $name = substr($line, $OFFSET, $len);
-		substr($line, $OFFSET, $len) = '';
-		set_line($line);
-		return $name;
-	}
-}
-
-#parse prototype
-sub parse_proto {
-	my $linestr = get_line;
-	if (substr($linestr, $OFFSET, 1) eq '(') {
-		#need to wrap the following stuff in Keyword:
-		my $length = scan_string;
-		my $proto = get_lex;
-		$linestr = get_line;
-		substr($linestr, $OFFSET, $length) = '';
-		set_line($linestr);
-		return $proto;
-	}
-	return;
-}
-
-#construct code for injection
-sub proto_action {
-	my ($proto) = @_;
-	my $inject = 'my ($self';
-	if (defined $proto) {
-		$inject .= ", $proto" if length($proto);
-		$inject .= ') = @_; ';
-	} else {
-		$inject .= ') = shift;';
-	}
-	return $inject;
-}
-
-
-1;
-
-
diff --git a/examples/Method2.pm b/examples/Method2.pm
index b77279e..bf61989 100644
--- a/examples/Method2.pm
+++ b/examples/Method2.pm
@@ -3,40 +3,18 @@ use lib 'lib/';
 use Keyword;
 use Data::Dumper;
 
-keyword method (ident?, proto?) {
-	warn "hello";
+keyword method (ident?, proto?, block) {
+	warn "method params: ".Dumper @_;
+#	$block->begin("warn 'hello from me';");
+	$block->name($ident);
 };
 
-sub rule_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 action_ident {
-	my $match = shift;
-}
-
-sub rule_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;
-	}
+	return @_;
 }
 
 sub action_proto {
-	my $match = shift;
+	return @_;
 }
 
 1;
diff --git a/lib/Keyword.pm b/lib/Keyword.pm
index 3cbad28..ec0fefa 100644
--- a/lib/Keyword.pm
+++ b/lib/Keyword.pm
@@ -6,9 +6,11 @@ use Devel::Declare;
 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
@@ -18,7 +20,10 @@ sub import {
 		{ 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;
@@ -26,167 +31,148 @@ sub 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;
diff --git a/lib/Keyword/Parse/.Block.pm.swp b/lib/Keyword/Parse/.Block.pm.swp
new file mode 100644
index 0000000..1f5c6ab
Binary files /dev/null and b/lib/Keyword/Parse/.Block.pm.swp differ
diff --git a/lib/Keyword/Parse/Block.pm b/lib/Keyword/Parse/Block.pm
new file mode 100644
index 0000000..353c609
--- /dev/null
+++ b/lib/Keyword/Parse/Block.pm
@@ -0,0 +1,48 @@
+package Keyword::Parse::Block;
+use strict;
+use warnings;
+
+sub new {
+	my ($parser) = @_;
+	my $self = bless({parser=>$parser}, __PACKAGE__);
+	return $self if $self->match;
+}
+
+sub match {
+	my ($self) = @_;
+	my $l = $self->{parser}->line;
+	if (substr($l, $self->{parser}->offset, 1) eq '{') {
+		return 1;
+	}
+}
+
+#add end of scope hook
+#inject code
+sub begin {
+	my ($self, $code) = @_;
+
+	my $l = $self->{parser}->line;
+	substr($l, $self->{parser}->offset+1, 0) = $code;
+	$self->{parser}->skip_ws;
+	$self->{parser}->line($l);
+}
+
+sub name {
+	my ($self, $name) = @_;
+	$self->{parser}->shadow($name);
+}
+
+sub terminate {
+	my $self = shift
+		# remove need for semi colon
+		#*{$module_user."::inject_scope"} = sub {
+		#		on_scope_end {
+		#			my $l = $parser->line;
+		#			my $loffset = $parser->line_offset;
+		#			substr($l, $loffset, 0) = ';';
+		#			$parser->line($l);
+		#	};
+		#}
+}
+
+1;
diff --git a/lib/Keyword/Parse/Ident.pm b/lib/Keyword/Parse/Ident.pm
new file mode 100644
index 0000000..6b68f7f
--- /dev/null
+++ b/lib/Keyword/Parse/Ident.pm
@@ -0,0 +1,16 @@
+package Keyword::Parse::Ident;
+use strict;
+use warnings;
+
+sub match {
+	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 if $ident =~ /^[a-z]{1}\w+$/i;
+	}
+}
+
+1;
diff --git a/lib/Keyword/Parse/Proto.pm b/lib/Keyword/Parse/Proto.pm
new file mode 100644
index 0000000..3e76554
--- /dev/null
+++ b/lib/Keyword/Parse/Proto.pm
@@ -0,0 +1,18 @@
+package Keyword::Parse::Proto;
+use strict;
+use warnings;
+
+sub match {
+	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;
+	}
+}
+
+1;
diff --git a/lib/Keyword/Parser.pm b/lib/Keyword/Parser.pm
index 8f0bdb3..5796c1e 100644
--- a/lib/Keyword/Parser.pm
+++ b/lib/Keyword/Parser.pm
@@ -2,13 +2,14 @@ package Keyword::Parser;
 use strict;
 use warnings;
 use Devel::Declare;
+use Data::Dumper;
 
 sub new {
 	my ($class, $self) = @_;
 	$self = {} unless $self;
 	no strict 'refs';
 	$self->{offset} = \${caller()."::_PARSER_OFFSET"};
-	${$self->{offset}} ||= 0;
+	${$self->{offset}} = 0;
 	bless($self,__PACKAGE__);	
 }
 
@@ -63,4 +64,25 @@ sub line_offset {
 	return Devel::Declare::get_linestr_offset;
 }
 
+sub shadow {
+	my ($self, $name) = @_;
+	$name = $self->package()."::$name" if $name;
+
+	my $sub;
+
+	if($name) {
+
+			warn "$name: ".Dumper @_;
+		$sub = sub (&) {
+			no strict 'refs'; 
+			*{$name} = shift;
+		};
+	}
+	else {
+		$sub = sub (&) { shift; };
+	}
+
+	Devel::Declare::shadow_sub("$name", $sub);
+}
+
 1;
diff --git a/lib/Keyword/Rule/Prototype.pm b/lib/Keyword/Rule/Prototype.pm
deleted file mode 100644
index 5f5ce26..0000000
--- a/lib/Keyword/Rule/Prototype.pm
+++ /dev/null
@@ -1,3 +0,0 @@
-package Keyword::Rule::Prototype;
-
-1;
diff --git a/t/02-keyword-method.t b/t/02-keyword-method.t
index a7cca25..f8471d9 100644
--- a/t/02-keyword-method.t
+++ b/t/02-keyword-method.t
@@ -4,11 +4,16 @@ use warnings;
 use lib 'examples/';
 use Method2;
 
-method name ($a, $b, $c) { warn "hello"; };
+method something ($a, $b, $c) { 
+	warn "oooK"; 
+};
 
 
 1;
 
 use Test::More qw/no_plan/;
 use Data::Dumper;
+
+Foobar->something;
+
 ok 1;
diff --git a/t/03-keyword-syntax.t b/t/03-keyword-syntax.t
new file mode 100644
index 0000000..aa8e963
--- /dev/null
+++ b/t/03-keyword-syntax.t
@@ -0,0 +1,12 @@
+use Test::More qw/no_plan/;
+use Keyword;
+use Data::Dumper;
+ok 1;
+
+keyword method (ident?, proto?, somethingelse) {
+	warn Dumper @_;
+};
+
+
+ok 1;
+