initial sketch of shadow_sub and hashref-based callback API

git-svn-id: http://dev.catalyst.perl.org/repos/bast/trunk/Devel-Declare@4828 bd8105ee-0ff8-0310-8827-fb3f25b6796d

diff --git a/Declare.xs b/Declare.xs
index c03921f..be8f478 100644 (file)
--- a/Declare.xs
+++ b/Declare.xs
@@ -12,10 +12,18 @@
 # define Newx(v,n,t) New(0,v,n,t)
 #endif /* !Newx */
 
+#if 1
+#define DD_HAS_TRAITS
+#endif
+
 #if 0
 #define DD_DEBUG
 #endif
 
+#define DD_HANDLE_NAME 1
+#define DD_HANDLE_PROTO 2
+#define DD_HANDLE_PACKAGE 8
+
 #ifdef DD_DEBUG
 #define DD_DEBUG_S printf("Buffer: %s\n", s);
 #else
@@ -117,7 +125,7 @@ void dd_set_linestr(pTHX_ char* new_value) {
 }
 
 char* dd_get_lex_stuff(pTHX) {
-  return SvPVX(PL_lex_stuff);
+  return (PL_lex_stuff ? SvPVX(PL_lex_stuff) : "");
 }
 
 char* dd_clear_lex_stuff(pTHX) {
@@ -128,7 +136,7 @@ char* dd_get_curstash_name(pTHX) {
   return HvNAME(PL_curstash);
 }
 
-char* dd_move_past_token(pTHX_ char* s) {
+char* dd_move_past_token (pTHX_ char* s) {
 
   /*
    *   buffer will be at the beginning of the declarator, -unless- the
@@ -142,7 +150,7 @@ char* dd_move_past_token(pTHX_ char* s) {
   return s;
 }
 
-int dd_toke_move_past_token(pTHX_ int offset) {
+int dd_toke_move_past_token (pTHX_ int offset) {
   char* base_s = SvPVX(PL_linestr) + offset;
   char* s = dd_move_past_token(aTHX_ base_s);
   return s - base_s;
@@ -180,10 +188,22 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
   o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */
 
   if (in_declare) {
-    dSP;
-    PUSHMARK(SP);
-    call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD);
-    in_declare--;
+    cb_args[0] = NULL;
+#ifdef DD_DEBUG
+    printf("Deconstructing declare\n");
+    printf("PL_bufptr: %s\n", PL_bufptr);
+    printf("bufend at: %i\n", PL_bufend - PL_bufptr);
+    printf("linestr: %s\n", SvPVX(PL_linestr));
+    printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
+#endif
+    call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args);
+#ifdef DD_DEBUG
+    printf("PL_bufptr: %s\n", PL_bufptr);
+    printf("bufend at: %i\n", PL_bufend - PL_bufptr);
+    printf("linestr: %s\n", SvPVX(PL_linestr));
+    printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
+    printf("actual len: %i\n", strlen(PL_bufptr));
+#endif
     return o;
   }
 
@@ -195,11 +215,23 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
   if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
     return o; /* not lexing? */
 
+#ifdef DD_DEBUG
+  printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv));
+#endif
+
   dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv));
 
   if (dd_flags == -1)
     return o;
 
+#ifdef DD_DEBUG
+  printf("dd_flags are: %i\n", dd_flags);
+#endif
+
+#ifdef DD_DEBUG
+  printf("PL_tokenbuf: %s\n", PL_tokenbuf);
+#endif
+
   dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
 
   return o;

diff --git a/lib/Devel/Declare.pm b/lib/Devel/Declare.pm
index 558074c..72f1f40 100644 (file)
--- a/lib/Devel/Declare.pm
+++ b/lib/Devel/Declare.pm
@@ -51,8 +51,11 @@ sub setup_for {
     } elsif (ref($info) eq 'CODE') {
       $flags = DECLARE_NAME;
       $sub = $info;
+    } elsif (ref($info) eq 'HASH') {
+      $flags = 1;
+      $sub = $info;
     } else {
-      die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub";
+      die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
     }
     $declarators{$target}{$key} = $flags;
     $declarator_handlers{$target}{$key} = $sub;
@@ -77,20 +80,10 @@ sub init_declare {
   ($temp_name, $temp_save) = ([], []);
   if ($name) {
     $name = "${inpack}::${name}" unless $name =~ /::/;
-    push(@$temp_name, $name);
-    no strict 'refs';
-    push(@$temp_save, \&{$name});
-    no warnings 'redefine';
-    no warnings 'prototype';
-    *{$name} = $name_h;
+    shadow_sub($name, $name_h);
   }
   if ($XX_h) {
-    push(@$temp_name, "${inpack}::X");
-    no strict 'refs';
-    push(@$temp_save, \&{"${inpack}::X"});
-    no warnings 'redefine';
-    no warnings 'prototype';
-    *{"${inpack}::X"} = $XX_h;
+    shadow_sub("${inpack}::X", $XX_h);
   }
   if (defined wantarray) {
     return $extra_code || '0;';
@@ -99,6 +92,19 @@ sub init_declare {
   }
 }
 
+sub shadow_sub {
+  my ($name, $cr) = @_;
+  push(@$temp_name, $name);
+  no strict 'refs';
+  my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
+  push(@$temp_save, $pack->can($pname));
+  delete ${"${pack}::"}{$pname};
+  no warnings 'redefine';
+  no warnings 'prototype';
+  *{$name} = $cr;
+  set_in_declare(~~@{$temp_name||[]});
+}
+
 sub done_declare {
   no strict 'refs';
   my $name = shift(@{$temp_name||[]});
@@ -111,6 +117,7 @@ sub done_declare {
     no warnings 'prototype';
     *{"${temp_pack}::${name}"} = $saved;
   }
+  set_in_declare(~~@{$temp_name||[]});
 }
 
 sub build_sub_installer {
@@ -202,7 +209,6 @@ sub linestr_callback_rv2cv {
   my $pack = get_curstash_name();
   my $flags = $declarators{$pack}{$name};
   my ($found_name, $found_proto);
-  my $in_declare = 0;
   if ($flags & DECLARE_NAME) {
     $offset += toke_skipspace($offset);
     my $linestr = get_linestr();
@@ -213,7 +219,6 @@ sub linestr_callback_rv2cv {
     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
       $found_name = substr($linestr, $offset, $len);
       $offset += $len;
-      $in_declare++;
     }
   }
   if ($flags & DECLARE_PROTO) {
@@ -230,11 +235,9 @@ sub linestr_callback_rv2cv {
       substr($linestr, $offset, $length) = $replace;
       set_linestr($linestr);
       $offset += $length;
-      $in_declare++;
     }
   }
   my @args = ($pack, $name, $pack, $found_name, $found_proto);
-  set_in_declare($in_declare);
   $offset += toke_skipspace($offset);
   my $linestr = get_linestr();
   if (substr($linestr, $offset, 1) eq '{') {
@@ -267,8 +270,19 @@ sub linestr_callback_const {
 
 sub linestr_callback {
   my $type = shift;
-  my $meth = "linestr_callback_${type}";
-  __PACKAGE__->can($meth)->(@_);
+  my $name = $_[0];
+  my $pack = get_curstash_name();
+  my $handlers = $declarator_handlers{$pack}{$name};
+  if (ref $handlers eq 'CODE') {
+    my $meth = "linestr_callback_${type}";
+    __PACKAGE__->can($meth)->(@_);
+  } elsif (ref $handlers eq 'HASH') {
+    if ($handlers->{$type}) {
+      $handlers->{$type}->(@_);
+    }
+  } else {
+    die "PANIC: unknown thing in handlers for $pack $name: $handlers";
+  }
 }
 
 =head1 NAME