From 27478ef49b56f42e1345466f8b3d084ac4ece370 Mon Sep 17 00:00:00 2001
From: Coke <will@coleda.com>
Date: Thu, 19 Aug 2010 01:10:16 -0400
Subject: [PATCH] instead of directly invoking .subs, go through a helper sub
 so we can do some extra handling.

---
 docs/todo.pod               |  5 -----
 src/Partcl/Actions.pm       |  4 ++--
 src/Partcl/commands/proc.pm |  1 +
 src/init.pm                 | 28 ++++++++++++++++++++++++++++
 t/cmd_catch.t               |  2 +-
 t/cmd_foreach.t             |  2 +-
 t/tcl_misc.t                |  8 +++++---
 t/tcl_namespace.t           |  4 ++--
 8 files changed, 40 insertions(+), 14 deletions(-)

diff --git a/docs/todo.pod b/docs/todo.pod
index 09100a5..41853e8 100644
--- a/docs/todo.pod
+++ b/docs/todo.pod
@@ -6,11 +6,6 @@ Document how to contribute to this version - ast, tcl, nqp ...
 
 =over 4
 
-=item [unknown] {t/tcl_misc.t; t/tcl_catch.t}
-
-Invoking a non-existant command should
-result in a tcl error, not a parrot error.
-
 =item [proc] {t/cmd_continue.t; t/cmd_break.t}
 
 User-defined procs should catch continue/break and complain about them, as
diff --git a/src/Partcl/Actions.pm b/src/Partcl/Actions.pm
index 3bb2350..b20fa7d 100644
--- a/src/Partcl/Actions.pm
+++ b/src/Partcl/Actions.pm
@@ -71,8 +71,8 @@ method script($/) {
 }
 
 method command($/) {
-    my $past := PAST::Op.new( :name(~$<word>[0].ast), :node($/) );
-    my $i := 1;
+    my $past := PAST::Op.new( :name('invoke'), :node($/) );
+    my $i := 0;
     my $n := +$<word>;
     while $i < $n {
         $past.push($<word>[$i].ast);
diff --git a/src/Partcl/commands/proc.pm b/src/Partcl/commands/proc.pm
index 8a0ebb4..5367549 100644
--- a/src/Partcl/commands/proc.pm
+++ b/src/Partcl/commands/proc.pm
@@ -63,6 +63,7 @@ our sub proc(*@args) {
     pir::setprop($thing, 'args', @argsInfo);
     pir::setprop($thing, 'defaults', %defaults);
     pir::setprop($thing, 'body', $body);
+
     '';
 }
 
diff --git a/src/init.pm b/src/init.pm
index 8af538b..181fe31 100644
--- a/src/init.pm
+++ b/src/init.pm
@@ -76,4 +76,32 @@ sub dumper($what, $label = 'VAR1') {
     &dumper($what, $label);
 }
 
+## wrapper sub for invoking tcl builtins - deals with unknown handling and
+## namespace desugaring; use a pointy block to avoid tampering with CONTROLs.
+
+INIT {
+    GLOBAL::invoke := -> $command, *@args {
+
+        ## Get our caller's namespace, do the lookup from there.
+        my $ns := Q:PIR {
+           $P1 = getinterp
+           %r = $P1['sub'; 1]
+        }.get_namespace();
+
+        my &command := $ns{$command};
+
+        ## if that didn't work, check in the root ns.
+        if pir::typeof(&command) eq "Undef" {
+            $ns := pir::get_hll_namespace__p();
+            &command := $ns{$command};
+        }
+
+        if pir::typeof(&command) eq "Undef" {
+            error("invalid command name \"$command\"");
+        }
+
+        &command(|@args);
+    }
+}
+
 # vim: expandtab shiftwidth=4 ft=perl6:
diff --git a/t/cmd_catch.t b/t/cmd_catch.t
index b3165d6..68323b4 100755
--- a/t/cmd_catch.t
+++ b/t/cmd_catch.t
@@ -52,7 +52,7 @@ eval_is {
 eval_is {
   set a [catch blorg var]
   list $a $var
-} {1 {invalid command name "blorg"}} {error, invalid command} {TODO NQPRX}
+} {1 {invalid command name "blorg"}} {error, invalid command}
 
 eval_is {catch} \
   {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} \
diff --git a/t/cmd_foreach.t b/t/cmd_foreach.t
index 8b58640..e871f6a 100755
--- a/t/cmd_foreach.t
+++ b/t/cmd_foreach.t
@@ -80,7 +80,7 @@ eval_is {
 
 eval_is {
   foreach name {a b c d} { aputs }
-} {invalid command name "aputs"} {inner exception} {TODO NQPRX}
+} {invalid command name "aputs"} {inner exception}
 
 is [
     set x {}
diff --git a/t/tcl_misc.t b/t/tcl_misc.t
index a75bf0a..5bdaa2e 100755
--- a/t/tcl_misc.t
+++ b/t/tcl_misc.t
@@ -1,7 +1,7 @@
 # Copyright (C) 2004-2007, The Parrot Foundation.
 
 source lib/test_more.tcl
-plan 27
+plan 26
 
 eval_is {
   set a Parsing
@@ -34,7 +34,7 @@ is [set x ";"] {;} {; doesn't end command in the middle of a string}
 eval_is {
   set a 2
   a
-} {invalid command name "a"} {variables can't be used as commands} {TODO NQPRX}
+} {invalid command name "a"} {variables can't be used as commands}
 
 eval_is {
 # commment
@@ -77,10 +77,12 @@ eval_is {
   set a [set b 1; set c 2]
 } 2 {subcommands with semicolons}
 
+if 0 { ## SKIP NQP-RX 
 eval_is {
   proc {} {} {return ok}
   {}
 } ok {empty proc name ok.} {TODO NQPRX}
+}
 
 eval_is {
   proc lreverse {} { return ok }
@@ -119,7 +121,7 @@ proc Default {{verify {boom}}} {
     [$verify]
 }
 Default
-} {invalid command name "boom"} {failure to find a dynamic command'} {TODO NQPRX}
+} {invalid command name "boom"} {failure to find a dynamic command'}
 
 set a 4; incr a
 is [lindex $a 0] 5 {can we convert integers into lists?}
diff --git a/t/tcl_namespace.t b/t/tcl_namespace.t
index edf8bc4..738ee99 100755
--- a/t/tcl_namespace.t
+++ b/t/tcl_namespace.t
@@ -14,12 +14,12 @@ is [{}] ok {command name, all colons}
 eval_is {
   :set c ok
 } {invalid command name ":set"}\
-{not enough colons, explicit global command} {TODO NQPRX}
+{not enough colons, explicit global command}
 
 eval_is {
   foo::bar
 } {invalid command name "foo::bar"} \
-{invalid ns command} {TODO NQPRX}
+{invalid ns command}
 
 eval_is {
   proc test {} {return ok1}