From: Robin Edwards <robin.ge@gmail.com>
Date: Wed, 2 Dec 2009 13:46:55 +0000 (+0000)
Subject: initial import
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4695d447cbad1ccd38d9275f58d121cff7b32705;p=p5sagit%2FDevel-Declare-Keyword.git

initial import
---

4695d447cbad1ccd38d9275f58d121cff7b32705
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..8d3b516
--- /dev/null
+++ b/Changes
@@ -0,0 +1,6 @@
+Revision history for Perl extension Keyword.
+
+0.01  Mon Nov  9 17:40:23 2009
+	- original version; created by h2xs 1.23 with options
+		-X -n Keyword
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..e0efd61
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,10 @@
+Changes
+Makefile.PL
+MANIFEST
+README
+lib/Keyword.pm
+examples/DevelDeclareExample.pm
+examples/KeywordMethod.pm
+t/00-use.t
+t/01-develdeclareexample.t
+t/02-keyword-method.t
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..c1cb069
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,12 @@
+use 5.010000;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    NAME              => 'Keyword',
+    VERSION_FROM      => 'lib/Keyword.pm', # finds $VERSION
+    PREREQ_PM         => {}, # e.g., Module::Name => 1.1
+    ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM  => 'lib/Keyword.pm', # retrieve abstract from module
+       AUTHOR         => 'Robin Edwards <rob@>') : ()),
+);
diff --git a/README b/README
new file mode 100644
index 0000000..11493c6
--- /dev/null
+++ b/README
@@ -0,0 +1,28 @@
+TODO
+* export keyword
+* make operator keyword for moose
+
+INFO
+<mst> rob: hey, we were talking about this
+<mst> basically, the answer is to standardise the declaration forms
+<mst> so you have something like
+<mst> keyword method (Proto?, Name?, Block) {
+<mst> and then that can we statically analyzed by something like PPI
+<mst> in order to work out what the syntax is for the keyword
+<mst> then anything using 'keyword' can be supported by a single set of code
+<kentnl> I think you'd first have to standardise the syntax for declaring declarations
+<kentnl> but yes, I see what you mean :)
+<Zefram> a structured macro facility would help there.  but we're some way off being able to do that
+<mst> kentnl: yes
+<mst> kentnl: that's the point
+<mst> kentnl: we write a Devel::Declare keyword -called- keyword
+<mst> and standardise on that
+<Zefram> we desperately need APIs for things like "parse a block" (properly)
+<mst> yes. I was hoping we vcould at least work out how to fake them in the process
+<Zefram> I have a long-term plan to let much of the Perl parser work in a recursive-descent manner
+<kentnl> also, for pedanticsness sake, wouldn't the signature be keyword method ( Name?, Proto?, Block ) , unless of course, you meant the example to do "method ( $foo, $bar, $baz ) mymethod  { } " notation
+
+use Keyword;
+keyword method ( Name?, Proto?, Block ) { 
+#block
+	};
diff --git a/examples/DevelDeclareExample.pm b/examples/DevelDeclareExample.pm
new file mode 100644
index 0000000..a7798cb
--- /dev/null
+++ b/examples/DevelDeclareExample.pm
@@ -0,0 +1,125 @@
+package DevelDeclareExample;
+use strict;
+use warnings;
+use Devel::Declare;
+use B::Hooks::EndOfScope;
+
+# created by following the Devel::Declare example
+# used as reference when hacking Keyword.pm
+
+sub import {
+	my $class = shift;
+	my $caller = caller;
+
+	Devel::Declare->setup_for(
+		$caller,
+		{ method => { const => \&parser } }
+	);
+	no strict 'refs';
+	*{$caller.'::method'} = sub (&) {};
+	use strict;
+	use warnings;
+}
+
+our ($Declarator, $Offset);
+
+sub parser {
+	local ($Declarator, $Offset) = @_;
+	skip_declarator();          # step past 'method'
+	my $name = strip_name();    # strip out the name 'foo', if present
+	my $proto = strip_proto();  # strip out the prototype '($arg1, $arg2)', if present
+	my $inject = make_proto_unwrap($proto);
+	if (defined $name) {
+		$inject = scope_injector_call().$inject;
+	}
+	inject_if_block($inject);
+	if (defined $name) {
+		$name = join('::', Devel::Declare::get_curstash_name(), $name)
+		unless ($name =~ /::/);
+		shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+	} else {
+		shadow(sub (&) { shift });
+	}
+}
+
+
+sub skip_declarator {
+	$Offset += Devel::Declare::toke_move_past_token($Offset);
+}
+
+
+sub strip_name {
+	skipspace();
+	if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
+		my $linestr = Devel::Declare::get_linestr();
+		my $name = substr($linestr, $Offset, $len);
+		substr($linestr, $Offset, $len) = '';
+		Devel::Declare::set_linestr($linestr);
+		return $name;
+	}
+	return;
+}
+
+sub skipspace {
+	$Offset += Devel::Declare::toke_skipspace($Offset);
+}
+
+
+sub strip_proto {
+	skipspace;
+
+	my $linestr = Devel::Declare::get_linestr();
+	if (substr($linestr, $Offset, 1) eq '(') {
+		my $length = Devel::Declare::toke_scan_str($Offset);
+		my $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);
+		return $proto;
+	}
+	return;
+}
+
+sub make_proto_unwrap {
+	my ($proto) = @_;
+	my $inject = 'my ($self';
+	if (defined $proto) {
+		$inject .= ", $proto" if length($proto);
+		$inject .= ') = @_; ';
+	} else {
+		$inject .= ') = shift;';
+	}
+	return $inject;
+}
+
+sub inject_if_block {
+	my $inject = shift;
+	skipspace;
+	my $linestr = Devel::Declare::get_linestr;
+	if (substr($linestr, $Offset, 1) eq '{') {
+		substr($linestr, $Offset+1, 0) = $inject;
+		Devel::Declare::set_linestr($linestr);
+	}
+}
+
+sub inject_scope {
+	on_scope_end {
+		my $linestr = Devel::Declare::get_linestr;
+		my $offset = Devel::Declare::get_linestr_offset;
+		substr($linestr, $offset, 0) = ';';
+		Devel::Declare::set_linestr($linestr);
+	};
+}
+
+
+sub scope_injector_call {
+	return ' BEGIN { DevelDeclareExample::inject_scope() }; ';
+}
+
+sub shadow {
+	my $pack = Devel::Declare::get_curstash_name;
+	Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
+}
+
+1;
diff --git a/examples/KeywordMethod.pm b/examples/KeywordMethod.pm
new file mode 100644
index 0000000..ba570f3
--- /dev/null
+++ b/examples/KeywordMethod.pm
@@ -0,0 +1,60 @@
+package KeywordMethod;
+use strict;
+use warnings;
+use Keyword;
+
+our $OFFSET;
+
+keyword method => {
+		name=>{parse=>\&parse_name}, 
+		proto=>{parse=>\&parse_proto, action=>\&proto_action, eos=>\&proto_eos}};
+
+#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;
+}
+
+sub proto_eos {
+	my $linestr = get_line;
+	my $loffset = get_line_offset;
+	substr($linestr, $loffset, 0) = ';';
+	set_line($linestr);
+}
+
+1;
+
+
diff --git a/lib/Keyword.pm b/lib/Keyword.pm
new file mode 100644
index 0000000..c8f1398
--- /dev/null
+++ b/lib/Keyword.pm
@@ -0,0 +1,161 @@
+package Keyword;
+use 5.010000;
+use strict;
+use warnings;
+no strict 'refs';
+use Devel::Declare;
+use B::Hooks::EndOfScope;
+use Exporter 'import';
+use Data::Dumper;
+
+our $VERSION = '0.01';
+our @EXPORT = qw/keyword next_token skip_space
+		scan_word scan_string set_line get_line get_lex get_line_offset get_package/;
+
+our $MODULE = caller();
+
+
+=head1 api?
+
+keyword $yourkeyword => ( 
+				name => ( parse => sub {}, action => sub {}),
+				proto => ( parse => sub {}, action => sub {}),
+				block => ( parse => sub {}, action => sub {}, end_of_scope => sub {}),
+				);
+
+=cut
+
+=head1 EXPORTED Utility Functions
+=cut
+
+#next token
+sub next_token () {
+	${$MODULE."::OFFSET"} += Devel::Declare::toke_move_past_token(${$MODULE."::OFFSET"});
+}
+
+#skip space
+sub skip_space () {
+	${$MODULE."::OFFSET"} += Devel::Declare::toke_skipspace(${$MODULE."::OFFSET"});
+}
+
+#scan word
+sub scan_word ($) {
+	return Devel::Declare::toke_scan_word(${$MODULE."::OFFSET"}, shift);
+}
+
+#scan string eg "blah blsah " or q( some string )
+sub scan_string () {
+	return Devel::Declare::toke_scan_str(${$MODULE."::OFFSET"});
+}
+
+#get lex
+sub get_lex () {
+	my $stream = Devel::Declare::get_lex_stuff();
+	Devel::Declare::clear_lex_stuff();
+	return $stream;
+}
+
+#get line
+sub get_line () {
+	return Devel::Declare::get_linestr;
+}
+
+#set line
+sub set_line ($){
+	Devel::Declare::set_linestr(shift());
+}
+
+# get package - returns name of package being compiled 
+sub get_package (){
+	return Devel::Declare::get_curstash_name;
+}
+
+sub get_line_offset (){
+	return Devel::Declare::get_linestr_offset;
+}
+
+=head1 declarator
+=cut
+
+sub keyword (%) {
+	my ($keyword,$param) = @_;
+	*{$MODULE."::import"} = mk_import($keyword, $param);
+};
+
+#construct import sub;
+sub mk_import {
+	my ($keyword, $param) = @_;
+	return sub {
+		#modcaller is the user of *your* Keyword based module
+		my $modcaller = caller();
+		my $class = shift;
+		Devel::Declare->setup_for(
+			$modcaller,
+			{ $keyword => { const => mk_parser($keyword,$param) } }
+		);
+		*{$modcaller."::$keyword"} = sub (&) {};
+	};
+}
+
+#construct parser subroutine
+sub mk_parser {
+	my ($keyword, $param) = @_;
+
+	return sub {
+		(${$MODULE."::DECL"}, ${$MODULE."::OFFSET"}) = @_;
+
+		#skip keyword
+		next_token;
+		
+		#match name	
+		skip_space;
+		my $name = &{$param->{name}{parse}}();
+
+		#match proto
+		skip_space;
+		my $proto = &{$param->{proto}{parse}}();
+		my $code = &{$param->{proto}{action}}($proto);
+
+		#add eos hook and create sub;
+		if(exists $param->{proto}{eos}) {
+			$code = " BEGIN { $MODULE\::_$keyword\_inject_scope() };\n".$code;
+			no warnings;
+			*{$MODULE."::_$keyword\_inject_scope"} = sub {
+				on_scope_end {
+					&{$param->{proto}{eos}}();
+				};
+			};
+			use warnings;
+		}
+
+		#inject block
+		inject_block($code); 
+
+		if (defined $name) {
+			$name = join('::', get_package, $name)
+			unless ($name =~ /::/);
+			shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
+		} else {
+			shadow(sub (&) { shift });
+		}
+	};
+}
+
+#shadow
+sub shadow {
+	my $sub = shift;
+	Devel::Declare::shadow_sub(get_package."::".${$MODULE."::DECL"}, $sub);
+}
+
+#inject into block
+sub inject_block {
+	my $inject = shift;
+	skip_space;
+	my $linestr = get_line;
+	if (substr($linestr, ${$MODULE."::OFFSET"}, 1) eq '{') {
+		substr($linestr, ${$MODULE."::OFFSET"}+1, 0) = $inject;
+		set_line($linestr);
+	}
+}
+
+1;
diff --git a/lib/Keyword/.Orig.pm.swo b/lib/Keyword/.Orig.pm.swo
new file mode 100644
index 0000000..5b14666
Binary files /dev/null and b/lib/Keyword/.Orig.pm.swo differ
diff --git a/lib/Keyword/.Orig.pm.swp b/lib/Keyword/.Orig.pm.swp
new file mode 100644
index 0000000..f37deb8
Binary files /dev/null and b/lib/Keyword/.Orig.pm.swp differ
diff --git a/t/00-use.t b/t/00-use.t
new file mode 100644
index 0000000..7a8954e
--- /dev/null
+++ b/t/00-use.t
@@ -0,0 +1,4 @@
+use Test::More qw/no_plan/;
+use_ok('Keyword');
+use lib 'examples/';
+use_ok('DevelDeclareExample');
diff --git a/t/01-develdeclareexample.t b/t/01-develdeclareexample.t
new file mode 100644
index 0000000..028497f
--- /dev/null
+++ b/t/01-develdeclareexample.t
@@ -0,0 +1,26 @@
+package Foobar;
+use strict;
+use warnings;
+use lib 'examples/';
+use DevelDeclareExample;
+
+sub new {
+	my ($class,) = @_;
+	my $self = {};
+	bless($self, $class); 
+	return $self;
+}
+
+method amethod ($a, $b) {
+	return ($a + $b);
+}
+
+
+1;
+
+use Test::More qw/no_plan/;
+
+my $t = new Foobar;
+
+ok(defined $t);
+$t->amethod(1,2);
diff --git a/t/02-keyword-method.t b/t/02-keyword-method.t
new file mode 100644
index 0000000..d46f2d2
--- /dev/null
+++ b/t/02-keyword-method.t
@@ -0,0 +1,32 @@
+package Foobar;
+use strict;
+use warnings;
+use lib 'examples/';
+use KeywordMethod;
+use Data::Dumper;
+
+method oki () {
+	return 1;
+}
+
+method plus ($a, $b) {
+	warn "$a + $b";
+	return $a + $b;
+}
+
+method new () {
+	return bless({}, __PACKAGE__);
+}
+
+1;
+
+use Test::More qw/no_plan/;
+use Data::Dumper;
+ok 1;
+
+my $s = Foobar->new;
+ok($s);
+ok($s->oki);
+ok(1);
+ok($s->plus(1,2) == 3);
+ok(1);