Tcl Source Code

Artifact 6aa951bf8a3906a5fc760cc51562984082c8a5ee:

Attachment "tclCmdIL.diff" to ticket [461635ffff] added by glennjnn 2001-09-15 02:21:53.

---

*** generic/tclCmdIL.c~	Tue Apr  3 18:54:36 2001
--- generic/tclCmdIL.c	Fri Sep 14 15:10:57 2001
***************
*** 102,107 ****
--- 102,110 ----
  static int		InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
  			    Tcl_Interp *interp, int objc,
  			    Tcl_Obj *CONST objv[]));
+ static int		InfoFullArgsCmd _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[]));
***************
*** 364,378 ****
      Tcl_Obj *CONST objv[];	/* Argument objects. */
  {
      static char *subCmds[] = {
!             "args", "body", "cmdcount", "commands",
! 	     "complete", "default", "exists", "globals",
  	     "hostname", "level", "library", "loaded",
  	     "locals", "nameofexecutable", "patchlevel", "procs",
  	     "script", "sharedlibextension", "tclversion", "vars",
  	     (char *) NULL};
      enum ISubCmdIdx {
  	    IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
! 	    ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
  	    IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
  	    ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
  	    IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
--- 367,381 ----
      Tcl_Obj *CONST objv[];	/* Argument objects. */
  {
      static char *subCmds[] = {
! 	    "args", "body", "cmdcount", "commands",
! 	     "complete", "default", "exists", "fullargs", "globals",
  	     "hostname", "level", "library", "loaded",
  	     "locals", "nameofexecutable", "patchlevel", "procs",
  	     "script", "sharedlibextension", "tclversion", "vars",
  	     (char *) NULL};
      enum ISubCmdIdx {
  	    IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
! 	    ICompleteIdx, IDefaultIdx, IExistsIdx, IFullArgsIdx, IGlobalsIdx,
  	    IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
  	    ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
  	    IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
***************
*** 412,417 ****
--- 415,423 ----
  	case IExistsIdx:
  	    result = InfoExistsCmd(clientData, interp, objc, objv);
  	    break;
+ 	case IFullArgsIdx:
+ 	    result = InfoFullArgsCmd(clientData, interp, objc, objv);
+ 	    break;
          case IGlobalsIdx:
  	    result = InfoGlobalsCmd(clientData, interp, objc, objv);
  	    break;
***************
*** 921,926 ****
--- 927,1004 ----
      } else {
          Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
      }
+     return TCL_OK;
+ }
+ 
+ /*
+  *----------------------------------------------------------------------
+  *
+  * InfoFullArgsCmd --
+  *
+  *      Called to implement the "info fullargs" command that returns the
+  *      formal argument list, including default values, for a procedure.
+  *      Handles the following syntax:
+  *
+  *          info fullargs 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
+ InfoFullArgsCmd(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;
  }