From 9b417d4592f2b4b1640d0877d27345928e4210a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 23:41:32 +0000 Subject: Rebase on 8.7 --- doc/define.n | 17 +++++++++++++---- generic/tclOODefineCmds.c | 27 +++++++++++++++++++++------ tests/oo.test | 20 ++++++++++++++++++-- 3 files changed, 52 insertions(+), 12 deletions(-) diff --git a/doc/define.n b/doc/define.n index 883d5fa..4e99b9a 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,7 +150,11 @@ 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 or \fB\-unexport\fR in the optional parameter +\fIoption\fR. +.VE TIP519 .RS .PP .VS TIP500 @@ -321,7 +325,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,7 +333,12 @@ 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 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 diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b4ff283..c056c26 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1834,11 +1834,25 @@ TclOODefineMethodObjCmd( int isInstanceMethod = (clientData != NULL); Object *oPtr; int isPublic; + const char *exportMode = NULL; + size_t exportLen; - 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; } + + if (objc == 5) { + exportMode = TclGetStringFromObj(objv[2], &exportLen); + if (exportLen == 0 || + (strcmp(exportMode, "-export") && + strcmp(exportMode, "-unexport"))) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid export flag", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "INVALID_EXPORT_FLAG", NULL); + return TCL_ERROR; + } + } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { @@ -1850,8 +1864,9 @@ TclOODefineMethodObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") - ? PUBLIC_METHOD : 0; + isPublic = exportMode == NULL + ? Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0 + : exportMode[1] == 'e' ? PUBLIC_METHOD : 0; if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; } @@ -1862,12 +1877,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..4f5e65b 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,22 @@ test oo-4.6 {export creates proper method entries} -setup { } -cleanup { testClass destroy } -result ok +test oo-4.7 {basic test of OO functionality: -export flag} { + set o [oo::object new] + set result {} + oo::objdefine $o method Foo {} {lappend ::result Foo; return} + lappend result [catch {$o Foo} msg] $msg + oo::objdefine $o method Bar -export {} {lappend ::result Bar; return} + lappend result [$o Bar] [$o destroy] +} {1 {unknown method "Foo": must be destroy} Bar {} {}} +test oo-4.8 {basic test of OO functionality: -unexport flag} { + set o [oo::object new] + set result {} + oo::objdefine $o method foo {} {lappend ::result foo; return} + lappend result [$o foo] + oo::objdefine $o method bar -unexport {} {lappend ::result bar; return} + lappend result [catch {$o bar} msg] $msg [$o destroy] +} {foo {} 1 {unknown method "bar": must be destroy or foo} {}} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] -- cgit v0.12 From 775ce545d2f9d37cb91b7e251ab708db97dab440 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 21 Oct 2018 09:57:43 +0000 Subject: More tests. Better implementation. --- doc/define.n | 16 +++++----- generic/tclOODefineCmds.c | 57 +++++++++++++++++++++++----------- tests/oo.test | 78 +++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 114 insertions(+), 37 deletions(-) diff --git a/doc/define.n b/doc/define.n index 4e99b9a..8cab8d3 100644 --- a/doc/define.n +++ b/doc/define.n @@ -152,14 +152,15 @@ 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 .VS TIP519 -or by specifying \fB\-export\fR or \fB\-unexport\fR in the optional parameter -\fIoption\fR. +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 @@ -335,15 +336,16 @@ 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; .VS TIP519 -this can be overridden by specifying \fB\-export\fR or \fB\-unexport\fR in the -optional parameter \fIoption\fR, or via the \fBexport\fR and \fBunexport\fR -definitions. +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 c056c26..1062579 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1831,10 +1831,25 @@ 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; - const char *exportMode = NULL; size_t exportLen; if (objc < 4 || objc > 5) { @@ -1842,18 +1857,6 @@ TclOODefineMethodObjCmd( return TCL_ERROR; } - if (objc == 5) { - exportMode = TclGetStringFromObj(objv[2], &exportLen); - if (exportLen == 0 || - (strcmp(exportMode, "-export") && - strcmp(exportMode, "-unexport"))) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invalid export flag", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "INVALID_EXPORT_FLAG", NULL); - return TCL_ERROR; - } - } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; @@ -1864,11 +1867,29 @@ TclOODefineMethodObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - isPublic = exportMode == NULL - ? Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0 - : exportMode[1] == 'e' ? 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; + } } /* diff --git a/tests/oo.test b/tests/oo.test index 4f5e65b..3974a76 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -778,22 +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: -export flag} { +test oo-4.7 {basic test of OO functionality: method -export flag} -setup { set o [oo::object new] - set result {} - oo::objdefine $o method Foo {} {lappend ::result Foo; return} + 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 - oo::objdefine $o method Bar -export {} {lappend ::result Bar; return} - lappend result [$o Bar] [$o destroy] -} {1 {unknown method "Foo": must be destroy} Bar {} {}} -test oo-4.8 {basic test of OO functionality: -unexport flag} { + 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] - set result {} - oo::objdefine $o method foo {} {lappend ::result foo; return} + 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] - oo::objdefine $o method bar -unexport {} {lappend ::result bar; return} - lappend result [catch {$o bar} msg] $msg [$o destroy] -} {foo {} 1 {unknown method "bar": must be destroy or 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 , 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] -- cgit v0.12 From 37c458acb73d94fa74e19dd036a751a54b5756e1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 21 Oct 2018 10:01:04 +0000 Subject: Remove unused variable --- generic/tclOODefineCmds.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 1062579..9455dd6 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1850,7 +1850,6 @@ TclOODefineMethodObjCmd( int isInstanceMethod = (clientData != NULL); Object *oPtr; int isPublic; - size_t exportLen; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); -- cgit v0.12