From ed3d330d86447c20841d39a0f0e0e57a2bad3ecd Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 27 Aug 2004 13:59:27 +0000
Subject: Make [namespace which] use newer option parsing code for more
 flexibility.

---
 ChangeLog            |  1 +
 generic/tclNamesp.c  | 48 +++++++++++++++++++++---------------------------
 tests/namespace.test | 10 +++++-----
 3 files changed, 27 insertions(+), 32 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7f14a65..2328c8c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,6 +3,7 @@
 	* generic/tclNamesp.c (FindEnsemble): Factor out the code to
 	convert a command name into an ensemble configuration and add
 	support for ignoring [namespace import] link chains. [Bug 1017022]
+	(NamespaceWhichCmd): Rework to use newer option parsing API.
 
 2004-08-27  Daniel Steffen  <das@users.sourceforge.net>
 
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 3db8543..9d88b82 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -21,7 +21,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.47 2004/08/27 11:04:26 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.48 2004/08/27 13:59:28 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -3851,39 +3851,33 @@ NamespaceWhichCmd(dummy, interp, objc, objv)
     int objc;                           /* Number of arguments. */
     Tcl_Obj *CONST objv[];              /* Argument objects. */
 {
-    int argIndex, lookup;
+    static CONST char *opts[] = {
+	"-command", "-variable", NULL
+    };
+    int lookupType = 0;
 
-    if (objc < 3) {
-        badArgs:
-        Tcl_WrongNumArgs(interp, 2, objv,
-	        "?-command? ?-variable? name");
+    if (objc < 3 || objc > 4) {
+      badArgs:
+        Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name");
         return TCL_ERROR;
-    }
-
-    /*
-     * Look for a flag controlling the lookup.
-     */
+    } else if (objc == 4) {
+	/*
+	 * Look for a flag controlling the lookup.
+	 */
 
-    argIndex = 2;
-    lookup = 0;			/* assume command lookup by default */
-    arg = TclGetString(objv[2]);
-    if (*arg == '-') {
-	if (strncmp(arg, "-command", 8) == 0) {
-	    lookup = 0;
-	} else if (strncmp(arg, "-variable", 9) == 0) {
-	    lookup = 1;
-	} else {
+	if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
+		&lookupType) != TCL_OK) {
+	    /*
+	     * Preserve old style of error message!
+	     */
+	    Tcl_ResetResult(interp);
 	    goto badArgs;
 	}
-	argIndex = 3;
-    }
-    if (objc != (argIndex + 1)) {
-	goto badArgs;
     }
 
-    switch (lookup) {
+    switch (lookupType) {
     case 0: {			/* -command */
-	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]);
+	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);
         if (cmd == (Tcl_Command) NULL) {	
             return TCL_OK;	/* cmd not found, just return (no error) */
         }
@@ -3892,7 +3886,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv)
     }
     case 1: {			/* -variable */
 	Tcl_Var var = Tcl_FindNamespaceVar(interp,
-		TclGetString(objv[argIndex]), NULL, /*flags*/ 0);
+		TclGetString(objv[objc-1]), NULL, /*flags*/ 0);
         if (var != (Tcl_Var) NULL) {
             Tcl_GetVariableFullName(interp, var, Tcl_GetObjResult(interp));
         }
diff --git a/tests/namespace.test b/tests/namespace.test
index 49ba1e9..f49c09b 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: namespace.test,v 1.33 2004/08/27 09:18:15 dkf Exp $
+# RCS: @(#) $Id: namespace.test,v 1.34 2004/08/27 13:59:29 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -1019,11 +1019,11 @@ test namespace-34.1 {NamespaceWhichCmd, bad args} {
     list [catch {namespace which} msg] $msg
 } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
 test namespace-34.2 {NamespaceWhichCmd, bad args} {
-    list [catch {namespace which -fred} msg] $msg
-} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
-test namespace-34.3 {NamespaceWhichCmd, bad args} {
-    list [catch {namespace which -command} msg] $msg
+    list [catch {namespace which -fred x} msg] $msg
 } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
+test namespace-34.3 {NamespaceWhichCmd, single arg is always command name} {
+    namespace which -command
+} {}
 test namespace-34.4 {NamespaceWhichCmd, bad args} {
     list [catch {namespace which a b} msg] $msg
 } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
-- 
cgit v0.12