From 0a1f66b1c502875f43acf2671f8d7770a830e4cc Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Sun, 2 May 2004 20:49:55 +0000
Subject: 	* generic/tclProc.c (TclObjInvokeProc): 	*
 tests/proc.test (proc-3.6): fix for bad quoting of multi-word 	proc names in
 error messages [Bug 942757]

---
 ChangeLog         |  6 ++++++
 generic/tclProc.c | 26 ++++++++++++++++++++++----
 tests/proc.test   |  7 ++++++-
 3 files changed, 34 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d50a32f..5dc9c96 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2004-05-02  Miguel Sofer <msofer@users.sf.net>
+
+	* generic/tclProc.c (TclObjInvokeProc):
+	* tests/proc.test (proc-3.6): fix for bad quoting of multi-word
+	proc names in error messages [Bug 942757]
+
 2004-04-30  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* doc/glob.n, doc/incr.n, doc/set.n:	More examples.
diff --git a/generic/tclProc.c b/generic/tclProc.c
index e1a4116..d99266e 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.50 2004/03/09 12:59:05 vincentdarley Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.51 2004/05/02 20:49:56 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -909,7 +909,6 @@ TclObjInterpProc(clientData, interp, objc, objv)
     register CompiledLocal *localPtr;
     char *procName;
     int nameLen, localCt, numArgs, argCt, i, result;
-    Tcl_Obj *objResult = Tcl_GetObjResult(interp);
 
     /*
      * This procedure generates an array "compiledLocals" that holds the
@@ -1036,13 +1035,32 @@ TclObjInterpProc(clientData, interp, objc, objv)
 	localPtr = localPtr->nextPtr;
     }
     if (argCt > 0) {
+	Tcl_Obj *objResult;
+	int len, flags;
+
 	incorrectArgs:
 	/*
 	 * Build up equivalent to Tcl_WrongNumArgs message for proc
 	 */
+
 	Tcl_ResetResult(interp);
-	Tcl_AppendStringsToObj(objResult,
-		"wrong # args: should be \"", procName, (char *) NULL);
+	objResult = Tcl_GetObjResult(interp);
+	Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
+
+	/*
+	 * Quote the proc name if it contains spaces (Bug 942757).
+	 */
+	
+	len = Tcl_ScanCountedElement(procName, nameLen, &flags);
+	if (len != nameLen) {
+	    char *procName1 = ckalloc((unsigned) len);
+	    len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
+	    Tcl_AppendToObj(objResult, procName1, len);
+	    ckfree(procName1);
+	} else {
+	    Tcl_AppendToObj(objResult, procName, len);
+	}
+
 	localPtr = procPtr->firstLocalPtr;
 	for (i = 1;  i <= numArgs;  i++) {
 	    if (localPtr->defValuePtr != NULL) {
diff --git a/tests/proc.test b/tests/proc.test
index 662d56f..ef5f3c4 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: proc.test,v 1.13 2004/03/30 16:22:22 msofer Exp $
+# RCS: @(#) $Id: proc.test,v 1.14 2004/05/02 20:49:56 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -166,6 +166,11 @@ test proc-3.5 {TclObjInterpProc, any old result is reset before appending error
     list [catch {p} msg] $msg
 } {1 {wrong # args: should be "p x"}}
 
+test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
+    proc {a b  c} {x} {info commands 3m}
+    list [catch {{a b  c}} msg] $msg
+} {1 {wrong # args: should be "{a b  c} x"}}
+
 catch {namespace delete {expand}[namespace children :: test_ns_*]}
 catch {rename p ""}
 catch {rename {} ""}
-- 
cgit v0.12