From 0ecdf938ca2b533273751a770d7c794e89faa9d3 Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Sun, 2 May 2004 21:07:16 +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 | 8 +++++++-
3 files changed, 35 insertions(+), 5 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 7d2b475..af3f478 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-23 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (Tcl_SetChannelOption): Fixed [SF Tcl Bug
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 1ec50f1..40c8ceb 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.44.2.1 2003/07/18 23:35:39 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.44.2.2 2004/05/02 21:07:16 msofer Exp $
*/
#include "tclInt.h"
@@ -910,7 +910,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
@@ -1037,13 +1036,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 ce07e88..222a31f 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.11 2002/12/11 21:29:52 dgp Exp $
+# RCS: @(#) $Id: proc.test,v 1.11.2.1 2004/05/02 21:07:16 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -166,9 +166,15 @@ 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 {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
+catch {rename {a b c} {}}
catch {unset msg}
if {[catch {package require procbodytest}]} {
--
cgit v0.12