Implement TIP 519

3 files changed, 133 insertions, 17 deletions

diff --git a/doc/define.n b/doc/define.n
index 883d5fa..8cab8d3 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -140,7 +140,7 @@ where the current namespace is the instance namespace of the class object
 itself. This is useful for setting up, e.g., class-scoped variables.
 .VE TIP478
 .TP
-\fBmethod\fI name argList bodyScript\fR
+\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR
 .
 This creates or updates a method that is implemented as a procedure-like
 script. The name of the method is \fIname\fR, the formal arguments to the
@@ -150,12 +150,17 @@ the body of the method is evaluated, the current namespace of the method will
 be a namespace that is unique to the current object. The method will be
 exported if \fIname\fR starts with a lower-case letter, and non-exported
 otherwise; this behavior can be overridden via \fBexport\fR and
-\fBunexport\fR.
+\fBunexport\fR
+.VS  TIP519
+or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the
+optional parameter \fIoption\fR.
+.VE TIP519
 .RS
 .PP
 .VS TIP500
 If in a private definition context (see the \fBprivate\fR definition command,
-below), this command creates private procedure-like methods.
+below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command
+creates private procedure-like methods.
 .VE TIP500
 .RE
 .TP
@@ -321,7 +326,7 @@ below), this command creates private forwarded methods.
 .VE TIP500
 .RE
 .TP
-\fBmethod\fI name argList bodyScript\fR
+\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR
 .
 This creates, updates or deletes an object method. The name of the method is
 \fIname\fR, the formal arguments to the method (defined using the same format
@@ -329,12 +334,18 @@ as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
 method will be \fIbodyScript\fR. When the body of the method is evaluated, the
 current namespace of the method will be a namespace that is unique to the
 object. The method will be exported if \fIname\fR starts with a lower-case
-letter, and non-exported otherwise.
+letter, and non-exported otherwise;
+.VS  TIP519
+this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or
+\fB\-unexport\fR in the optional parameter \fIoption\fR, or via the
+\fBexport\fR and \fBunexport\fR definitions.
+.VE TIP519
 .RS
 .PP
 .VS TIP500
 If in a private definition context (see the \fBprivate\fR definition command,
-below), this command creates private procedure-like methods.
+below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command
+creates private procedure-like methods.
 .VE TIP500
 .RE
 .TP
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 3e8dd11..a00d473 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -1833,15 +1833,31 @@ TclOODefineMethodObjCmd(
     int objc,
     Tcl_Obj *const *objv)
 {
+    /*
+     * Table of export modes for methods and their corresponding enum.
+     */
+
+    static const char *const exportModes[] = {
+	"-export",
+	"-private",
+	"-unexport",
+	NULL
+    };
+    enum ExportMode {
+	MODE_EXPORT,
+	MODE_PRIVATE,
+	MODE_UNEXPORT
+    } exportMode;
+
     int isInstanceMethod = (clientData != NULL);
     Object *oPtr;
     int isPublic;
 
-    if (objc != 4) {
-	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+    if (objc < 4 || objc > 5) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body");
 	return TCL_ERROR;
     }
-
+    
     oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     if (oPtr == NULL) {
 	return TCL_ERROR;
@@ -1852,10 +1868,29 @@ TclOODefineMethodObjCmd(
 	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
-    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
-	    ? PUBLIC_METHOD : 0;
-    if (IsPrivateDefine(interp)) {
-	isPublic = TRUE_PRIVATE_METHOD;
+    if (objc == 5) {
+	if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
+		0, (int *) &exportMode) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	switch (exportMode) {
+	case MODE_EXPORT:
+	    isPublic = PUBLIC_METHOD;
+	    break;
+	case MODE_PRIVATE:
+	    isPublic = TRUE_PRIVATE_METHOD;
+	    break;
+	case MODE_UNEXPORT:
+	    isPublic = 0;
+	    break;
+	}
+    } else {
+	if (IsPrivateDefine(interp)) {
+	    isPublic = TRUE_PRIVATE_METHOD;
+	} else {
+	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+		    ? PUBLIC_METHOD : 0;
+	}
     }
 
     /*
@@ -1864,12 +1899,12 @@ TclOODefineMethodObjCmd(
 
     if (isInstanceMethod) {
 	if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
-		objv[2], objv[3], NULL) == NULL) {
+		objv[objc - 2], objv[objc - 1], NULL) == NULL) {
 	    return TCL_ERROR;
 	}
     } else {
 	if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
-		objv[2], objv[3], NULL) == NULL) {
+		objv[objc - 2], objv[objc - 1], NULL) == NULL) {
 	    return TCL_ERROR;
 	}
     }
diff --git a/tests/oo.test b/tests/oo.test
index 37c4495..3974a76 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -129,11 +129,11 @@ test oo-1.1 {basic test of OO functionality: no classes} {
 } {::foo {} a b c 3 {} {}}
 test oo-1.2 {basic test of OO functionality: no classes} -body {
     oo::define oo::object method missingArgs
-} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
+} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\""
 test oo-1.3 {basic test of OO functionality: no classes} {
     catch {oo::define oo::object method missingArgs}
     set errorInfo
-} "wrong # args: should be \"oo::define oo::object method name args body\"
+} "wrong # args: should be \"oo::define oo::object method name ?option? args body\"
     while executing
 \"oo::define oo::object method missingArgs\""
 test oo-1.4 {basic test of OO functionality} -body {
@@ -778,6 +778,76 @@ test oo-4.6 {export creates proper method entries} -setup {
 } -cleanup {
     testClass destroy
 } -result ok
+test oo-4.7 {basic test of OO functionality: method -export flag} -setup {
+    set o [oo::object new]
+    unset -nocomplain result
+} -body {
+    oo::objdefine $o {
+	method Foo {} {
+	    lappend ::result Foo
+	    return foo
+	}
+	method Bar -export {} {
+	    lappend ::result Bar
+	    return bar
+	}
+    }
+    lappend result [catch {$o Foo} msg] $msg
+    lappend result [$o Bar]
+} -cleanup {
+    $o destroy
+} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar}
+test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup {
+    set o [oo::object new]
+    unset -nocomplain result
+} -body {
+    oo::objdefine $o {
+	method foo {} {
+	    lappend ::result foo
+	    return Foo
+	}
+	method bar -unexport {} {
+	    lappend ::result bar
+	    return Bar
+	}
+    }
+    lappend result [$o foo]
+    lappend result [catch {$o bar} msg] $msg
+} -cleanup {
+    $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}}
+test oo-4.9 {basic test of OO functionality: method -private flag} -setup {
+    set o [oo::object new]
+    unset -nocomplain result
+} -body {
+    oo::objdefine $o {
+	method foo {} {
+	    lappend ::result foo
+	    return Foo
+	}
+	method bar -private {} {
+	    lappend ::result bar
+	    return Bar
+	}
+	export eval
+	method gorp {} {
+	    my bar
+	}
+    }
+    lappend result [$o foo]
+    lappend result [catch {$o bar} msg] $msg
+    lappend result [catch {$o eval my bar} msg] $msg
+    lappend result [$o gorp]
+} -cleanup {
+    $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar}
+test oo-4.10 {basic test of OO functionality: method flag parsing} -setup {
+    set o [oo::object new]
+} -body {
+    oo::objdefine $o method foo -gorp xyz {return Foo}
+} -returnCodes error -cleanup {
+    $o destroy
+} -result {bad export flag "-gorp": must be -export, -private, or -unexport}
 
 test oo-5.1 {OO: manipulation of classes as objects} -setup {
     set obj [oo::object new]