Make [info object methods] and [info class methods] work right.

4 files changed, 52 insertions, 4 deletions

diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 5fd0c2a..bc84da0 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -44,18 +44,25 @@ struct ChainBuilder {
 #define MIXIN_CONSISTENT(flags) \
     (((flags) & OBJECT_MIXIN) ||					\
 	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
+
 /*
- * Note that the flag bit PRIVATE_METHOD has a confusing name.
+ * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
+ * Itcl's special type of private.
  */
+
 #define IS_PUBLIC(mPtr)				\
     (((mPtr)->flags & PUBLIC_METHOD) != 0)
 #define IS_UNEXPORTED(mPtr)			\
+    (((mPtr)->flags & SCOPE_FLAGS) == 0)
+#define IS_ITCLPRIVATE(mPtr)				\
     (((mPtr)->flags & PRIVATE_METHOD) != 0)
 #define IS_PRIVATE(mPtr)			\
     (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
 #define WANT_PUBLIC(flags)			\
     (((flags) & PUBLIC_METHOD) != 0)
 #define WANT_UNEXPORTED(flags)			\
+    (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
+#define WANT_ITCLPRIVATE(flags)			\
     (((flags) & PRIVATE_METHOD) != 0)
 #define WANT_PRIVATE(flags)			\
     (((flags) & TRUE_PRIVATE_METHOD) != 0)
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index db490fb..fe433e4 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -533,7 +533,8 @@ InfoObjectMethodsCmd(
 	"private", "public", "unexported"
     };
     enum Scopes {
-	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
+	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
+	SCOPE_LOCALPRIVATE
     };
 
     if (objc < 2) {
@@ -587,6 +588,9 @@ InfoObjectMethodsCmd(
 	case SCOPE_PUBLIC:
 	    flag = PUBLIC_METHOD;
 	    break;
+	case SCOPE_LOCALPRIVATE:
+	    flag = PRIVATE_METHOD;
+	    break;
 	case SCOPE_UNEXPORTED:
 	    flag = 0;
 	    break;
@@ -608,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);
 	    }
 	}
@@ -1314,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);
 	    }
 	}
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index e81bbf9..a43ab76 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -407,6 +407,7 @@ typedef struct CallContext {
 				/* This is a private method only accessible
 				 * from other methods defined on this class
 				 * or instance. [TIP #500] */
+#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
 
 /*
  * Structure containing definition information about basic class methods.
diff --git a/tests/oo.test b/tests/oo.test
index 9aedaaf..9563b4f 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -4691,6 +4691,42 @@ test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setu
 } -cleanup {
     parent destroy
 } -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
+test oo-39.12 {TIP 500: private methods; introspection} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method chain {} {
+	    return [self call]
+	}
+	private method abc {} {}
+    }
+    oo::class create cls2 {
+	superclass cls
+	method chain2 {} {
+	    my chain
+	}
+	method chain3 {} {
+	    [self] chain
+	}
+	private method def {} {}
+	unexport chain3
+    }
+    cls create a
+    cls2 create b
+    oo::objdefine b {
+	private method ghi {} {}
+	method ABC {} {}
+	method foo {} {}
+    }
+    set scopes {public unexported private}
+    list a: [lmap s $scopes {info object methods a -scope $s}] \
+	b: [lmap s $scopes {info object methods b -scope $s}] \
+	cls: [lmap s $scopes {info class methods cls -scope $s}] \
+	cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
+} -cleanup {
+    parent destroy
+} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}
 
 cleanupTests
 return