merge 8.7

1 files changed, 165 insertions, 27 deletions

diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 76eaef5..fe433e4 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd;
 static Tcl_ObjCmdProc InfoObjectDefnCmd;
 static Tcl_ObjCmdProc InfoObjectFiltersCmd;
 static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIdCmd;
 static Tcl_ObjCmdProc InfoObjectIsACmd;
 static Tcl_ObjCmdProc InfoObjectMethodsCmd;
 static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
@@ -50,6 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd;
 static const EnsembleImplMap infoObjectCmds[] = {
     {"call",	   InfoObjectCallCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
     {"class",	   InfoObjectClassCmd,	    TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+    {"creationid", InfoObjectIdCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"definition", InfoObjectDefnCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
     {"filters",	   InfoObjectFiltersCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"forward",	   InfoObjectForwardCmd,    TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -58,7 +60,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
     {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
     {"mixins",	   InfoObjectMixinsCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
-    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1ArgCmd, NULL, NULL, 0},
+    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {"vars",	   InfoObjectVarsCmd,	    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
@@ -80,7 +82,7 @@ static const EnsembleImplMap infoClassCmds[] = {
     {"mixins",	     InfoClassMixinsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
-    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
+    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
@@ -517,15 +519,22 @@ InfoObjectMethodsCmd(
     Tcl_Obj *const objv[])
 {
     Object *oPtr;
-    int flag = PUBLIC_METHOD, recurse = 0;
+    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
     FOREACH_HASH_DECLS;
     Tcl_Obj *namePtr, *resultObj;
     Method *mPtr;
     static const char *const options[] = {
-	"-all", "-localprivate", "-private", NULL
+	"-all", "-localprivate", "-private", "-scope", NULL
     };
     enum Options {
-	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+    };
+    static const char *const scopes[] = {
+	"private", "public", "unexported"
+    };
+    enum Scopes {
+	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
+	SCOPE_LOCALPRIVATE
     };
 
     if (objc < 2) {
@@ -554,14 +563,45 @@ InfoObjectMethodsCmd(
 	    case OPT_PRIVATE:
 		flag = 0;
 		break;
+	    case OPT_SCOPE:
+		if (++i >= objc) {
+		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			    "missing option for -scope"));
+		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+			    NULL);
+		    return TCL_ERROR;
+		}
+		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+			&scope) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		break;
 	    }
 	}
     }
+    if (scope != -1) {
+	recurse = 0;
+	switch (scope) {
+	case SCOPE_PRIVATE:
+	    flag = TRUE_PRIVATE_METHOD;
+	    break;
+	case SCOPE_PUBLIC:
+	    flag = PUBLIC_METHOD;
+	    break;
+	case SCOPE_LOCALPRIVATE:
+	    flag = PRIVATE_METHOD;
+	    break;
+	case SCOPE_UNEXPORTED:
+	    flag = 0;
+	    break;
+	}
+    }
 
     resultObj = Tcl_NewObj();
     if (recurse) {
 	const char **names;
-	int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
+		&names);
 
 	for (i=0 ; i<numNames ; i++) {
 	    Tcl_ListObjAppendElement(NULL, resultObj,
@@ -572,7 +612,7 @@ InfoObjectMethodsCmd(
 	}
     } else if (oPtr->methodsPtr) {
 	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
-	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
 		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
 	    }
 	}
@@ -684,6 +724,38 @@ InfoObjectMixinsCmd(
 /*
  * ----------------------------------------------------------------------
  *
+ * InfoObjectIdCmd --
+ *
+ *	Implements [info object creationid $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIdCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * InfoObjectNsCmd --
  *
  *	Implements [info object namespace $objName]
@@ -719,7 +791,7 @@ InfoObjectNsCmd(
  *
  * InfoObjectVariablesCmd --
  *
- *	Implements [info object variables $objName]
+ *	Implements [info object variables $objName ?-private?]
  *
  * ----------------------------------------------------------------------
  */
@@ -732,21 +804,37 @@ InfoObjectVariablesCmd(
     Tcl_Obj *const objv[])
 {
     Object *oPtr;
-    Tcl_Obj *variableObj, *resultObj;
-    int i;
+    Tcl_Obj *resultObj;
+    int i, private = 0;
 
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "objName");
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
 	return TCL_ERROR;
     }
+    if (objc == 3) {
+	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+	    return TCL_ERROR;
+	}
+	private = 1;
+    }
     oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
     if (oPtr == NULL) {
 	return TCL_ERROR;
     }
 
     resultObj = Tcl_NewObj();
-    FOREACH(variableObj, oPtr->variables) {
-	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    if (private) {
+	PrivateVariableMapping *privatePtr;
+
+	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+	}
+    } else {
+	Tcl_Obj *variableObj;
+
+	FOREACH(variableObj, oPtr->variables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+	}
     }
     Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
@@ -1128,7 +1216,7 @@ InfoClassInstancesCmd(
  *
  * InfoClassMethodsCmd --
  *
- *	Implements [info class methods $clsName ?-private?]
+ *	Implements [info class methods $clsName ?options...?]
  *
  * ----------------------------------------------------------------------
  */
@@ -1140,15 +1228,21 @@ InfoClassMethodsCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    int flag = PUBLIC_METHOD, recurse = 0;
+    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
     Tcl_Obj *namePtr, *resultObj;
     Method *mPtr;
     Class *clsPtr;
     static const char *const options[] = {
-	"-all", "-localprivate", "-private", NULL
+	"-all", "-localprivate", "-private", "-scope", NULL
     };
     enum Options {
-	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+    };
+    static const char *const scopes[] = {
+	"private", "public", "unexported"
+    };
+    enum Scopes {
+	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
     };
 
     if (objc < 2) {
@@ -1177,9 +1271,36 @@ InfoClassMethodsCmd(
 	    case OPT_PRIVATE:
 		flag = 0;
 		break;
+	    case OPT_SCOPE:
+		if (++i >= objc) {
+		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			    "missing option for -scope"));
+		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+			    NULL);
+		    return TCL_ERROR;
+		}
+		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+			&scope) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		break;
 	    }
 	}
     }
+    if (scope != -1) {
+	recurse = 0;
+	switch (scope) {
+	case SCOPE_PRIVATE:
+	    flag = TRUE_PRIVATE_METHOD;
+	    break;
+	case SCOPE_PUBLIC:
+	    flag = PUBLIC_METHOD;
+	    break;
+	case SCOPE_UNEXPORTED:
+	    flag = 0;
+	    break;
+	}
+    }
 
     resultObj = Tcl_NewObj();
     if (recurse) {
@@ -1197,7 +1318,7 @@ InfoClassMethodsCmd(
 	FOREACH_HASH_DECLS;
 
 	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
-	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
 		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
 	    }
 	}
@@ -1399,7 +1520,7 @@ InfoClassSupersCmd(
  *
  * InfoClassVariablesCmd --
  *
- *	Implements [info class variables $clsName]
+ *	Implements [info class variables $clsName ?-private?]
  *
  * ----------------------------------------------------------------------
  */
@@ -1412,21 +1533,37 @@ InfoClassVariablesCmd(
     Tcl_Obj *const objv[])
 {
     Class *clsPtr;
-    Tcl_Obj *variableObj, *resultObj;
-    int i;
+    Tcl_Obj *resultObj;
+    int i, private = 0;
 
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "className");
+    if (objc != 2 && objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
 	return TCL_ERROR;
     }
+    if (objc == 3) {
+	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+	    return TCL_ERROR;
+	}
+	private = 1;
+    }
     clsPtr = GetClassFromObj(interp, objv[1]);
     if (clsPtr == NULL) {
 	return TCL_ERROR;
     }
 
     resultObj = Tcl_NewObj();
-    FOREACH(variableObj, clsPtr->variables) {
-	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    if (private) {
+	PrivateVariableMapping *privatePtr;
+
+	FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+	}
+    } else {
+	Tcl_Obj *variableObj;
+
+	FOREACH(variableObj, clsPtr->variables) {
+	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+	}
     }
     Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
@@ -1465,7 +1602,8 @@ InfoObjectCallCmd(
      * Get the call context and render its call chain.
      */
 
-    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
+    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
+	    NULL);
     if (contextPtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"cannot construct any call chain", -1));