--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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@>') : ()),
+);
--- /dev/null
+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
+ };
--- /dev/null
+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;
--- /dev/null
+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;
+
+
--- /dev/null
+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;
--- /dev/null
+use Test::More qw/no_plan/;
+use_ok('Keyword');
+use lib 'examples/';
+use_ok('DevelDeclareExample');
--- /dev/null
+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);
--- /dev/null
+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);
projects / p5sagit/Devel-Declare-Keyword.git / commitdiff