flakey blockless support
Robin Edwards [Fri, 18 Dec 2009 16:15:10 +0000 (16:15 +0000)]
README
lib/Keyword.pm
lib/Keyword/Declare.pm
lib/Keyword/Parser.pm

diff --git a/README b/README
index e2aab40..36c79ec 100644 (file)
--- a/README
+++ b/README
@@ -2,6 +2,7 @@ ABOUT
 This module aims to provide an easy interface to Devel::Declare. 
 
 PLAN
+* STOP BLOCKLESS BEING EXECUTED AT COMPILE TIME
 * find usescases from: http://cpants.perl.org/dist/used_by/Devel-Declare
 * and go through perl's -existing- keywords print $fh "sddfsd". $f, $c etc
 * look at ... metalua ... and common lisp reader macros.
index 29004f6..c117a79 100644 (file)
@@ -46,16 +46,17 @@ sub keyword_parser {
 
        #strip out the name of new keyword
        my $keyword = parse_ident($kd) or
-       croak "expecting identifier for keyword near:\n".$kd->line;
+       confess "expecting identifier for keyword near:\n".$kd->line;
 
        $kd->skip_ws;
 
        #extract the prototype
        my $proto = parse_proto($kd)    or
-       croak "expecting prototype for keyword at:\n".$kd->line;
+       confess "expecting prototype for keyword at:\n".$kd->line;
 
        my $b = 1 if $proto =~ /block/i;
-       my $parser = Keyword::Parser->new({proto=>$proto, module=>$KW_MODULE, noblock=>$b});
+       my $parser = Keyword::Parser->new({proto=>$proto, 
+                       module=>$KW_MODULE, noblock=>$b, keyword=>$keyword});
 
        no strict 'refs';
        *{$KW_MODULE."::import"} = mk_import($parser->build, $keyword, $b);
@@ -78,11 +79,11 @@ sub parse_parser {
 
        #strip out the name of parse routine
        my $name = parse_ident($kd) or
-       croak "expecting identifier for parse near:\n".$kd->line;
+       confess "expecting identifier for parse near:\n".$kd->line;
 
        $kd->skip_ws;
        my $proto = parse_proto($kd)    or
-       croak "expecting prototype for parse at:\n".$kd->line;
+       confess "expecting prototype for parse at:\n".$kd->line;
 
        $kd->skip_ws;
        my $l = $kd->line;
@@ -105,11 +106,11 @@ sub action_parser {
 
        #strip out the name of action
        my $name = parse_ident($kd) or
-       croak "expecting identifier for action near:\n".$kd->line;
+       confess "expecting identifier for action near:\n".$kd->line;
 
        $kd->skip_ws;
        my $proto = parse_proto($kd)    or
-       croak "expecting prototype for action at:\n".$kd->line;
+       confess "expecting prototype for action at:\n".$kd->line;
 
        $kd->skip_ws;
        my $l = $kd->line;
@@ -173,7 +174,8 @@ sub mk_import {
                        };
                }
                else {
-                       *{$module_user."::$keyword"} = sub { };
+                       *{$module_user."::$keyword"} = sub { 
+                               $Keyword::__keyword_block_ret; }; 
                }
        };
 }
index 7dc1593..beb206d 100644 (file)
@@ -1,6 +1,7 @@
 package Keyword::Declare;
 use strict;
 use warnings;
+use Carp;
 use Devel::Declare;
 
 # maybe subclass Devel::Declare::Context::Simple?
@@ -20,14 +21,57 @@ sub offset {
        return ${$self->{offset}};
 }
 
+sub inc_offset {
+       my ($self, $offset) = @_;
+       if($offset) {
+               ${$self->{offset}} += $offset;
+       }
+       else {
+               ${$self->{offset}}++;
+       }
+       return ${$self->{offset}};
+}
 sub next_token {
        my ($self) = @_;
        ${$self->{offset}} += Devel::Declare::toke_move_past_token($self->offset);
 }
 
+sub skip_to {
+       my ($self, $name) = @_;
+       my $toke = "";
+       while ($toke ne $name) {
+               my $len = $self->scan_word(1);
+               my $l = $self->line;
+               $toke = substr($l, $self->offset, $len);
+               $self->offset($len + $self->offset);
+               $self->inc_offset;
+               confess "couldn't find '$name' on this line" if $toke and $toke =~ /\n/;
+       }
+       return $toke;
+}
+
+sub strip_to_char {
+       my ($self, $char) = @_;
+       my $str = "";
+       while ($str !~ /$char/) {
+               my $l = $self->line;
+               $str .= substr($l, $self->offset, 1);
+               substr($l, $self->offset, 1) = '';
+               $self->line($l);
+       }
+       return $str;
+}
+
+sub terminate {
+       my ($self) = shift;
+       my $l = $self->line;
+       substr($l, $self->offset, 1) = ';';
+       $self->line($l);
+}
+
 sub skip_ws {
        my ($self) = @_;
-       ${$self->{offset}} += Devel::Declare::toke_skipspace($self->offset);
+       ${$self->{offset}} +=   Devel::Declare::toke_skipspace($self->offset);
 }
 
 sub scan_word {
index b76ff69..668175e 100644 (file)
@@ -3,6 +3,7 @@ use strict;
 use warnings;
 use Carp;
 use Keyword::Declare;
+use Data::Dumper;
 
 our %BUILTIN = (
        proto => 'Keyword::Parse::Proto::parse_proto',
@@ -12,8 +13,9 @@ our %BUILTIN = (
 
 sub new {
        my ($class, $self) = @_;
-       $self->{proto} or croak 'no proto provided';
-       $self->{module} or croak 'no module provided';
+       $self->{proto} or confess 'no proto provided';
+       $self->{module} or confess 'no module provided';
+       $self->{keyword} or confess 'no keyword provided';
        bless($self,$class);    
 }
 
@@ -25,14 +27,13 @@ sub build {
        
        return sub {
                my @arg;
-               $self->declare->next_token;
-               $self->declare->skip_ws;
+               $self->declare->skip_to($self->{keyword});
 
                #call each parse routine and action
                for my $pa (@{$self->{plist}}) {
                        push @arg, $self->exec($pa);    
                }
-
+               
                &{$Keyword::__keyword_block}(@arg);
        };
 }
@@ -48,7 +49,7 @@ sub exec {
        my ($self, $pa) = @_;
        my $match = &{$pa->{parse}}($self->declare); 
        $self->declare->skip_ws;
-       croak "failed to parse $pa->{name}" unless $match or $pa->{opt};
+       confess "failed to parse $pa->{name}" unless $match or $pa->{opt};
        return &{$pa->{action}}($match);
 }
 
@@ -58,7 +59,7 @@ sub _build_ident_list {
        my @i = split /\,/, $self->{proto};
        for my $ident (@i){
                $ident =~ /^[a-z]{1}\w+[\?]?$/i or 
-               croak "bad identifier '$ident' in prototype.";
+               confess "bad identifier '$ident' in prototype.";
                my $opt;
                $ident =~ s/\?//g and $opt = 1 if $ident =~ /\?$/;
                push @{$self->{plist}}, {name=>lc($ident),optional=>$opt};