Attachment "461635.patch" to
ticket [461635ffff]
added by
dgp
2003-03-21 12:05:12.
Index: doc/info.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/info.n,v
retrieving revision 1.8
diff -u -r1.8 info.n
--- doc/info.n 11 Jun 2002 13:22:35 -0000 1.8
+++ doc/info.n 21 Mar 2003 04:47:30 -0000
@@ -75,7 +75,14 @@
Returns \fB1\fR if the variable named \fIvarName\fR exists in the
current context (either as a global or local variable) and has been
defined by being given a value, returns \fB0\fR otherwise.
-.VS 8.4
+.VS 8.5
+.TP
+\fBinfo formalargs \fIprocname\fR
+Returns a list containing the formal argument specifiers to procedure
+\fIprocname\fR, in order. Each argument specifier is either the argument
+name, or a two-element list containing the argument name and its default
+value. \fIProcname\fR must be the name of a Tcl command procedure.
+.VE
.TP
\fBinfo functions \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the math
@@ -83,7 +90,6 @@
If \fIpattern\fR is specified, only those functions whose name matches
\fIpattern\fR are returned. Matching is determined using the same
rules as for \fBstring match\fR.
-.VE
.TP
\fBinfo globals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
Index: generic/tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v
retrieving revision 1.47
diff -u -r1.47 tclCmdIL.c
--- generic/tclCmdIL.c 27 Feb 2003 16:01:55 -0000 1.47
+++ generic/tclCmdIL.c 21 Mar 2003 04:48:02 -0000
@@ -112,6 +112,9 @@
static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+static int InfoFormalArgsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -401,17 +404,18 @@
{
static CONST char *subCmds[] = {
"args", "body", "cmdcount", "commands",
- "complete", "default", "exists", "functions", "globals",
- "hostname", "level", "library", "loaded",
- "locals", "nameofexecutable", "patchlevel", "procs",
- "script", "sharedlibextension", "tclversion", "vars",
- (char *) NULL};
+ "complete", "default", "exists", "formalargs", "functions",
+ "globals", "hostname", "level", "library", "loaded",
+ "locals", "nameofexecutable", "patchlevel", "procs",
+ "script", "sharedlibextension", "tclversion", "vars",
+ (char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
- ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
- IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
- ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
- IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
+ ICompleteIdx, IDefaultIdx, IExistsIdx, IFormalArgsIdx,
+ IFunctionsIdx, IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx,
+ ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx,
+ IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx,
+ IVarsIdx
};
int index, result;
@@ -451,6 +455,9 @@
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
+ case IFormalArgsIdx:
+ result = InfoFormalArgsCmd(clientData, interp, objc, objv);
+ break;
case IGlobalsIdx:
result = InfoGlobalsCmd(clientData, interp, objc, objv);
break;
@@ -962,6 +969,78 @@
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoFormalArgsCmd --
+ *
+ * Called to implement the "info formalargs" command that returns the
+ * formal argument list, including default values, for a procedure.
+ * Handles the following syntax:
+ *
+ * info formalargs procName
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoFormalArgsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *procName;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *listObjPtr, *sublistObjPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "procname");
+ return TCL_ERROR;
+ }
+
+ procName = Tcl_GetString(objv[2]);
+ procPtr = TclFindProc(iPtr, procName);
+ if (procPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "\"", procName, "\" isn't a procedure", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Build a return list containing the arguments, including defaults.
+ */
+
+ listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
+ localPtr = localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ if (localPtr->defValuePtr == NULL) {
+ Tcl_ListObjAppendElement(interp, listObjPtr,
+ Tcl_NewStringObj(localPtr->name, -1));
+ } else {
+ sublistObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ Tcl_ListObjAppendElement(interp, sublistObjPtr,
+ Tcl_NewStringObj(localPtr->name, -1));
+ Tcl_ListObjAppendElement(interp, sublistObjPtr,
+ Tcl_NewStringObj(Tcl_GetString(localPtr->defValuePtr), -1));
+ Tcl_ListObjAppendElement(interp, listObjPtr, sublistObjPtr);
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
}
Index: tests/info.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/info.test,v
retrieving revision 1.24
diff -u -r1.24 info.test
--- tests/info.test 1 Jul 2002 07:52:03 -0000 1.24
+++ tests/info.test 21 Mar 2003 04:48:11 -0000
@@ -628,16 +628,50 @@
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} {
list [catch {info gorp} msg] $msg
-} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, formalargs, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} {
list [catch {info c} msg] $msg
-} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, formalargs, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} {
list [catch {info l} msg] $msg
-} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, formalargs, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} {
list [catch {info s} msg] $msg
-} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, formalargs, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+
+# Tests 22.* : [info formalargs] from TIP 65
+#
+test info-22.1 {info formalargs option} {
+ proc t1 {a bbb c} {return foo}
+ info formalargs t1
+} {a bbb c}
+test info-22.2 {info formalargs option} {
+ proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
+ info formalargs t1
+} {{a default1} {bbb default2} {c default3} args}
+test info-22.3 {info formalargs option} {
+ proc t1 "" {return foo}
+ info formalargs t1
+} {}
+test info-22.4 {info formalargs option} {
+ catch {rename t1 {}}
+ list [catch {info formalargs t1} msg] $msg
+} {1 {"t1" isn't a procedure}}
+test info-22.5 {info formalargs option} {
+ list [catch {info formalargs set} msg] $msg
+} {1 {"set" isn't a procedure}}
+test info-22.6 {info formalargs option} {
+ proc t1 {a b} {set c 123; set d $c}
+ t1 1 2
+ info formalargs t1
+} {a b}
+test info-22.7 {info formalargs option} {
+ catch {namespace delete test_ns_info2}
+ namespace eval test_ns_info2 {
+ namespace import ::test_ns_info1::*
+ list [info formalargs p] [info formalargs q]
+ }
+} {x {{y 27} {z {}}}}
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
