From 1f91c778bb2a0d9b3e67c7e6e55d46fa91311b4e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Jun 2018 15:42:58 +0000 Subject: Split scripted parts of TclOO into their own file. --- generic/tclOO.c | 66 +++++---------------------------------- generic/tclOOScript.h | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 2 +- 3 files changed, 94 insertions(+), 59 deletions(-) create mode 100644 generic/tclOOScript.h diff --git a/generic/tclOO.c b/generic/tclOO.c index 6aa03fa..7f609b2 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -152,65 +152,10 @@ static const char *initScript = /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The scripted part of the definitions of slots. + * The scripted part of the definitions of TclOO. */ -static const char *slotScript = -"::oo::define ::oo::Slot {\n" -" method Get {} {error unimplemented}\n" -" method Set list {error unimplemented}\n" -" method -set args {\n" -" uplevel 1 [list [namespace which my] Set $args]\n" -" }\n" -" method -append args {\n" -" uplevel 1 [list [namespace which my] Set [list" -" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" -" }\n" -" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" -" forward --default-operation my -append\n" -" method unknown {args} {\n" -" set def --default-operation\n" -" if {[llength $args] == 0} {\n" -" return [uplevel 1 [list [namespace which my] $def]]\n" -" } elseif {![string match -* [lindex $args 0]]} {\n" -" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" -" }\n" -" next {*}$args\n" -" }\n" -" export -set -append -clear\n" -" unexport unknown destroy\n" -"}\n" -"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" -"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; - -/* - * The body of the method of oo::object. - */ - -static const char *clonedBody = -"foreach p [info procs [info object namespace $originObject]::*] {" -" set args [info args $p];" -" set idx -1;" -" foreach a $args {" -" lset args [incr idx] " -" [if {[info default $p $a d]} {list $a $d} {list $a}]" -" };" -" set b [info body $p];" -" set p [namespace tail $p];" -" proc $p $args $b;" -"};" -"foreach v [info vars [info object namespace $originObject]::*] {" -" upvar 0 $v vOrigin;" -" namespace upvar [namespace current] [namespace tail $v] vNew;" -" if {[info exists vOrigin]} {" -" if {[array exists vOrigin]} {" -" array set vNew [array get vOrigin];" -" } else {" -" set vNew $vOrigin;" -" }" -" }" -"}"; +#include "tclOOScript.h" /* * The actual definition of the variable holding the TclOO stub table. @@ -491,7 +436,12 @@ InitFoundation( if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } - return Tcl_EvalEx(interp, slotScript, -1, 0); + + /* + * Evaluate the remaining definitions, which are a compiled-in Tcl script. + */ + + return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); } /* diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h new file mode 100644 index 0000000..51a8a56 --- /dev/null +++ b/generic/tclOOScript.h @@ -0,0 +1,85 @@ +/* + * tclOOScript.h -- + * + * This file contains support scripts for TclOO. They are defined here so + * that the code can be definitely run even in safe interpreters; TclOO's + * core setup is safe. + * + * Copyright (c) 2012-2018 by Donal K. Fellows + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_OO_SCRIPT_H +#define TCL_OO_SCRIPT_H + +/* + * The scripted part of the definitions of TclOO. + */ + +static const char *tclOOSetupScript = +"::oo::define ::oo::Slot {\n" +" method Get {} {return -code error unimplemented}\n" +" method Set list {return -code error unimplemented}\n" +" method -set args {tailcall my Set $args}\n" +" method -append args {\n" +" set current [uplevel 1 [list [namespace which my] Get]]\n" +" tailcall my Set [list {*}$current {*}$args]\n" +" }\n" +" method -clear {} {tailcall my Set {}}\n" +" forward --default-operation my -append\n" +" method unknown {args} {\n" +" set def --default-operation\n" +" if {[llength $args] == 0} {\n" +" tailcall my $def\n" +" } elseif {![string match -* [lindex $args 0]]} {\n" +" tailcall my $def {*}$args\n" +" }\n" +" next {*}$args\n" +" }\n" +" export -set -append -clear\n" +" unexport unknown destroy\n" +"}\n" +"\n" +"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" +"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" +"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; + +/* + * The body of the method of oo::object. + */ + +static const char *clonedBody = +"foreach p [info procs [info object namespace $originObject]::*] {\n" +" set args [info args $p]\n" +" set idx -1\n" +" foreach a $args {\n" +" lset args [incr idx]" +" [if {[info default $p $a d]} {list $a $d} {list $a}]\n" +" }\n" +" set b [info body $p]\n" +" set p [namespace tail $p]\n" +" proc $p $args $b\n" +"}\n" +"foreach v [info vars [info object namespace $originObject]::*] {\n" +" upvar 0 $v vOrigin\n" +" namespace upvar [namespace current] [namespace tail $v] vNew\n" +" if {[info exists vOrigin]} {\n" +" if {[array exists vOrigin]} {\n" +" array set vNew [array get vOrigin]\n" +" } else {\n" +" set vNew $vOrigin\n" +" }\n" +" }\n" +"}\n"; + +#endif /* TCL_OO_SCRIPT_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index f044e41..9aa67fb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1220,7 +1220,7 @@ tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c -tclOO.o: $(GENERIC_DIR)/tclOO.c +tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c -- cgit v0.12 From 9e511d78742e4c5b32ad7d4286f2c0bd56e0083a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Jun 2018 16:47:45 +0000 Subject: Most of the implementation ported over. [classmethod] is trickier... --- generic/tclOOScript.h | 107 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/oo.test | 2 +- 2 files changed, 107 insertions(+), 2 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 51a8a56..5772e2c 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -19,9 +19,90 @@ */ static const char *tclOOSetupScript = +"::proc ::oo::Helpers::callback {method args} {\n" +" list [uplevel 1 {namespace which my}] $method {*}$args\n" +"}\n" + +"::proc ::oo::Helpers::mymethod {method args} {\n" +" list [uplevel 1 {namespace which my}] $method {*}$args\n" +"}\n" + +"::proc ::oo::Helpers::classvariable {name args} {\n" +" # Get a reference to the class's namespace\n" +" set ns [info object namespace [uplevel 1 {self class}]]\n" +" # Double up the list of variable names\n" +" set vs [list $name $name]\n" +" foreach v $args {lappend vs $v $v}\n" +" # Lastly, link the caller's local variables to the class's variables\n" +" tailcall namespace upvar $ns {*}$vs\n" +"}\n" + +"::proc ::oo::Helpers::link {args} {\n" +" set ns [uplevel 1 {namespace current}]\n" +" foreach link $args {\n" +" if {[llength $link] == 2} {\n" +" lassign $link src dst\n" +" } else {\n" +" lassign $link src\n" +" set dst $src\n" +" }\n" +" interp alias {} ${ns}::$src {} ${ns}::my $dst\n" +" }\n" +" return\n" +"}\n" + +/* +"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n" +" # Create the method on the class if the caller gave arguments and body\n" +" set argc [llength [info level 0]]\n" +" if {$argc == 3} {\n" +" return -code error [string cat {wrong # args: should be \"}" +" [lindex [info level 0] 0] { name ?args body?\"}]\n" +" }\n" +" # Get the name of the current class or class delegate\n" +" set cls [uplevel 1 self]\n" +" set d $cls.Delegate\n" +" if {[info object isa object $d] && [info object isa class $d]} {\n" +" set cls $d\n" +" }\n" +" if {$argc == 4} {\n" +" ::oo::define $cls method $name $args $body\n" +" }\n" +" # Make the connection by forwarding\n" +" tailcall forward $name [info object namespace $cls]::my $name\n" +"}\n" + +"# Build this *almost* like a class method, but with extra care to avoid\n" +"# nuking the existing method.\n" +"::oo::class create ::oo::class.Delegate {\n" +" method create {name args} {\n" +" if {![string match ::* $name]} {\n" +" set ns [uplevel 1 {namespace current}]\n" +" if {$ns eq {::}} {set ns {}}\n" +" set name ${ns}::${name}\n" +" }\n" +" if {[string match *.Delegate $name]} {\n" +" return [next $name {*}$args]\n" +" }\n" +" set delegate [oo::class create $name.Delegate]\n" +" set cls [next $name {*}$args]\n" +" set superdelegates [list $delegate]\n" +" foreach c [info class superclass $cls] {\n" +" set d $c.Delegate\n" +" if {[info object isa object $d] && [info object isa class $d]} {\n" +" lappend superdelegates $d\n" +" }\n" +" }\n" +" oo::objdefine $cls mixin {*}$superdelegates\n" +" return $cls\n" +" }\n" +"}\n" +*/ + "::oo::define ::oo::Slot {\n" " method Get {} {return -code error unimplemented}\n" " method Set list {return -code error unimplemented}\n" + " method -set args {tailcall my Set $args}\n" " method -append args {\n" " set current [uplevel 1 [list [namespace which my] Get]]\n" @@ -29,6 +110,7 @@ static const char *tclOOSetupScript = " }\n" " method -clear {} {tailcall my Set {}}\n" " forward --default-operation my -append\n" + " method unknown {args} {\n" " set def --default-operation\n" " if {[llength $args] == 0} {\n" @@ -38,13 +120,36 @@ static const char *tclOOSetupScript = " }\n" " next {*}$args\n" " }\n" + " export -set -append -clear\n" " unexport unknown destroy\n" "}\n" "\n" "::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; +"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" + +/* +"::oo::define ::oo::class self mixin ::oo::class.Delegate\n" +*/ + +"::oo::class create ::oo::singleton {\n" +" superclass ::oo::class\n" +" variable object\n" +" unexport create createWithNamespace\n" +" method new args {\n" +" if {![info exists object]} {\n" +" set object [next {*}$args]\n" +" }\n" +" return $object\n" +" }\n" +"}\n" + +"::oo::class create ::oo::abstract {\n" +" superclass ::oo::class\n" +" unexport create createWithNamespace new\n" +"}\n" +; /* * The body of the method of oo::object. diff --git a/tests/oo.test b/tests/oo.test index 9a22438..25ef5e2 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -343,7 +343,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { }] {lsort $x} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as -- cgit v0.12 From 8e696a5e5d19327336892388286b8d5d4fdc64a8 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Jun 2018 17:27:41 +0000 Subject: Leaving out the weird delegates stops the test failures. --- generic/tclOOScript.h | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 5772e2c..4ca286c 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -51,7 +51,6 @@ static const char *tclOOSetupScript = " return\n" "}\n" -/* "proc ::oo::define::classmethod {name {args {}} {body {}}} {\n" " # Create the method on the class if the caller gave arguments and body\n" " set argc [llength [info level 0]]\n" @@ -59,12 +58,13 @@ static const char *tclOOSetupScript = " return -code error [string cat {wrong # args: should be \"}" " [lindex [info level 0] 0] { name ?args body?\"}]\n" " }\n" -" # Get the name of the current class or class delegate\n" " set cls [uplevel 1 self]\n" +/* " set d $cls.Delegate\n" " if {[info object isa object $d] && [info object isa class $d]} {\n" " set cls $d\n" " }\n" +*/ " if {$argc == 4} {\n" " ::oo::define $cls method $name $args $body\n" " }\n" @@ -72,6 +72,7 @@ static const char *tclOOSetupScript = " tailcall forward $name [info object namespace $cls]::my $name\n" "}\n" +/* "# Build this *almost* like a class method, but with extra care to avoid\n" "# nuking the existing method.\n" "::oo::class create ::oo::class.Delegate {\n" -- cgit v0.12 From 05209c57d377b14758bda3882b0a70b979898066 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 23 Jun 2018 15:03:26 +0000 Subject: Make the delegates work by moving their creation into C. --- generic/tclOOBasic.c | 22 +++++++++++++++++--- generic/tclOOScript.h | 56 +++++++++++++++++---------------------------------- tests/oo.test | 45 ++++++++++++++++++++++++++++++++++++++++- 3 files changed, 81 insertions(+), 42 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 763f0ad..54115e0 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -83,7 +83,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke; + Tcl_Obj **invoke, *nameObj; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -94,6 +94,17 @@ TclOO_Class_Constructor( } /* + * Make the class definition delegate. This is special; it doesn't reenter + * here (and the class definition delegate doesn't run any constructors). + */ + + nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); + Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); + Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, + TclGetString(nameObj), NULL, -1, NULL, -1); + Tcl_DecrRefCount(nameObj); + + /* * Delegate to [oo::define] to do the work. */ @@ -128,12 +139,17 @@ DecrRefsPostClassConstructor( int result) { Tcl_Obj **invoke = data[0]; + Tcl_InterpState saved; TclDecrRefCount(invoke[0]); - TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); + invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + Tcl_IncrRefCount(invoke[0]); + saved = Tcl_SaveInterpState(interp, result); + Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[1]); ckfree(invoke); - return result; + return Tcl_RestoreInterpState(interp, saved); } /* diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4ca286c..102f2a2 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -5,7 +5,9 @@ * that the code can be definitely run even in safe interpreters; TclOO's * core setup is safe. * - * Copyright (c) 2012-2018 by Donal K. Fellows + * Copyright (c) 2012-2018 Donal K. Fellows + * Copyright (c) 2013 Andreas Kupries + * Copyright (c) 2017 Gerald Lester * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -51,6 +53,10 @@ static const char *tclOOSetupScript = " return\n" "}\n" +"proc ::oo::DelegateName {class} {\n" +" string cat [info object namespace $class] {:: oo ::delegate}\n" +"}\n" + "proc ::oo::define::classmethod {name {args {}} {body {}}} {\n" " # Create the method on the class if the caller gave arguments and body\n" " set argc [llength [info level 0]]\n" @@ -59,46 +65,24 @@ static const char *tclOOSetupScript = " [lindex [info level 0] 0] { name ?args body?\"}]\n" " }\n" " set cls [uplevel 1 self]\n" -/* -" set d $cls.Delegate\n" -" if {[info object isa object $d] && [info object isa class $d]} {\n" -" set cls $d\n" -" }\n" -*/ " if {$argc == 4} {\n" -" ::oo::define $cls method $name $args $body\n" +" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" " }\n" " # Make the connection by forwarding\n" " tailcall forward $name [info object namespace $cls]::my $name\n" "}\n" -/* -"# Build this *almost* like a class method, but with extra care to avoid\n" -"# nuking the existing method.\n" -"::oo::class create ::oo::class.Delegate {\n" -" method create {name args} {\n" -" if {![string match ::* $name]} {\n" -" set ns [uplevel 1 {namespace current}]\n" -" if {$ns eq {::}} {set ns {}}\n" -" set name ${ns}::${name}\n" -" }\n" -" if {[string match *.Delegate $name]} {\n" -" return [next $name {*}$args]\n" -" }\n" -" set delegate [oo::class create $name.Delegate]\n" -" set cls [next $name {*}$args]\n" -" set superdelegates [list $delegate]\n" -" foreach c [info class superclass $cls] {\n" -" set d $c.Delegate\n" -" if {[info object isa object $d] && [info object isa class $d]} {\n" -" lappend superdelegates $d\n" -" }\n" -" }\n" -" oo::objdefine $cls mixin {*}$superdelegates\n" -" return $cls\n" -" }\n" +"proc ::oo::MixinClassDelegates {class} {\n" +" ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n" +" set d [::oo::DelegateName $c]\n" +" if {![info object isa class $d]} continue; set d\n" +" }]\n" +"}\n" + +"::proc ::oo::define::initialise {body} {\n" +" set clsns [info object namespace [uplevel 1 self]]\n" +" tailcall apply [list {} $body $clsns]\n" "}\n" -*/ "::oo::define ::oo::Slot {\n" " method Get {} {return -code error unimplemented}\n" @@ -130,10 +114,6 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" -/* -"::oo::define ::oo::class self mixin ::oo::class.Delegate\n" -*/ - "::oo::class create ::oo::singleton {\n" " superclass ::oo::class\n" " variable object\n" diff --git a/tests/oo.test b/tests/oo.test index 25ef5e2..87f0567 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -340,7 +340,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { lappend x [info object class ::oo::$initial] } return $x - }] {lsort $x} + }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]} } -cleanup { interp delete $fresh } -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} @@ -4845,6 +4845,49 @@ test oo-40.3 {TIP 500: private and unexport} -setup { } -cleanup { cls destroy } -result {{} {} foo {} foo {}} + +test oo-41.1 {TIP 478: classmethod} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { puts "[self] called with arguments: $args" } + } + oo::class create Table { + superclass ActiveRecord + } + Table find foo bar +} -cleanup { + parent destroy +} -output "::Table called with arguments: foo bar\n" +test oo-41.2 {TIP 478: classmethod in namespace} -setup { + namespace eval ::testns {} +} -body { + namespace eval ::testns { + oo::class create ActiveRecord { + classmethod find args { puts "[self] called with arguments: $args" } + } + oo::class create Table { + superclass ActiveRecord + } + } + testns::Table find foo bar +} -cleanup { + namespace delete ::testns +} -output "::testns::Table called with arguments: foo bar\n" +test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { + oo::class create parent +} -body { + oo::class create TestClass { + superclass oo::class parent + self method create {name ignore body} { + next $name $body + } + } + TestClass create okay {} {} +} -cleanup { + parent destroy +} -result {::okay} cleanupTests return -- cgit v0.12 From 082e8c6d7aa61e4250a321d2d44ca57c8d09049d Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 27 Jun 2018 07:39:49 +0000 Subject: Add better error handling and make the delegation work with cloning. --- generic/tclOOBasic.c | 14 ++++- generic/tclOOScript.h | 35 +++++++++++-- tests/oo.test | 139 ++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 178 insertions(+), 10 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 54115e0..13c98f4 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -122,7 +122,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke, NULL, NULL, NULL); + invoke, oPtr, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -139,16 +139,26 @@ DecrRefsPostClassConstructor( int result) { Tcl_Obj **invoke = data[0]; + Object *oPtr = data[1]; Tcl_InterpState saved; + int code; TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + invoke[1] = TclOOObjectName(interp, oPtr); Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); saved = Tcl_SaveInterpState(interp, result); - Tcl_EvalObjv(interp, 2, invoke, 0); + code = Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); ckfree(invoke); + if (code != TCL_OK) { + Tcl_DiscardInterpState(saved); + return code; + } return Tcl_RestoreInterpState(interp, saved); } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 102f2a2..73c3383 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -73,10 +73,21 @@ static const char *tclOOSetupScript = "}\n" "proc ::oo::MixinClassDelegates {class} {\n" -" ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n" +" if {![info object isa class $class]} {\n" +" return\n" +" }\n" +" set delegate [::oo::DelegateName $class]\n" +" if {![info object isa class $delegate]} {\n" +" return\n" +" }\n" +" foreach c [info class superclass $class] {" " set d [::oo::DelegateName $c]\n" -" if {![info object isa class $d]} continue; set d\n" -" }]\n" +" if {![info object isa class $d]} {\n" +" continue\n" +" }\n" +" ::oo::define $delegate superclass -append $d\n" +" }\n" +" ::oo::objdefine $class mixin -append $delegate\n" "}\n" "::proc ::oo::define::initialise {body} {\n" @@ -114,6 +125,19 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" +"::oo::define ::oo::class method {originObject} {\n" +" next $originObject\n" +" # Rebuild the class inheritance delegation class\n" +" set originDelegate [::oo::DelegateName $originObject]\n" +" set targetDelegate [::oo::DelegateName [self]]\n" +" if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n" +" ::oo::copy $originDelegate $targetDelegate\n" +" ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n" +" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" +" }]\n" +" }\n" +"}\n" + "::oo::class create ::oo::singleton {\n" " superclass ::oo::class\n" " variable object\n" @@ -137,6 +161,7 @@ static const char *tclOOSetupScript = */ static const char *clonedBody = +"# Copy over the procedures from the original namespace\n" "foreach p [info procs [info object namespace $originObject]::*] {\n" " set args [info args $p]\n" " set idx -1\n" @@ -148,6 +173,7 @@ static const char *clonedBody = " set p [namespace tail $p]\n" " proc $p $args $b\n" "}\n" +"# Copy over the variables from the original namespace\n" "foreach v [info vars [info object namespace $originObject]::*] {\n" " upvar 0 $v vOrigin\n" " namespace upvar [namespace current] [namespace tail $v] vNew\n" @@ -158,7 +184,8 @@ static const char *clonedBody = " set vNew $vOrigin\n" " }\n" " }\n" -"}\n"; +"}\n" +; #endif /* TCL_OO_SCRIPT_H */ diff --git a/tests/oo.test b/tests/oo.test index 87f0567..9aafe2e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4851,7 +4851,9 @@ test oo-41.1 {TIP 478: classmethod} -setup { } -body { oo::class create ActiveRecord { superclass parent - classmethod find args { puts "[self] called with arguments: $args" } + classmethod find args { + return "[self] called with arguments: $args" + } } oo::class create Table { superclass ActiveRecord @@ -4859,13 +4861,15 @@ test oo-41.1 {TIP 478: classmethod} -setup { Table find foo bar } -cleanup { parent destroy -} -output "::Table called with arguments: foo bar\n" +} -result {::Table called with arguments: foo bar} test oo-41.2 {TIP 478: classmethod in namespace} -setup { namespace eval ::testns {} } -body { namespace eval ::testns { oo::class create ActiveRecord { - classmethod find args { puts "[self] called with arguments: $args" } + classmethod find args { + return "[self] called with arguments: $args" + } } oo::class create Table { superclass ActiveRecord @@ -4874,7 +4878,7 @@ test oo-41.2 {TIP 478: classmethod in namespace} -setup { testns::Table find foo bar } -cleanup { namespace delete ::testns -} -output "::testns::Table called with arguments: foo bar\n" +} -result {::testns::Table called with arguments: foo bar} test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { oo::class create parent } -body { @@ -4888,6 +4892,133 @@ test oo-41.3 {TIP 478: classmethod must not interfere with constructor signature } -cleanup { parent destroy } -result {::okay} +test oo-41.4 {TIP 478: classmethod with three levels} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + oo::class create SubTable { + superclass Table + } + SubTable find foo bar +} -cleanup { + parent destroy +} -result {::SubTable called with arguments: foo bar} + +test oo-42.1 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [callback CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test oo-42.2 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test oo-42.3 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [mymethod CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test oo-42.4 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [mymethod CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test oo-42.5 {TIP 478: callbacks and method lifetime} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + set result [list [catch {{*}$cb PQR} msg] $msg] + oo::objdefine context { + method CallMe {a b c} { return ok,[self],$a,$b,$c } + } + lappend result [{*}$cb PQR] +} -cleanup { + parent destroy +} -result {1 {unknown method "CallMe": must be , destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} +test oo-42.6 {TIP 478: callback use case} -setup { + oo::class create parent + unset -nocomplain x +} -body { + oo::class create c { + superclass parent + variable count + constructor {var} { + set count 0 + upvar 1 $var v + trace add variable v write [callback TraceCallback] + } + method count {} {return $count} + method TraceCallback {name1 name2 op} { + incr count + } + } + set o [c new x] + for {set x 0} {$x < 5} {incr x} {} + $o count +} -cleanup { + unset -nocomplain x + parent destroy +} -result 6 cleanupTests return -- cgit v0.12 From 8219fb26323aa59d5e46299099e965049a0cb654 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Jun 2018 08:12:07 +0000 Subject: Tests for abstract and singleton --- generic/tclOOScript.h | 3 +- tests/oo.test | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 93 insertions(+), 2 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 73c3383..22f5e56 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -143,8 +143,9 @@ static const char *tclOOSetupScript = " variable object\n" " unexport create createWithNamespace\n" " method new args {\n" -" if {![info exists object]} {\n" +" if {![info exists object] || ![info object isa object $object]} {\n" " set object [next {*}$args]\n" +" ::oo::objdefine $object unexport destroy\n" " }\n" " return $object\n" " }\n" diff --git a/tests/oo.test b/tests/oo.test index 9aafe2e..1e694c1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4892,7 +4892,7 @@ test oo-41.3 {TIP 478: classmethod must not interfere with constructor signature } -cleanup { parent destroy } -result {::okay} -test oo-41.4 {TIP 478: classmethod with three levels} -setup { +test oo-41.4 {TIP 478: classmethod with several inheritance levels} -setup { oo::class create parent } -body { oo::class create ActiveRecord { @@ -4911,6 +4911,41 @@ test oo-41.4 {TIP 478: classmethod with three levels} -setup { } -cleanup { parent destroy } -result {::SubTable called with arguments: foo bar} +test oo-41.5 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + set t [Table new] + $t find 1 2 3 +} -cleanup { + parent destroy +} -result {::ActiveRecord called with arguments: 1 2 3} +test oo-41.6 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + unexport find + } + set t [Table new] + $t find 1 2 3 +} -returnCodes error -cleanup { + parent destroy +} -match glob -result {unknown method "find": must be *} test oo-42.1 {TIP 478: callback generation} -setup { oo::class create parent @@ -5019,6 +5054,61 @@ test oo-42.6 {TIP 478: callback use case} -setup { unset -nocomplain x parent destroy } -result 6 + +test oo-43.1 {TIP 478: class initialisation} -setup { + oo::class create parent +} -body { + oo::class create ::cls { + superclass parent + initialise { + proc foobar {} {return ok} + } + method calls {} { + list [catch foobar msg] $msg \ + [namespace eval [info object namespace [self class]] foobar] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar"} ok} + +test oo-44.1 {TIP 478: singleton} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + set x [xyz new] + set y [xyz new] + set z [xyz new] + set code [catch {$x destroy} msg] + set p [xyz new] + lappend code $msg [catch {rename $x ""}] + set q [xyz new] + string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] +} -cleanup { + parent destroy +} -result {1 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO} + +test oo-45.1 {TIP 478: abstract} -setup { + oo::class create parent +} -body { + oo::abstract create xyz { + superclass parent + method foo {} {return 123} + } + oo::class create pqr { + superclass xyz + method bar {} {return 456} + } + set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] + set x [pqr new] + set y [pqr create ::y] + lappend codes [$x foo] [$x bar] $y +} -cleanup { + parent destroy +} -result {1 1 1 123 456 ::y} cleanupTests return -- cgit v0.12 From 4c24e60418bdb662ac652345798230eeff89ce0b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Jun 2018 10:40:37 +0000 Subject: Split out TIP 478 tests into their own file. --- tests/oo.test | 264 ------------------------------------------ tests/ooUtil.test | 337 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 337 insertions(+), 264 deletions(-) create mode 100644 tests/ooUtil.test diff --git a/tests/oo.test b/tests/oo.test index 1e694c1..7e0f12e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4845,270 +4845,6 @@ test oo-40.3 {TIP 500: private and unexport} -setup { } -cleanup { cls destroy } -result {{} {} foo {} foo {}} - -test oo-41.1 {TIP 478: classmethod} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - Table find foo bar -} -cleanup { - parent destroy -} -result {::Table called with arguments: foo bar} -test oo-41.2 {TIP 478: classmethod in namespace} -setup { - namespace eval ::testns {} -} -body { - namespace eval ::testns { - oo::class create ActiveRecord { - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - } - testns::Table find foo bar -} -cleanup { - namespace delete ::testns -} -result {::testns::Table called with arguments: foo bar} -test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { - oo::class create parent -} -body { - oo::class create TestClass { - superclass oo::class parent - self method create {name ignore body} { - next $name $body - } - } - TestClass create okay {} {} -} -cleanup { - parent destroy -} -result {::okay} -test oo-41.4 {TIP 478: classmethod with several inheritance levels} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - oo::class create SubTable { - superclass Table - } - SubTable find foo bar -} -cleanup { - parent destroy -} -result {::SubTable called with arguments: foo bar} -test oo-41.5 {TIP 478: classmethod and instances} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - } - set t [Table new] - $t find 1 2 3 -} -cleanup { - parent destroy -} -result {::ActiveRecord called with arguments: 1 2 3} -test oo-41.6 {TIP 478: classmethod and instances} -setup { - oo::class create parent -} -body { - oo::class create ActiveRecord { - superclass parent - classmethod find args { - return "[self] called with arguments: $args" - } - } - oo::class create Table { - superclass ActiveRecord - unexport find - } - set t [Table new] - $t find 1 2 3 -} -returnCodes error -cleanup { - parent destroy -} -match glob -result {unknown method "find": must be *} - -test oo-42.1 {TIP 478: callback generation} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {} { return ok,[self] } - method makeCall {} { - return [callback CallMe] - } - } - c create ::context - set cb [context makeCall] - {*}$cb -} -cleanup { - parent destroy -} -result {ok,::context} -test oo-42.2 {TIP 478: callback generation} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {a b c} { return ok,[self],$a,$b,$c } - method makeCall {b} { - return [callback CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - {*}$cb PQR -} -cleanup { - parent destroy -} -result {ok,::context,123,a b c,PQR} -test oo-42.3 {TIP 478: callback generation, alternate name} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {} { return ok,[self] } - method makeCall {} { - return [mymethod CallMe] - } - } - c create ::context - set cb [context makeCall] - {*}$cb -} -cleanup { - parent destroy -} -result {ok,::context} -test oo-42.4 {TIP 478: callback generation, alternate name} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method CallMe {a b c} { return ok,[self],$a,$b,$c } - method makeCall {b} { - return [mymethod CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - {*}$cb PQR -} -cleanup { - parent destroy -} -result {ok,::context,123,a b c,PQR} -test oo-42.5 {TIP 478: callbacks and method lifetime} -setup { - oo::class create parent -} -body { - oo::class create c { - superclass parent - method makeCall {b} { - return [callback CallMe 123 $b] - } - } - c create ::context - set cb [context makeCall "a b c"] - set result [list [catch {{*}$cb PQR} msg] $msg] - oo::objdefine context { - method CallMe {a b c} { return ok,[self],$a,$b,$c } - } - lappend result [{*}$cb PQR] -} -cleanup { - parent destroy -} -result {1 {unknown method "CallMe": must be , destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} -test oo-42.6 {TIP 478: callback use case} -setup { - oo::class create parent - unset -nocomplain x -} -body { - oo::class create c { - superclass parent - variable count - constructor {var} { - set count 0 - upvar 1 $var v - trace add variable v write [callback TraceCallback] - } - method count {} {return $count} - method TraceCallback {name1 name2 op} { - incr count - } - } - set o [c new x] - for {set x 0} {$x < 5} {incr x} {} - $o count -} -cleanup { - unset -nocomplain x - parent destroy -} -result 6 - -test oo-43.1 {TIP 478: class initialisation} -setup { - oo::class create parent -} -body { - oo::class create ::cls { - superclass parent - initialise { - proc foobar {} {return ok} - } - method calls {} { - list [catch foobar msg] $msg \ - [namespace eval [info object namespace [self class]] foobar] - } - } - [cls new] calls -} -cleanup { - parent destroy -} -result {1 {invalid command name "foobar"} ok} - -test oo-44.1 {TIP 478: singleton} -setup { - oo::class create parent -} -body { - oo::singleton create xyz { - superclass parent - } - set x [xyz new] - set y [xyz new] - set z [xyz new] - set code [catch {$x destroy} msg] - set p [xyz new] - lappend code $msg [catch {rename $x ""}] - set q [xyz new] - string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] -} -cleanup { - parent destroy -} -result {1 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO} - -test oo-45.1 {TIP 478: abstract} -setup { - oo::class create parent -} -body { - oo::abstract create xyz { - superclass parent - method foo {} {return 123} - } - oo::class create pqr { - superclass xyz - method bar {} {return 456} - } - set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] - set x [pqr new] - set y [pqr create ::y] - lappend codes [$x foo] [$x bar] $y -} -cleanup { - parent destroy -} -result {1 1 1 123 456 ::y} cleanupTests return diff --git a/tests/ooUtil.test b/tests/ooUtil.test new file mode 100644 index 0000000..4e4dba1 --- /dev/null +++ b/tests/ooUtil.test @@ -0,0 +1,337 @@ +# This file contains a collection of tests for functionality originally +# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs +# the tests and generates output for errors. No output means no errors were +# found. +# +# Copyright (c) 2014-2016 Andreas Kupries +# Copyright (c) 2018 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require TclOO 1.0.3 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +test ooUtil-1.1 {TIP 478: classmethod} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + Table find foo bar +} -cleanup { + parent destroy +} -result {::Table called with arguments: foo bar} +test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { + namespace eval ::testns {} +} -body { + namespace eval ::testns { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + } + testns::Table find foo bar +} -cleanup { + namespace delete ::testns +} -result {::testns::Table called with arguments: foo bar} +test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { + oo::class create parent +} -body { + oo::class create TestClass { + superclass oo::class parent + self method create {name ignore body} { + next $name $body + } + } + TestClass create okay {} {} +} -cleanup { + parent destroy +} -result {::okay} +test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + oo::class create SubTable { + superclass Table + } + SubTable find foo bar +} -cleanup { + parent destroy +} -result {::SubTable called with arguments: foo bar} +test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + set t [Table new] + $t find 1 2 3 +} -cleanup { + parent destroy +} -result {::ActiveRecord called with arguments: 1 2 3} +test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + unexport find + } + set t [Table new] + $t find 1 2 3 +} -returnCodes error -cleanup { + parent destroy +} -match glob -result {unknown method "find": must be *} + +test ooUtil-2.1 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [callback CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.2 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [mymethod CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [mymethod CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + set result [list [catch {{*}$cb PQR} msg] $msg] + oo::objdefine context { + method CallMe {a b c} { return ok,[self],$a,$b,$c } + } + lappend result [{*}$cb PQR] +} -cleanup { + parent destroy +} -result {1 {unknown method "CallMe": must be , destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} +test ooUtil-2.6 {TIP 478: callback use case} -setup { + oo::class create parent + unset -nocomplain x +} -body { + oo::class create c { + superclass parent + variable count + constructor {var} { + set count 0 + upvar 1 $var v + trace add variable v write [callback TraceCallback] + } + method count {} {return $count} + method TraceCallback {name1 name2 op} { + incr count + } + } + set o [c new x] + for {set x 0} {$x < 5} {incr x} {} + $o count +} -cleanup { + unset -nocomplain x + parent destroy +} -result 6 + +test ooUtil-3.1 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + proc foobar-3.1 {} {return ok} + } + method calls {} { + list [catch foobar-3.1 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.1] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.1"} ok} +test ooUtil-3.2 {TIP 478: class variables} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + variable x 123 + } + method call {} { + classvariable x + incr x + } + } + cls create a + cls create b + cls create c + list [a call] [b call] [c call] [a call] [b call] [c call] +} -cleanup { + parent destroy +} -result {124 125 126 127 128 129} + +test ooUtil-4.1 {TIP 478: singleton} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + set x [xyz new] + set y [xyz new] + set z [xyz new] + set code [catch {$x destroy} msg] + set p [xyz new] + lappend code $msg [catch {rename $x ""}] + set q [xyz new] + string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] +} -cleanup { + parent destroy +} -result {1 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO} + +test ooUtil-5.1 {TIP 478: abstract} -setup { + oo::class create parent +} -body { + oo::abstract create xyz { + superclass parent + method foo {} {return 123} + } + oo::class create pqr { + superclass xyz + method bar {} {return 456} + } + set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] + set x [pqr new] + set y [pqr create ::y] + lappend codes [$x foo] [$x bar] $y +} -cleanup { + parent destroy +} -result {1 1 1 123 456 ::y} + +# Tests that verify issues detected with the tcllib version of the code +test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { + oo::class create animal {} + namespace eval ::ooutiltest { + oo::class create pet { superclass animal } + } +} -body { + namespace eval ::ooutiltest { + oo::class create dog { superclass pet } + } +} -cleanup { + namespace delete ooutiltest + rename animal {} +} -result {::ooutiltest::dog} +test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { + oo::class create TestClass { + superclass oo::class + self method create {name ignore body} { + next $name $body + } + } +} -body { + TestClass create okay {} {} +} -cleanup { + rename TestClass {} +} -result {::okay} + +cleanupTests +return + +# Local Variables: +# fill-column: 78 +# mode: tcl +# End: -- cgit v0.12 From 3f8c7d5d407e778604b2238e06ced08bf1402eca Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 29 Jun 2018 07:15:06 +0000 Subject: More test cases. More fixes. --- generic/tclOOScript.h | 24 ++++++++++--- tests/ooUtil.test | 98 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 118 insertions(+), 4 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 22f5e56..6dd105e 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -33,8 +33,15 @@ static const char *tclOOSetupScript = " # Get a reference to the class's namespace\n" " set ns [info object namespace [uplevel 1 {self class}]]\n" " # Double up the list of variable names\n" -" set vs [list $name $name]\n" -" foreach v $args {lappend vs $v $v}\n" +" foreach v [list $name {*}$args] {\n" +" if {[string match *(*) $v]} {\n" +" return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n" +" }\n" +" if {[string match *::* $v]} {\n" +" return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n" +" }\n" +" lappend vs $v $v\n" +" }\n" " # Lastly, link the caller's local variables to the class's variables\n" " tailcall namespace upvar $ns {*}$vs\n" "}\n" @@ -48,12 +55,21 @@ static const char *tclOOSetupScript = " lassign $link src\n" " set dst $src\n" " }\n" -" interp alias {} ${ns}::$src {} ${ns}::my $dst\n" +" if {![string match ::* $src]} {\n" +" set src [string cat $ns :: $src]\n" +" }\n" +" interp alias {} $src {} ${ns}::my $dst\n" +" trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n" " }\n" " return\n" "}\n" +"::proc ::oo::Helpers::Unlink {cmd args} {\n" +" if {[namespace which $cmd] ne {}} {\n" +" rename $cmd {}\n" +" }\n" +"}\n" -"proc ::oo::DelegateName {class} {\n" +"::proc ::oo::DelegateName {class} {\n" " string cat [info object namespace $class] {:: oo ::delegate}\n" "}\n" diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 4e4dba1..77fa175 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -301,6 +301,104 @@ test ooUtil-5.1 {TIP 478: abstract} -setup { parent destroy } -result {1 1 1 123 456 ::y} +test ooUtil-6.1 {TIP 478: classvarable} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + initialise { + variable x 1 y 2 + } + method a {} { + classvariable x + incr x + } + method b {} { + classvariable y + incr y + } + method c {} { + classvariable x y + list $x $y + } + } + set p [xyz new] + set q [xyz new] + set result [list [$p c] [$q c]] + $p a + $q b + lappend result [[xyz new] c] +} -cleanup { + parent destroy +} -result {{1 2} {1 2} {2 3}} +test ooUtil-6.2 {TIP 478: classvarable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable x(1) + incr x(1) + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} +test ooUtil-6.3 {TIP 478: classvarable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable ::x + incr x + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} + +test ooUtil-7.1 {TIP 478: link calling pattern} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + method Bar {} {return "in bar of [self]"} + method Grill {} {return "in grill of [self]"} + export eval + constructor {} { + link foo + link {bar Bar} {grill Grill} + } + } + cls create o + o eval {list [foo] [bar] [grill]} +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} +test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + constructor {cmd} { + link [list ::$cmd foo] + } + } + cls create o pqr + list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} + # Tests that verify issues detected with the tcllib version of the code test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { oo::class create animal {} -- cgit v0.12 From 0978bd50ce03a7d56c569156c606be4533699a31 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Jun 2018 05:13:39 +0000 Subject: Started to write documentation --- doc/callback.n | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 86 insertions(+) create mode 100644 doc/callback.n diff --git a/doc/callback.n b/doc/callback.n new file mode 100644 index 0000000..8244f07 --- /dev/null +++ b/doc/callback.n @@ -0,0 +1,86 @@ +'\" +'\" Copyright (c) 2018 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH callback n 0.1 TclOO "TclOO Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +callback, mymethod \- generate callbacks to methods +.SH SYNOPSIS +.nf +package require TclOO + +\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR? +\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR? +.fi +.BE +.SH DESCRIPTION +The \fBcallback\fR command, also called \fBmymethod\fR for compatibility with +the ooutil package of Tcllib, and which should only be used from within the +context of a call to a method (i.e. inside a method, constructor or destructor +body) is used to generate a script fragment that will invoke the method, +\fImethodName\fR, on the current object (as reported by \fBself\fR) when +executed. Any additional arguments provided will be provided as leading +arguments to the callback. The resulting script fragment shall be a proper +list. +.PP +Note that it is up to the caller to ensure that the current object is able to +handle the call of \fImethodName\fR; this command does not check that. +\fImethodName\fR may refer to any exported or unexported method, but may not +refer to a private method as those can only be invoked directly from within +methods. If there is no such method present at the point when the callback is +invoked, the standard \fBunknown\fR method handler will be called. +.SH EXAMPLE +This is a simple echo server class. The \fBcallback\fR command is used in two +places, to arrange for the incoming socket connections to be handled by the +\fIAccept\fR method, and to arrange for the incoming bytes on those +connections to be handled by the \fIReceive\fR method. +.PP +.CS +oo::class create EchoServer { + variable server clients + constructor {port} { + set server [socket -server [\fBcallback\fR Accept] $port] + set clients {} + } + destructor { + chan close $server + foreach client [dict keys $clients] { + chan close $client + } + } + + method Accept {channel clientAddress clientPort} { + dict set clients $channel [dict create \e + address $clientAddress port $clientPort] + chan event $channel readable [\fBcallback\fR Receive $channel] + } + method Receive {channel} { + if {[chan gets $channel line] >= 0} { + my echo $channel $line + } else { + chan close $channel + dict unset clients $channel + } + } + + method echo {channel line} { + dict with clients $channel { + chan puts $channel \e + [format {[%s:%d] %s} $address $port $line] + } + } +} +.CE +.SH "SEE ALSO" +chan(n), fileevent(n), my(n), self(n), socket(n), trace(n) +.SH KEYWORDS +callback, object +.\" Local Variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From bffb982059c34bbd6c4bcb6074af928f28ceeed4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Jun 2018 13:44:25 +0000 Subject: More docs --- doc/callback.n | 18 +++++++------ doc/classvariable.n | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 88 insertions(+), 8 deletions(-) create mode 100644 doc/classvariable.n diff --git a/doc/callback.n b/doc/callback.n index 8244f07..a05eb9c 100644 --- a/doc/callback.n +++ b/doc/callback.n @@ -19,14 +19,16 @@ package require TclOO .fi .BE .SH DESCRIPTION -The \fBcallback\fR command, also called \fBmymethod\fR for compatibility with -the ooutil package of Tcllib, and which should only be used from within the -context of a call to a method (i.e. inside a method, constructor or destructor -body) is used to generate a script fragment that will invoke the method, -\fImethodName\fR, on the current object (as reported by \fBself\fR) when -executed. Any additional arguments provided will be provided as leading -arguments to the callback. The resulting script fragment shall be a proper -list. +The \fBcallback\fR command, +'\" Based on notes in the tcllib docs, we know the provenance of mymethod +also called \fBmymethod\fR for compatibility with the ooutil and snit packages +of Tcllib, +and which should only be used from within the context of a call to a method +(i.e. inside a method, constructor or destructor body) is used to generate a +script fragment that will invoke the method, \fImethodName\fR, on the current +object (as reported by \fBself\fR) when executed. Any additional arguments +provided will be provided as leading arguments to the callback. The resulting +script fragment shall be a proper list. .PP Note that it is up to the caller to ensure that the current object is able to handle the call of \fImethodName\fR; this command does not check that. diff --git a/doc/classvariable.n b/doc/classvariable.n new file mode 100644 index 0000000..1edca3e --- /dev/null +++ b/doc/classvariable.n @@ -0,0 +1,78 @@ +'\" +'\" Copyright (c) 2011-2015 Andreas Kupries +'\" Copyright (c) 2018 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH classvariable n 0.1 TclOO "TclOO Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +classvariable \- create link from local variable to variable in class +.SH SYNOPSIS +.nf +package require TclOO + +\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR? +.fi +.BE +.SH DESCRIPTION +The \fBclassvariable\fR command is available within methods. It takes a series +of one or more variable names and makes them available in the method's scope; +those variable names must not be qualified and must not refer to array +elements. The originating scope for the variables is the namespace of the +class that the method was defined by. In other words, the referenced variables +are shared between all instances of that class. +.PP +Note: This command is equivalent to the command \fBtypevariable\fR provided by +the snit package in tcllib for approximately the same purpose. If used in a +method defined directly on a class instance (e.g., through the +\fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just +using: +.PP +.CS +namespace upvar [namespace current] $var $var +.CE +.PP +for each variable listed to \fBclassvariable\fR. +.SH EXAMPLE +This class counts how many instances of it have been made. +.PP +.CS +oo::class create Counted { + initialise { + variable count 0 + } + + variable number + constructor {} { + \fBclassvariable\fR count + set number [incr count] + } + + method report {} { + \fBclassvariable\fR count + puts "This is instance $number of $count" + } +} + +set a [Counted new] +set b [Counted new] +$a report + \fI\(-> This is instance 1 of 2\fR +set c [Counted new] +$b report + \fI\(-> This is instance 2 of 3\fR +$c report + \fI\(-> This is instance 3 of 3\fR +.CE +.SH "SEE ALSO" +global(n), namespace(n), oo::class(n), oo::define(n), upvar(n), variable(n) +.SH KEYWORDS +class, class variable, variable +.\" Local Variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From 1d1e95e7793597eb517bdeffc450474e6616ef92 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Jun 2018 18:30:53 +0000 Subject: More docs --- doc/link.n | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) create mode 100644 doc/link.n diff --git a/doc/link.n b/doc/link.n new file mode 100644 index 0000000..e7c28d7 --- /dev/null +++ b/doc/link.n @@ -0,0 +1,124 @@ +'\" +'\" Copyright (c) 2011-2015 Andreas Kupries +'\" Copyright (c) 2018 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH link n 0.1 TclOO "TclOO Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +link \- create link from command to method of object +.SH SYNOPSIS +.nf +package require TclOO + +\fBlink\fR \fImethodName\fR ?\fI...\fR? +\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR? +.fi +.BE +.SH DESCRIPTION +The \fBlink\fR command is available within methods. It takes a series of one +or more method names (\fImethodName ...\fR) and/or pairs of command- and +method-name (\fB{\fIcommandName methodName\fB}\fR) and makes the named methods +available as commands without requiring the explicit use of the name of the +object or the \fBmy\fR command. The method does not need to exist at the time +that the link is made; if the link command is invoked when the method does not +exist, the standard \fBunknown\fR method handling system is used. +.PP +The command name under which the method becomes available defaults to the +method name, except where explicitly specified through an alias/method pair. +Formally, every argument must be a list; if the list has two elements, the +first element is the name of the command to create and the second element is +the name of the method of the current object to which the command links; +otherwise, the name of the command and the name of the method are the same +string (the first element of the list). +.PP +If the name of the command is not a fully-qualified command name, it will be +resolved with respect to the current namespace (i.e., the object namespace). +.SH EXAMPLES +This demonstrates linking a single method in various ways. First it makes a +simple link, then a renamed link, then an external link. Note that the method +itself is unexported, but that it can still be called directly from outside +the class. +.PP +.CS +oo::class create ABC { + method Foo {} { + puts "This is Foo in [self]" + } + + constructor {} { + \fBlink\fR Foo + # The method foo is now directly accessible as foo here + \fBlink\fR {bar Foo} + # The method foo is now directly accessible as bar + \fBlink\fR {::ExternalCall Foo} + # The method foo is now directly accessible in the global + # namespace as ExternalCall + } + + method grill {} { + puts "Step 1:" + Foo + puts "Step 2:" + bar + } +} + +ABC create abc +abc grill + \fI\(-> Step 1:\fR + \fI\(-> This is foo in ::abc\fR + \fI\(-> Step 2:\fR + \fI\(-> This is foo in ::abc\fR +# Direct access via the linked command +puts "Step 3:"; ExternalCall + \fI\(-> Step 3:\fR + \fI\(-> This is foo in ::abc\fR +.CE +.PP +This example shows that multiple linked commands can be made in a call to +\fBlink\fR, and that they can handle arguments. +.PP +.CS +oo::class create Ex { + constructor {} { + \fBlink\fR a b c + # The methods a, b, and c (defined below) are all now + # directly acessible within methods under their own names. + } + + method a {} { + puts "This is a" + } + method b {x} { + puts "This is b($x)" + } + method c {y z} { + puts "This is c($y,$z)" + } + + method call {p q r} { + a + b $p + c $q $r + } +} + +set o [Ex new] +$o 3 5 7 + \fI\(-> This is a\fR + \fI\(-> This is b(3)\fR + \fI\(-> This is c(5,7)\fR +.CE +.SH "SEE ALSO" +interp(n), my(n), oo::class(n), oo::define(n) +.SH KEYWORDS +command, method, object +.\" Local Variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From 5c7ba37901819efd8c30dee373dada97eafdce04 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Jun 2018 21:36:01 +0000 Subject: More docs --- doc/abstract.n | 75 ++++++++++++++++++++++++++++++++++++++++++ doc/callback.n | 2 +- doc/classvariable.n | 2 +- doc/define.n | 7 ++++ doc/link.n | 2 +- doc/singleton.n | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 178 insertions(+), 3 deletions(-) create mode 100644 doc/abstract.n create mode 100644 doc/singleton.n diff --git a/doc/abstract.n b/doc/abstract.n new file mode 100644 index 0000000..c11202b --- /dev/null +++ b/doc/abstract.n @@ -0,0 +1,75 @@ +'\" +'\" Copyright (c) 2018 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH abstract n 0.3 TclOO "TclOO Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::abstract \- a class that does not allow direct instances of itself +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::abstract\fI method \fR?\fIarg ...\fR? +.fi +.SH "CLASS HIERARCHY" +.nf +\fBoo::object\fR + \(-> \fBoo::class\fR + \(-> \fBoo::abstract\fR +.fi +.BE +.SH DESCRIPTION +Abstract classes are classes that can contain definitions, but which cannot be +directly manufactured; they are intended to only ever be inherited from and +instantiated indirectly. The characteristic methods of \fBoo::class\fR +(\fBcreate\fR and \fBnew\fR) are not exported by an instance of +\fBoo::abstract\fR. +.PP +Note that \fBoo::abstract\fR is not itself an instance of \fBoo::abstract\fR. +.SS CONSTRUCTOR +The \fBoo::abstract\fR class does not define an explicit constructor; this +means that it is effectively the same as the constructor of the +\fBoo::class\fR class. +.SS DESTRUCTOR +The \fBoo::abstract\fR class does not define an explicit destructor. +.SS "EXPORTED METHODS" +The \fBoo::abstract\fR class defines no new exported methods. +.SS "NON-EXPORTED METHODS" +The \fBoo::abstract\fR class explicitly states that \fBcreate\fR, +\fBcreateWithNamespace\fR, and \fBnew\fR are unexported. +.SH EXAMPLES +.PP +This example defines a simple class hierarchy and creates a new instance of +it. It then invokes a method of the object before destroying the hierarchy and +showing that the destruction is transitive. +.PP +.CS +\fBoo::abstract\fR create fruit { + method eat {} { + puts "yummy!" + } +} +oo::class create banana { + superclass fruit + method peel {} { + puts "skin now off" + } +} +set b [banana \fBnew\fR] +$b peel \fI\(-> prints 'skin now off'\fR +$b eat \fI\(-> prints 'yummy!'\fR +set f [fruit new] \fI\(-> error 'unknown method "new"...'\fR +.CE +.SH "SEE ALSO" +oo::define(n), oo::object(n) +.SH KEYWORDS +abstract class, class, metaclass, object +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/callback.n b/doc/callback.n index a05eb9c..95838a9 100644 --- a/doc/callback.n +++ b/doc/callback.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH callback n 0.1 TclOO "TclOO Commands" +.TH callback n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! diff --git a/doc/classvariable.n b/doc/classvariable.n index 1edca3e..0798bb2 100644 --- a/doc/classvariable.n +++ b/doc/classvariable.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH classvariable n 0.1 TclOO "TclOO Commands" +.TH classvariable n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! diff --git a/doc/define.n b/doc/define.n index b489e5f..c0c90d1 100644 --- a/doc/define.n +++ b/doc/define.n @@ -110,6 +110,13 @@ below), this command creates private forwarded methods. .VE TIP500 .RE .TP +\fBinitialise\fI script\fR +.VS TIP478 +This evaluates \fIscript\fR in a context which supports local variables and +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 . This creates or updates a method that is implemented as a procedure-like diff --git a/doc/link.n b/doc/link.n index e7c28d7..7219342 100644 --- a/doc/link.n +++ b/doc/link.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH link n 0.1 TclOO "TclOO Commands" +.TH link n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! diff --git a/doc/singleton.n b/doc/singleton.n new file mode 100644 index 0000000..6319abe --- /dev/null +++ b/doc/singleton.n @@ -0,0 +1,93 @@ +'\" +'\" Copyright (c) 2018 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH singleton n 0.3 TclOO "TclOO Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::singleton \- a class that does only allows one instance of itself +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::singleton\fI method \fR?\fIarg ...\fR? +.fi +.SH "CLASS HIERARCHY" +.nf +\fBoo::object\fR + \(-> \fBoo::class\fR + \(-> \fBoo::singleton\fR +.fi +.BE +.SH DESCRIPTION +Singleton classes are classes that only permit at most one instance of +themselves to exist. They unexport the \fBcreate\fR and +\fBcreateWithNamespace\fR methods entirely, and override the \fBnew\fR method +so that it only makes a new instance if there is no existing instance. It is +not recommended to inherit from a singleton class; singleton-ness is \fInot\fR +inherited. It is not recommended that a singleton class's constructor take any +arguments. +.PP +Instances have their\fB destroy\fR method (from \fBoo::object\fR) unexported +in order to discourage destruction of the object, but destruction remains +possible if strictly necessary (e.g., by destroying the class or using +\fBrename\fR to delete it). +.SS CONSTRUCTOR +The \fBoo::singleton\fR class does not define an explicit constructor; this +means that it is effectively the same as the constructor of the +\fBoo::class\fR class. +.SS DESTRUCTOR +The \fBoo::singleton\fR class does not define an explicit destructor. +.SS "EXPORTED METHODS" +.TP +\fIcls \fBnew \fR?\fIarg ...\fR? +. +This returns the current instance of the singleton class, if one exists, and +creates a new instance only if there is no existing instance. The additional +arguments, \fIarg ...\fR, are only used if a new instance is actually +manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR +method. +.RS +.PP +This is an override of the behaviour of a superclass's method. +.RE +.SS "NON-EXPORTED METHODS" +The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and +\fBcreateWithNamespace\fR are unexported. +.SH EXAMPLE +.PP +This example demonstrates that there is only one instance even though the +\fBnew\fR method is called three times. +.PP +.CS +\fBoo::singleton\fR create Highlander { + method say {} { + puts "there can be only one" + } +} + +set h1 [Highlander new] +set h2 [Highlander new] +if {$h1 eq $h2} { + puts "equal objects" \fI\(-> prints "equal objects"\fR +} +set h3 [Highlander new] +if {$h1 eq $h3} { + puts "equal objects" \fI\(-> prints "equal objects"\fR +} +.CE +.PP +Note that the name of the instance of the singleton is not guaranteed to be +anything in particular. +.SH "SEE ALSO" +oo::class(n) +.SH KEYWORDS +class, metaclass, object, single instance +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From d11660acfec5e51e088b6e9661d3b6b8e0b1988a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 1 Jul 2018 16:39:11 +0000 Subject: Create a special command, [ :my:class], (in each instance namespace) that allows objects to delegate methods to their class. --- generic/tclOO.c | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 2 ++ generic/tclOOScript.h | 2 +- tests/ooUtil.test | 25 +++++++++++++++++++++- unix/Makefile.in | 7 +++++++ 5 files changed, 92 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 7f609b2..8229dc1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -102,6 +102,13 @@ static int PrivateObjectCmd(ClientData clientData, static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int MyClassObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static int MyClassNRObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static void MyClassDeletedCmd(ClientData clientData); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -747,6 +754,9 @@ AllocObject( oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + oPtr->myclassCommand = TclNRCreateCommandInNs(interp, " :my:class", + oPtr->namespacePtr, MyClassObjCmd, MyClassNRObjCmd, oPtr, + MyClassDeletedCmd); return oPtr; } @@ -1165,6 +1175,9 @@ ObjectNamespaceDeleted( Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } + if (oPtr->myclassCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); + } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } @@ -2488,6 +2501,51 @@ TclOOInvokeObject( /* * ---------------------------------------------------------------------- * + * MyClassObjCmd, MyClassNRObjCmd, MyClassDeletedCmd -- + * + * Special trap door to allow an object to delegate simply to its class. + * + * ---------------------------------------------------------------------- + */ + +static int +MyClassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); +} + +static int +MyClassNRObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = clientData; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?"); + return TCL_ERROR; + } + return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, + NULL); +} + +static void +MyClassDeletedCmd( + ClientData clientData) +{ + Object *oPtr = clientData; + oPtr->myclassCommand = NULL; +} + +/* + * ---------------------------------------------------------------------- + * * TclOOObjectCmdCore, FinalizeObjectCall -- * * Main function for object invocations. Does call chain creation, diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index a43ab76..ce4ea0d 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -209,6 +209,8 @@ typedef struct Object { PrivateVariableList privateVariables; /* Configurations for the variable resolver * used inside methods. */ + Tcl_Command myclassCommand; /* Reference to this object's class dispatcher + * command. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 6dd105e..237bff5 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -85,7 +85,7 @@ static const char *tclOOSetupScript = " ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" " }\n" " # Make the connection by forwarding\n" -" tailcall forward $name [info object namespace $cls]::my $name\n" +" tailcall forward $name { :my:class} $name\n" "}\n" "proc ::oo::MixinClassDelegates {class} {\n" diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 77fa175..28ab9c7 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -96,7 +96,7 @@ test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { $t find 1 2 3 } -cleanup { parent destroy -} -result {::ActiveRecord called with arguments: 1 2 3} +} -result {::Table called with arguments: 1 2 3} test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { oo::class create parent } -body { @@ -115,6 +115,29 @@ test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { } -returnCodes error -cleanup { parent destroy } -match glob -result {unknown method "find": must be *} +test ooUtil-1.7 {} -setup { + oo::class create parent +} -body { + oo::class create Foo { + superclass parent + classmethod bar {} { + puts "This is in the class; self is [self]" + my meee + } + classmethod meee {} { + puts "This is meee" + } + } + oo::class create Grill { + superclass Foo + classmethod meee {} { + puts "This is meee 2" + } + } + list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] +} -cleanup { + parent destroy +} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" test ooUtil-2.1 {TIP 478: callback generation} -setup { oo::class create parent diff --git a/unix/Makefile.in b/unix/Makefile.in index 9aa67fb..e4d77e6 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -259,6 +259,7 @@ INSTALL_TZDATA = @INSTALL_TZDATA@ #-------------------------------------------------------------------------- GDB = gdb +LLDB = lldb TRACE = strace TRACE_OPTS = VALGRIND = valgrind @@ -730,6 +731,12 @@ gdb-test: ${TCLTEST_EXE} $(GDB) ./${TCLTEST_EXE} --command=gdb.run rm gdb.run +lldb-test: ${TCLTEST_EXE} + @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run + @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run + $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1 + rm lldb.run + # Useful target to launch a built tcltest with the proper path,... runtest: ${TCLTEST_EXE} $(SHELL_ENV) ./${TCLTEST_EXE} -- cgit v0.12 From 414bcee273fa2ac3fbc1e329f65d1ae7396a22a4 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 2 Jul 2018 07:44:09 +0000 Subject: Documentation for [classmethod] --- doc/define.n | 99 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 99 insertions(+) diff --git a/doc/define.n b/doc/define.n index c0c90d1..099e59f 100644 --- a/doc/define.n +++ b/doc/define.n @@ -39,6 +39,27 @@ used as the \fIdefScript\fR argument. The following commands are supported in the \fIdefScript\fR for \fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: .TP +\fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR? +.VS TIP478 +This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are +omitted) promotes an existing method on the class object to be a class +method. The \fIname\fR, \fIargList\fR and \fIbodyScript\fR arguments are as in +the \fBmethod\fR definition, below. +.RS +.PP +Class methods can be called on either the class itself or on the instances of +that class. When they are called, the current object (see the \fBself\R and +\fBmy\fR commands) is the class on which they are called or the class of the +instance on which they are called, depending on whether they are called on the +class or an instance of the class, respectively. If called on a subclass or +instance of the subclass, the current object is the subclass. +.PP +In a private definition context, the methods as invoked on classes are +\fInot\fR private, but the methods as invoked on instances of classes are +private. +.RE +.VE TIP478 +.TP \fBconstructor\fI argList bodyScript\fR . This creates or updates the constructor for a class. The formal arguments to @@ -503,6 +524,84 @@ oo::class create B { inst m1 \fI\(-> prints "red brick"\fR inst m2 \fI\(-> prints "blue brick"\fR .CE +.PP +.VS TIP478 +This example shows how to create and use class variables. It is a class that +counts how many instances of itself have been made. +.PP +.CS +oo::class create Counted +\fBoo::define\fR Counted { + \fBinitialise\fR { + variable count 0 + } + + \fBvariable\fR number + \fBconstructor\fR {} { + classvariable count + set number [incr count] + } + + \fBmethod\fR report {} { + classvariable count + puts "This is instance $number of $count" + } +} + +set a [Counted new] +set b [Counted new] +$a report + \fI\(-> This is instance 1 of 2\fR +set c [Counted new] +$b report + \fI\(-> This is instance 2 of 3\fR +$c report + \fI\(-> This is instance 3 of 3\fR +.CE +.PP +This example demonstrates how to use class methods. (Note that the constructor +for \fBoo::class\fR calls \fBoo::define\fR on the class.) +.PP +.CS +oo::class create DBTable { + \fBclassmethod\fR find {description} { + puts "DB: locate row from [self] matching $description" + return [my new] + } + \fBclassmethod\fR insert {description} { + puts "DB: create row in [self] matching $description" + return [my new] + } + \fBmethod\fR update {description} { + puts "DB: update row [self] with $description" + } + \fBmethod\fR delete {} { + puts "DB: delete row [self]" + my destroy; # Just delete the object, not the DB row + } +} + +oo::class create Users { + \fBsuperclass\fR DBTable +} +oo::class create Groups { + \fBsuperclass\fR DBTable +} + +set u1 [Users insert "username=abc"] + \fI\(-> DB: create row from ::Users matching username=abc\fR +set u2 [Users insert "username=def"] + \fI\(-> DB: create row from ::Users matching username=def\fR +$u2 update "group=NULL" + \fI\(-> DB: update row ::oo::Obj124 with group=NULL\fR +$u1 delete + \fI\(-> DB: delete row ::oo::Obj123\fR +set g [Group find "groupname=webadmins"] + \fI\(-> DB: locate row ::Group with groupname=webadmins\fR +$g update "emailaddress=admins" + \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR +.CE +.VE TIP478 .SH "SEE ALSO" next(n), oo::class(n), oo::object(n) .SH KEYWORDS -- cgit v0.12 From 969f9f571cda6f6b8db32f8b9cdf922715b37c43 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Jul 2018 13:50:54 +0000 Subject: Improving the singleton --- doc/abstract.n | 4 +++- doc/define.n | 2 +- doc/singleton.n | 20 +++++++++++++------- generic/tclOOScript.h | 7 ++++++- tests/ooUtil.test | 25 +++++++++++++++++++++++-- 5 files changed, 46 insertions(+), 12 deletions(-) diff --git a/doc/abstract.n b/doc/abstract.n index c11202b..022c24b 100644 --- a/doc/abstract.n +++ b/doc/abstract.n @@ -36,7 +36,9 @@ The \fBoo::abstract\fR class does not define an explicit constructor; this means that it is effectively the same as the constructor of the \fBoo::class\fR class. .SS DESTRUCTOR -The \fBoo::abstract\fR class does not define an explicit destructor. +The \fBoo::abstract\fR class does not define an explicit destructor; +destroying an instance of it is just like destroying an ordinary class (and +will destroy all its subclasses). .SS "EXPORTED METHODS" The \fBoo::abstract\fR class defines no new exported methods. .SS "NON-EXPORTED METHODS" diff --git a/doc/define.n b/doc/define.n index 099e59f..860218f 100644 --- a/doc/define.n +++ b/doc/define.n @@ -1,5 +1,5 @@ '\" -'\" Copyright (c) 2007 Donal K. Fellows +'\" Copyright (c) 2007-2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/doc/singleton.n b/doc/singleton.n index 6319abe..568a8bd 100644 --- a/doc/singleton.n +++ b/doc/singleton.n @@ -32,16 +32,20 @@ not recommended to inherit from a singleton class; singleton-ness is \fInot\fR inherited. It is not recommended that a singleton class's constructor take any arguments. .PP -Instances have their\fB destroy\fR method (from \fBoo::object\fR) unexported -in order to discourage destruction of the object, but destruction remains -possible if strictly necessary (e.g., by destroying the class or using -\fBrename\fR to delete it). +Instances have their\fB destroy\fR method overridden with a method that always +returns an error in order to discourage destruction of the object, but +destruction remains possible if strictly necessary (e.g., by destroying the +class or using \fBrename\fR to delete it). They also have a (non-exported) +\fB\fR method defined on them that similarly always returns errors to +make attempts to use the singleton instance with \fBoo::copy\fR fail. .SS CONSTRUCTOR The \fBoo::singleton\fR class does not define an explicit constructor; this means that it is effectively the same as the constructor of the \fBoo::class\fR class. .SS DESTRUCTOR -The \fBoo::singleton\fR class does not define an explicit destructor. +The \fBoo::singleton\fR class does not define an explicit destructor; +destroying an instance of it is just like destroying an ordinary class (and +will destroy the singleton object). .SS "EXPORTED METHODS" .TP \fIcls \fBnew \fR?\fIarg ...\fR? @@ -53,11 +57,13 @@ manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR method. .RS .PP -This is an override of the behaviour of a superclass's method. +This is an override of the behaviour of a superclass's method with an +identical call signature to the superclass's implementation. .RE .SS "NON-EXPORTED METHODS" The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and -\fBcreateWithNamespace\fR are unexported. +\fBcreateWithNamespace\fR are unexported; callers should not assume that they +have control over either the name or the namespace name of the singleton instance. .SH EXAMPLE .PP This example demonstrates that there is only one instance even though the diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 237bff5..d96ee76 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -161,7 +161,12 @@ static const char *tclOOSetupScript = " method new args {\n" " if {![info exists object] || ![info object isa object $object]} {\n" " set object [next {*}$args]\n" -" ::oo::objdefine $object unexport destroy\n" +" ::oo::objdefine $object method destroy {} {\n" +" return -code error {may not destroy a singleton object}\n" +" }\n" +" ::oo::objdefine $object method {originObject} {\n" +" return -code error {may not clone a singleton object}\n" +" }\n" " }\n" " return $object\n" " }\n" diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 28ab9c7..e00c70c 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -298,12 +298,33 @@ test ooUtil-4.1 {TIP 478: singleton} -setup { set z [xyz new] set code [catch {$x destroy} msg] set p [xyz new] - lappend code $msg [catch {rename $x ""}] + lappend code [catch {rename $x ""}] set q [xyz new] string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] } -cleanup { parent destroy -} -result {1 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO} +} -result {1 0 ONE ONE ONE ONE TWO TWO} +test ooUtil-4.2 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + [xyz new] destroy +} -returnCodes error -cleanup { + parent destroy +} -result {may not destroy a singleton object} +test ooUtil-4.3 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + oo::copy [xyz new] +} -returnCodes error -cleanup { + parent destroy +} -result {may not clone a singleton object} + test ooUtil-5.1 {TIP 478: abstract} -setup { oo::class create parent -- cgit v0.12 From 5a06fd4bcf87ea7fc607798714be8886927c1b15 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Jul 2018 08:22:13 +0000 Subject: Document the [myclass] command; someone might find it useful besides me. --- doc/my.n | 60 +++++++++++++++++++++++++++++++++++++++++++++------ generic/tclOO.c | 34 ++++++++++++++--------------- generic/tclOOScript.h | 2 +- 3 files changed, 72 insertions(+), 24 deletions(-) diff --git a/doc/my.n b/doc/my.n index 26d861a..262186f 100644 --- a/doc/my.n +++ b/doc/my.n @@ -9,30 +9,45 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -my \- invoke any method of current object +my, myclass \- invoke any method of current object or its class .SH SYNOPSIS .nf package require TclOO \fBmy\fI methodName\fR ?\fIarg ...\fR? +\fBmyclass\fI methodName\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION .PP The \fBmy\fR command is used to allow methods of objects to invoke methods -of the object (or its class). In particular, the set of valid values for +of the object (or its class), +.VS TIP478 +and he \fBmyclass\fR command is used to allow methods of objects to invoke +methods of the current class of the object \fIas an object\fR. +.VE TIP478 +In particular, the set of valid values for \fImethodName\fR is the set of all methods supported by an object and its superclasses, including those that are not exported .VS TIP500 and private methods of the object or class when used within another method defined by that object or class. .VE TIP500 -The object upon which the method is invoked is the one that owns the namespace -that the \fBmy\fR command is contained in initially (\fBNB:\fR the link +.PP +The object upon which the method is invoked via \fBmy\fR is the one that owns +the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link remains if the command is renamed), which is the currently invoked object by default. +.VS TIP478 +Similarly, the object on which the method is invoked via \fBmyclass\fR is the +object that is the current class of the object that owns the namespace that +the \fBmyclass\fR command is contained in initially. As with \fBmy\fR, the +link remains even if the command is renamed into another namespace, and +defaults to being the manufacturing class of the current object. +.VE TIP478 .PP -Each object has its own \fBmy\fR command, contained in its instance namespace. +Each object has its own \fBmy\fR and \fBmyclass\fR commands, contained in its +instance namespace. .SH EXAMPLES .PP This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of @@ -54,7 +69,8 @@ o count \fI\(-> prints "3"\fR .PP This example shows how you can use \fBmy\fR to make callbacks to private methods from outside the object (from a \fBtrace\fR), using -\fBnamespace code\fR to enter the correct context: +\fBnamespace code\fR to enter the correct context. (See the \fBcallback\fR +command for the recommended way of doing this.) .PP .CS oo::class create HasCallback { @@ -73,6 +89,38 @@ set o [HasCallback new] trace add variable xyz write [$o makeCallback] set xyz "called" \fI\(-> prints "callback: xyz {} write"\fR .CE +.PP +.VS TIP478 +This example shows how to access a private method of a class from an instance +of that class. (See the \fBclassmethod\fR declaration in \fBoo::define\fR for +a higher level interface for doing this.) +.PP +.CS +oo::class create CountedSteps { + self { + variable count + method Count {} { + return [incr count] + } + } + method advanceTwice {} { + puts "in [self] step A: [\fBmyclass\fR Count]" + puts "in [self] step B: [\fBmyclass\fR Count]" + } +} + +CountedSteps create x +CountedSteps create y +x advanceTwice \fI\(-> prints "in ::x step A: 1"\fR + \fI\(-> prints "in ::x step B: 2"\fR +y advanceTwice \fI\(-> prints "in ::y step A: 3"\fR + \fI\(-> prints "in ::y step B: 4"\fR +x advanceTwice \fI\(-> prints "in ::x step A: 5"\fR + \fI\(-> prints "in ::x step B: 6"\fR +y advanceTwice \fI\(-> prints "in ::y step A: 7"\fR + \fI\(-> prints "in ::y step B: 8"\fR +.CE +.VE TIP478 .SH "SEE ALSO" next(n), oo::object(n), self(n) .SH KEYWORDS diff --git a/generic/tclOO.c b/generic/tclOO.c index 8229dc1..630e977 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -108,7 +108,7 @@ static int MyClassObjCmd(ClientData clientData, static int MyClassNRObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static void MyClassDeletedCmd(ClientData clientData); +static void MyClassDeleted(ClientData clientData); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -754,9 +754,9 @@ AllocObject( oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); - oPtr->myclassCommand = TclNRCreateCommandInNs(interp, " :my:class", + oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, MyClassObjCmd, MyClassNRObjCmd, oPtr, - MyClassDeletedCmd); + MyClassDeleted); return oPtr; } @@ -784,12 +784,12 @@ SquelchCachedName( /* * ---------------------------------------------------------------------- * - * MyDeleted -- + * MyDeleted, MyClassDeleted -- * - * This callback is triggered when the object's [my] command is deleted - * by any mechanism. It just marks the object as not having a [my] - * command, and so prevents cleanup of that when the object itself is - * deleted. + * These callbacks are triggered when the object's [my] or [myclass] + * commands are deleted by any mechanism. They just mark the object as + * not having a [my] command or [myclass] command, and so prevent cleanup + * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ @@ -803,6 +803,14 @@ MyDeleted( oPtr->myCommand = NULL; } + +static void +MyClassDeleted( + ClientData clientData) +{ + Object *oPtr = clientData; + oPtr->myclassCommand = NULL; +} /* * ---------------------------------------------------------------------- @@ -2501,7 +2509,7 @@ TclOOInvokeObject( /* * ---------------------------------------------------------------------- * - * MyClassObjCmd, MyClassNRObjCmd, MyClassDeletedCmd -- + * MyClassObjCmd, MyClassNRObjCmd -- * * Special trap door to allow an object to delegate simply to its class. * @@ -2534,14 +2542,6 @@ MyClassNRObjCmd( return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, NULL); } - -static void -MyClassDeletedCmd( - ClientData clientData) -{ - Object *oPtr = clientData; - oPtr->myclassCommand = NULL; -} /* * ---------------------------------------------------------------------- diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index d96ee76..4b58337 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -85,7 +85,7 @@ static const char *tclOOSetupScript = " ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" " }\n" " # Make the connection by forwarding\n" -" tailcall forward $name { :my:class} $name\n" +" tailcall forward $name myclass $name\n" "}\n" "proc ::oo::MixinClassDelegates {class} {\n" -- cgit v0.12 From 27110774bd87b00612e7c3ff97d7af542d364d42 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Jul 2018 08:45:00 +0000 Subject: Added direct tests for [myclass] --- tests/oo.test | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 7e0f12e..b2c269b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4845,6 +4845,59 @@ test oo-40.3 {TIP 500: private and unexport} -setup { } -cleanup { cls destroy } -result {{} {} foo {} foo {}} + +test oo-41.1 {TIP 478: myclass command, including class morphing} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method count {} { + my variable c + incr c + } + method act {} { + myclass count + } + } + cls1 create x + lappend result [x act] [x act] + cls1 create y + lappend result [y act] [y act] [x act] + oo::class create cls2 { + superclass cls1 + self method count {} { + my variable d + expr {1.0 * [incr d]} + } + } + oo::objdefine x {class cls2} + lappend result [x act] [y act] [x act] [y act] +} -cleanup { + parent destroy +} -result {1 2 3 4 5 1.0 6 2.0 7} +test oo-41.2 {TIP 478: myclass command cleanup} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method hi {} { + return "this is [self]" + } + method hi {} { + return "this is [self]" + } + } + cls1 create x + rename [info object namespace x]::my foo + rename [info object namespace x]::myclass bar + lappend result [cls1 hi] [x hi] [foo hi] [bar hi] + x destroy + lappend result [catch {foo hi}] [catch {bar hi}] +} -cleanup { + parent destroy +} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1} cleanupTests return -- cgit v0.12 From d0f8889c8f63ea1c95b2d89ad98354657cf2f10f Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Jul 2018 08:57:49 +0000 Subject: And another test --- tests/oo.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index b2c269b..e49ecb3 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4898,6 +4898,22 @@ test oo-41.2 {TIP 478: myclass command cleanup} -setup { } -cleanup { parent destroy } -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1} +test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method Hi {} { + return "this is [self]" + } + forward poke myclass Hi + } + cls1 create x + lappend result [catch {cls1 Hi}] [x poke] +} -cleanup { + parent destroy +} -result {1 {this is ::cls1}} cleanupTests return -- cgit v0.12 From 77aceb5c5fa1c705713e90b474e94be2799f233a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Jul 2018 15:46:33 +0000 Subject: Added more tests and made [initialize] an alternate spelling for [initialise]. --- doc/define.n | 2 ++ generic/tclOOScript.h | 45 +++++++++++++++++++++++++++------------------ tests/ooUtil.test | 45 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 18 deletions(-) diff --git a/doc/define.n b/doc/define.n index 860218f..6353d00 100644 --- a/doc/define.n +++ b/doc/define.n @@ -132,6 +132,8 @@ below), this command creates private forwarded methods. .RE .TP \fBinitialise\fI script\fR +.TP +\fBinitialize\fI script\fR .VS TIP478 This evaluates \fIscript\fR in a context which supports local variables and where the current namespace is the instance namespace of the class object diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4b58337..ffdedb8 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -73,21 +73,6 @@ static const char *tclOOSetupScript = " string cat [info object namespace $class] {:: oo ::delegate}\n" "}\n" -"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n" -" # Create the method on the class if the caller gave arguments and body\n" -" set argc [llength [info level 0]]\n" -" if {$argc == 3} {\n" -" return -code error [string cat {wrong # args: should be \"}" -" [lindex [info level 0] 0] { name ?args body?\"}]\n" -" }\n" -" set cls [uplevel 1 self]\n" -" if {$argc == 4} {\n" -" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" -" }\n" -" # Make the connection by forwarding\n" -" tailcall forward $name myclass $name\n" -"}\n" - "proc ::oo::MixinClassDelegates {class} {\n" " if {![info object isa class $class]} {\n" " return\n" @@ -106,9 +91,33 @@ static const char *tclOOSetupScript = " ::oo::objdefine $class mixin -append $delegate\n" "}\n" -"::proc ::oo::define::initialise {body} {\n" -" set clsns [info object namespace [uplevel 1 self]]\n" -" tailcall apply [list {} $body $clsns]\n" +"::namespace eval ::oo::define {" +" ::proc classmethod {name {args {}} {body {}}} {\n" +" # Create the method on the class if the caller gave arguments and body\n" +" ::set argc [::llength [::info level 0]]\n" +" ::if {$argc == 3} {\n" +" ::return -code error [::string cat {wrong # args: should be \"}" +" [::lindex [::info level 0] 0] { name ?args body?\"}]\n" +" }\n" +" ::set cls [::uplevel 1 self]\n" +" ::if {$argc == 4} {\n" +" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" +" }\n" +" # Make the connection by forwarding\n" +" ::tailcall forward $name myclass $name\n" +" }\n" + +" ::proc initialise {body} {\n" +" ::set clsns [::info object namespace [::uplevel 1 self]]\n" +" ::tailcall apply [::list {} $body $clsns]\n" +" }\n" + +" # Make the initialise command appear with US spelling too\n" +" ::namespace export initialise\n" +" ::namespace eval tmp {::namespace import ::oo::define::initialise}\n" +" ::rename ::oo::define::tmp::initialise initialize\n" +" ::namespace delete tmp\n" +" ::namespace export -clear\n" "}\n" "::oo::define ::oo::Slot {\n" diff --git a/tests/ooUtil.test b/tests/ooUtil.test index e00c70c..e796637 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -286,6 +286,51 @@ test ooUtil-3.2 {TIP 478: class variables} -setup { } -cleanup { parent destroy } -result {124 125 126 127 128 129} +test ooUtil-3.3 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.3 {}} +} -body { + oo::class create ::cls { + superclass parent + initialize { + proc foobar-3.3 {} {return ok} + } + method calls {} { + list [catch foobar-3.3 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.3] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.3"} ok} +test ooUtil-3.4 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::appendToResultVar {}} + proc ::appendToResultVar args { + lappend ::result {*}$args + } + set result {} +} -body { + trace add execution oo::define::initialise enter appendToResultVar + oo::class create ::cls { + superclass parent + initialize {proc xyzzy {} {}} + } + return $result +} -cleanup { + catch { + trace remove execution oo::define::initialise enter appendToResultVar + } + rename ::appendToResultVar {} + parent destroy +} -result {{initialize {proc xyzzy {} {}}} enter} +test ooUtil-3.5 {TIP 478: class initialisation} -body { + oo::define oo::object { + ::list [::namespace which initialise] [::namespace which initialize] \ + [::namespace origin initialise] [::namespace origin initialize] + } +} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} test ooUtil-4.1 {TIP 478: singleton} -setup { oo::class create parent -- cgit v0.12 From d87884d51b4fcfc7d9a09febe9a351dad983d732 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2018 15:01:30 +0000 Subject: Make it much easier to maintain the TclOO initialisation script. --- generic/tclOOScript.h | 44 ++++++------ generic/tclOOScript.tcl | 183 ++++++++++++++++++++++++++++++++++++++++++++++++ tools/makeHeader.tcl | 164 +++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 9 +++ 4 files changed, 379 insertions(+), 21 deletions(-) create mode 100644 generic/tclOOScript.tcl create mode 100644 tools/makeHeader.tcl diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index ffdedb8..1f345fb 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -21,16 +21,17 @@ */ static const char *tclOOSetupScript = +/* !BEGIN!: Do not edit below this line. */ "::proc ::oo::Helpers::callback {method args} {\n" " list [uplevel 1 {namespace which my}] $method {*}$args\n" "}\n" - +"\n" "::proc ::oo::Helpers::mymethod {method args} {\n" " list [uplevel 1 {namespace which my}] $method {*}$args\n" "}\n" - +"\n" "::proc ::oo::Helpers::classvariable {name args} {\n" -" # Get a reference to the class's namespace\n" +" # Get a reference to the class\'s namespace\n" " set ns [info object namespace [uplevel 1 {self class}]]\n" " # Double up the list of variable names\n" " foreach v [list $name {*}$args] {\n" @@ -42,10 +43,10 @@ static const char *tclOOSetupScript = " }\n" " lappend vs $v $v\n" " }\n" -" # Lastly, link the caller's local variables to the class's variables\n" +" # Lastly, link the caller\'s local variables to the class\'s variables\n" " tailcall namespace upvar $ns {*}$vs\n" "}\n" - +"\n" "::proc ::oo::Helpers::link {args} {\n" " set ns [uplevel 1 {namespace current}]\n" " foreach link $args {\n" @@ -68,11 +69,11 @@ static const char *tclOOSetupScript = " rename $cmd {}\n" " }\n" "}\n" - +"\n" "::proc ::oo::DelegateName {class} {\n" " string cat [info object namespace $class] {:: oo ::delegate}\n" "}\n" - +"\n" "proc ::oo::MixinClassDelegates {class} {\n" " if {![info object isa class $class]} {\n" " return\n" @@ -81,7 +82,7 @@ static const char *tclOOSetupScript = " if {![info object isa class $delegate]} {\n" " return\n" " }\n" -" foreach c [info class superclass $class] {" +" foreach c [info class superclass $class] {\n" " set d [::oo::DelegateName $c]\n" " if {![info object isa class $d]} {\n" " continue\n" @@ -90,14 +91,14 @@ static const char *tclOOSetupScript = " }\n" " ::oo::objdefine $class mixin -append $delegate\n" "}\n" - -"::namespace eval ::oo::define {" +"\n" +"::namespace eval ::oo::define {\n" " ::proc classmethod {name {args {}} {body {}}} {\n" " # Create the method on the class if the caller gave arguments and body\n" " ::set argc [::llength [::info level 0]]\n" " ::if {$argc == 3} {\n" -" ::return -code error [::string cat {wrong # args: should be \"}" -" [::lindex [::info level 0] 0] { name ?args body?\"}]\n" +" ::return -code error [::string cat {wrong # args: should be \"} \\\n" +" [::lindex [::info level 0] 0] { name \?args body\?\"}]\n" " }\n" " ::set cls [::uplevel 1 self]\n" " ::if {$argc == 4} {\n" @@ -106,12 +107,12 @@ static const char *tclOOSetupScript = " # Make the connection by forwarding\n" " ::tailcall forward $name myclass $name\n" " }\n" - +"\n" " ::proc initialise {body} {\n" " ::set clsns [::info object namespace [::uplevel 1 self]]\n" " ::tailcall apply [::list {} $body $clsns]\n" " }\n" - +"\n" " # Make the initialise command appear with US spelling too\n" " ::namespace export initialise\n" " ::namespace eval tmp {::namespace import ::oo::define::initialise}\n" @@ -119,11 +120,11 @@ static const char *tclOOSetupScript = " ::namespace delete tmp\n" " ::namespace export -clear\n" "}\n" - +"\n" "::oo::define ::oo::Slot {\n" " method Get {} {return -code error unimplemented}\n" " method Set list {return -code error unimplemented}\n" - +"\n" " method -set args {tailcall my Set $args}\n" " method -append args {\n" " set current [uplevel 1 [list [namespace which my] Get]]\n" @@ -131,7 +132,7 @@ static const char *tclOOSetupScript = " }\n" " method -clear {} {tailcall my Set {}}\n" " forward --default-operation my -append\n" - +"\n" " method unknown {args} {\n" " set def --default-operation\n" " if {[llength $args] == 0} {\n" @@ -141,7 +142,7 @@ static const char *tclOOSetupScript = " }\n" " next {*}$args\n" " }\n" - +"\n" " export -set -append -clear\n" " unexport unknown destroy\n" "}\n" @@ -149,7 +150,7 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" - +"\n" "::oo::define ::oo::class method {originObject} {\n" " next $originObject\n" " # Rebuild the class inheritance delegation class\n" @@ -162,7 +163,7 @@ static const char *tclOOSetupScript = " }]\n" " }\n" "}\n" - +"\n" "::oo::class create ::oo::singleton {\n" " superclass ::oo::class\n" " variable object\n" @@ -180,11 +181,12 @@ static const char *tclOOSetupScript = " return $object\n" " }\n" "}\n" - +"\n" "::oo::class create ::oo::abstract {\n" " superclass ::oo::class\n" " unexport create createWithNamespace new\n" "}\n" +/* !END!: Do not edit above this line. */ ; /* diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl new file mode 100644 index 0000000..e0af23f --- /dev/null +++ b/generic/tclOOScript.tcl @@ -0,0 +1,183 @@ +# tclOOScript.h -- +# +# This file contains support scripts for TclOO. They are defined here so +# that the code can be definitely run even in safe interpreters; TclOO's +# core setup is safe. +# +# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2013 Andreas Kupries +# Copyright (c) 2017 Gerald Lester +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +::proc ::oo::Helpers::callback {method args} { + list [uplevel 1 {namespace which my}] $method {*}$args +} + +::proc ::oo::Helpers::mymethod {method args} { + list [uplevel 1 {namespace which my}] $method {*}$args +} + +::proc ::oo::Helpers::classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}] + } + if {[string match *::* $v]} { + return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs +} + +::proc ::oo::Helpers::link {args} { + set ns [uplevel 1 {namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } else { + lassign $link src + set dst $src + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src] + } + return +} +::proc ::oo::Helpers::Unlink {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } +} + +::proc ::oo::DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} +} + +proc ::oo::MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [::oo::DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [::oo::DelegateName $c] + if {![info object isa class $d]} { + continue + } + ::oo::define $delegate superclass -append $d + } + ::oo::objdefine $class mixin -append $delegate +} + +::namespace eval ::oo::define { + ::proc classmethod {name {args {}} {body {}}} { + # Create the method on the class if the caller gave arguments and body + ::set argc [::llength [::info level 0]] + ::if {$argc == 3} { + ::return -code error [::string cat {wrong # args: should be "} \ + [::lindex [::info level 0] 0] { name ?args body?"}] + } + ::set cls [::uplevel 1 self] + ::if {$argc == 4} { + ::oo::define [::oo::DelegateName $cls] method $name $args $body + } + # Make the connection by forwarding + ::tailcall forward $name myclass $name + } + + ::proc initialise {body} { + ::set clsns [::info object namespace [::uplevel 1 self]] + ::tailcall apply [::list {} $body $clsns] + } + + # Make the initialise command appear with US spelling too + ::namespace export initialise + ::namespace eval tmp {::namespace import ::oo::define::initialise} + ::rename ::oo::define::tmp::initialise initialize + ::namespace delete tmp + ::namespace export -clear +} + +::oo::define ::oo::Slot { + method Get {} {return -code error unimplemented} + method Set list {return -code error unimplemented} + + method -set args {tailcall my Set $args} + method -append args { + set current [uplevel 1 [list [namespace which my] Get]] + tailcall my Set [list {*}$current {*}$args] + } + method -clear {} {tailcall my Set {}} + forward --default-operation my -append + + method unknown {args} { + set def --default-operation + if {[llength $args] == 0} { + tailcall my $def + } elseif {![string match -* [lindex $args 0]]} { + tailcall my $def {*}$args + } + next {*}$args + } + + export -set -append -clear + unexport unknown destroy +} + +::oo::objdefine ::oo::define::superclass forward --default-operation my -set +::oo::objdefine ::oo::define::mixin forward --default-operation my -set +::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set + +::oo::define ::oo::class method {originObject} { + next $originObject + # Rebuild the class inheritance delegation class + set originDelegate [::oo::DelegateName $originObject] + set targetDelegate [::oo::DelegateName [self]] + if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} { + ::oo::copy $originDelegate $targetDelegate + ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } +} + +::oo::class create ::oo::singleton { + superclass ::oo::class + variable object + unexport create createWithNamespace + method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object method destroy {} { + return -code error {may not destroy a singleton object} + } + ::oo::objdefine $object method {originObject} { + return -code error {may not clone a singleton object} + } + } + return $object + } +} + +::oo::class create ::oo::abstract { + superclass ::oo::class + unexport create createWithNamespace new +} + +# Local Variables: +# mode: tcl +# c-basic-offset: 4 +# fill-column: 78 +# End: diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl new file mode 100644 index 0000000..8af35fc --- /dev/null +++ b/tools/makeHeader.tcl @@ -0,0 +1,164 @@ +# makeHeader.tcl -- +# +# This script generates embeddable C source (in a .h file) from a .tcl +# script. +# +# Copyright (c) 2018 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6 + +namespace eval makeHeader { + + #################################################################### + # + # mapSpecial -- + # Transform a single line so that it is able to be put in a C string. + # + proc mapSpecial {str} { + # All Tcl metacharacters and key C backslash sequences + set MAP { + \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\? + \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v + } + set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]} + + subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM] + } + + #################################################################### + # + # processScript -- + # Transform a whole sequence of lines with [mapSpecial]. + # + proc processScript {scriptLines} { + lmap line $scriptLines { + format {"%s"} [mapSpecial $line\n] + } + } + + #################################################################### + # + # updateTemplate -- + # Rewrite a template to contain the content from the input script. + # + proc updateTemplate {dataVar scriptLines} { + set BEGIN "*!BEGIN!: Do not edit below this line.*" + set END "*!END!: Do not edit above this line.*" + + upvar 1 $dataVar data + + set from [lsearch -glob $data $BEGIN] + set to [lsearch -glob $data $END] + if {$from == -1 || $to == -1 || $from >= $to} { + throw BAD "not a template" + } + + set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]] + } + + #################################################################### + # + # stripSurround -- + # Removes the header and footer comments from a (line-split list of + # lines of) Tcl script code. + # + proc stripSurround {lines} { + set RE {^\s*$|^#} + set state 0 + set lines [lmap line [lreverse $lines] { + if {!$state && [regexp $RE $line]} continue { + set state 1 + set line + } + }] + return [lmap line [lreverse $lines] { + if {$state && [regexp $RE $line]} continue { + set state 0 + set line + } + }] + } + + #################################################################### + # + # updateTemplateFile -- + # Rewrites a template file with the lines of the given script. + # + proc updateTemplateFile {headerFile scriptLines} { + set f [open $headerFile "r+"] + try { + set content [split [chan read -nonewline $f] "\n"] + updateTemplate content [stripSurround $scriptLines] + chan seek $f 0 + chan puts $f [join $content \n] + chan truncate $f + } trap BAD msg { + # Add the filename to the message + throw BAD "${headerFile}: $msg" + } finally { + chan close $f + } + } + + #################################################################### + # + # readScript -- + # Read a script from a file and return its lines. + # + proc readScript {script} { + set f [open $script] + try { + chan configure $f -encoding utf-8 + return [split [string trim [chan read $f]] "\n"] + } finally { + chan close $f + } + } + + #################################################################### + # + # run -- + # The main program of this script. + # + proc run {args} { + try { + if {[llength $args] != 2} { + throw ARGS "inputTclScript templateFile" + } + lassign $args inputTclScript templateFile + + puts "Inserting $inputTclScript into $templateFile" + set scriptLines [readScript $inputTclScript] + updateTemplateFile $templateFile $scriptLines + exit 0 + } trap ARGS msg { + puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\"" + exit 2 + } trap BAD msg { + puts stderr $msg + exit 1 + } trap POSIX msg { + puts stderr $msg + exit 1 + } on error {- opts} { + puts stderr [dict get $opts -errorinfo] + exit 3 + } + } +} + +######################################################################## +# +# Launch the main program +# +if {[info script] eq $::argv0} { + makeHeader::run {*}$::argv +} + +# Local-Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/unix/Makefile.in b/unix/Makefile.in index e4d77e6..6ae2b0d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1895,6 +1895,11 @@ $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls @echo "Developers may want to run \"make genstubs\" to regenerate." @echo "This warning can be safely ignored, do not report as a bug!" +$(GENERIC_DIR)/tclOOScript.h: $(GENERIC_DIR)/tclOOScript.tcl + @echo "Warning: tclOOScript.h may be out of date." + @echo "Developers may want to run \"make genscript\" to regenerate." + @echo "This warning can be safely ignored, do not report as a bug!" + genstubs: $(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \ @@ -1902,6 +1907,10 @@ genstubs: $(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tclOO.decls +genscript: + $(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \ + $(GENERIC_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h + # # Target to check that all exported functions have an entry in the stubs # tables. -- cgit v0.12 From ed3e9c60bac115e7ad38b1169dacc8bf974e99d2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2018 20:14:04 +0000 Subject: Combine the two bits of scripted code inside TclOO's definition into one. --- generic/tclOO.c | 14 +--- generic/tclOOScript.h | 215 +++++++++++++++++++++++++++--------------------- generic/tclOOScript.tcl | 188 +++++++++++++++++++++++++++--------------- tools/makeHeader.tcl | 2 +- 4 files changed, 244 insertions(+), 175 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 630e977..7702b2b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -312,7 +312,7 @@ InitFoundation( ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); - Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; @@ -392,18 +392,6 @@ InitFoundation( } /* - * Create the default method implementation, used when 'oo::copy' - * is called to finish the copying of one object to another. - */ - - TclNewLiteralStringObj(argsPtr, "originObject"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(clonedBody, -1); - TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, - bodyPtr, NULL); - TclDecrRefCount(argsPtr); - - /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 1f345fb..d89e81a 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -22,74 +22,103 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ -"::proc ::oo::Helpers::callback {method args} {\n" -" list [uplevel 1 {namespace which my}] $method {*}$args\n" -"}\n" +"::namespace eval ::oo::Helpers {\n" +" ::namespace path {}\n" "\n" -"::proc ::oo::Helpers::mymethod {method args} {\n" -" list [uplevel 1 {namespace which my}] $method {*}$args\n" -"}\n" +" proc callback {method args} {\n" +" list [uplevel 1 {::namespace which my}] $method {*}$args\n" +" }\n" "\n" -"::proc ::oo::Helpers::classvariable {name args} {\n" -" # Get a reference to the class\'s namespace\n" -" set ns [info object namespace [uplevel 1 {self class}]]\n" -" # Double up the list of variable names\n" -" foreach v [list $name {*}$args] {\n" -" if {[string match *(*) $v]} {\n" -" return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n" -" }\n" -" if {[string match *::* $v]} {\n" -" return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n" -" }\n" -" lappend vs $v $v\n" +" proc mymethod {method args} {\n" +" list [uplevel 1 {::namespace which my}] $method {*}$args\n" " }\n" -" # Lastly, link the caller\'s local variables to the class\'s variables\n" -" tailcall namespace upvar $ns {*}$vs\n" -"}\n" "\n" -"::proc ::oo::Helpers::link {args} {\n" -" set ns [uplevel 1 {namespace current}]\n" -" foreach link $args {\n" -" if {[llength $link] == 2} {\n" -" lassign $link src dst\n" -" } else {\n" -" lassign $link src\n" -" set dst $src\n" -" }\n" -" if {![string match ::* $src]} {\n" -" set src [string cat $ns :: $src]\n" +" proc classvariable {name args} {\n" +" # Get a reference to the class\'s namespace\n" +" set ns [info object namespace [uplevel 1 {self class}]]\n" +" # Double up the list of variable names\n" +" foreach v [list $name {*}$args] {\n" +" if {[string match *(*) $v]} {\n" +" variable \n" +" return -code error [format \\\n" +" {bad variable name \"%s\": can\'t create a scalar variable that looks like an array element} \\\n" +" $v]\n" +" }\n" +" if {[string match *::* $v]} {\n" +" return -code error [format \\\n" +" {bad variable name \"%s\": can\'t create a local variable with a namespace separator in it} \\\n" +" $v]\n" +" }\n" +" lappend vs $v $v\n" " }\n" -" interp alias {} $src {} ${ns}::my $dst\n" -" trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n" +" # Lastly, link the caller\'s local variables to the class\'s variables\n" +" tailcall namespace upvar $ns {*}$vs\n" " }\n" -" return\n" -"}\n" -"::proc ::oo::Helpers::Unlink {cmd args} {\n" -" if {[namespace which $cmd] ne {}} {\n" -" rename $cmd {}\n" +"\n" +" proc link {args} {\n" +" set ns [uplevel 1 {::namespace current}]\n" +" foreach link $args {\n" +" if {[llength $link] == 2} {\n" +" lassign $link src dst\n" +" } else {\n" +" lassign $link src\n" +" set dst $src\n" +" }\n" +" if {![string match ::* $src]} {\n" +" set src [string cat $ns :: $src]\n" +" }\n" +" interp alias {} $src {} ${ns}::my $dst\n" +" trace add command ${ns}::my delete [list \\\n" +" ::oo::UnlinkLinkedCommand $src]\n" +" }\n" +" return\n" " }\n" "}\n" "\n" -"::proc ::oo::DelegateName {class} {\n" -" string cat [info object namespace $class] {:: oo ::delegate}\n" -"}\n" +"::namespace eval ::oo {\n" +" proc UnlinkLinkedCommand {cmd args} {\n" +" if {[namespace which $cmd] ne {}} {\n" +" rename $cmd {}\n" +" }\n" +" }\n" "\n" -"proc ::oo::MixinClassDelegates {class} {\n" -" if {![info object isa class $class]} {\n" -" return\n" +" proc DelegateName {class} {\n" +" string cat [info object namespace $class] {:: oo ::delegate}\n" " }\n" -" set delegate [::oo::DelegateName $class]\n" -" if {![info object isa class $delegate]} {\n" -" return\n" +"\n" +" proc MixinClassDelegates {class} {\n" +" if {![info object isa class $class]} {\n" +" return\n" +" }\n" +" set delegate [DelegateName $class]\n" +" if {![info object isa class $delegate]} {\n" +" return\n" +" }\n" +" foreach c [info class superclass $class] {\n" +" set d [DelegateName $c]\n" +" if {![info object isa class $d]} {\n" +" continue\n" +" }\n" +" define $delegate superclass -append $d\n" +" }\n" +" objdefine $class mixin -append $delegate\n" " }\n" -" foreach c [info class superclass $class] {\n" -" set d [::oo::DelegateName $c]\n" -" if {![info object isa class $d]} {\n" -" continue\n" +"\n" +" proc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" +" # Rebuild the class inheritance delegation class\n" +" set originDelegate [DelegateName $originObject]\n" +" set targetDelegate [DelegateName $targetObject]\n" +" if {\n" +" [info object isa class $originDelegate]\n" +" && ![info object isa class $targetDelegate]\n" +" } then {\n" +" copy $originDelegate $targetDelegate\n" +" objdefine $targetObject mixin -set \\\n" +" {*}[lmap c [info object mixin $targetObject] {\n" +" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" +" }]\n" " }\n" -" ::oo::define $delegate superclass -append $d\n" " }\n" -" ::oo::objdefine $class mixin -append $delegate\n" "}\n" "\n" "::namespace eval ::oo::define {\n" @@ -97,8 +126,9 @@ static const char *tclOOSetupScript = " # Create the method on the class if the caller gave arguments and body\n" " ::set argc [::llength [::info level 0]]\n" " ::if {$argc == 3} {\n" -" ::return -code error [::string cat {wrong # args: should be \"} \\\n" -" [::lindex [::info level 0] 0] { name \?args body\?\"}]\n" +" ::return -code error [::format \\\n" +" {wrong # args: should be \"%s name \?args body\?\"} \\\n" +" [::lindex [::info level 0] 0]]\n" " }\n" " ::set cls [::uplevel 1 self]\n" " ::if {$argc == 4} {\n" @@ -151,17 +181,43 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" "\n" +"::oo::define ::oo::object method {originObject} {\n" +" # Copy over the procedures from the original namespace\n" +" foreach p [info procs [info object namespace $originObject]::*] {\n" +" set args [info args $p]\n" +" set idx -1\n" +" foreach a $args {\n" +" if {[info default $p $a d]} {\n" +" lset args [incr idx] [list $a $d]\n" +" } else {\n" +" lset args [incr idx] [list $a]\n" +" }\n" +" }\n" +" set b [info body $p]\n" +" set p [namespace tail $p]\n" +" proc $p $args $b\n" +" }\n" +" # Copy over the variables from the original namespace\n" +" foreach v [info vars [info object namespace $originObject]::*] {\n" +" upvar 0 $v vOrigin\n" +" namespace upvar [namespace current] [namespace tail $v] vNew\n" +" if {[info exists vOrigin]} {\n" +" if {[array exists vOrigin]} {\n" +" array set vNew [array get vOrigin]\n" +" } else {\n" +" set vNew $vOrigin\n" +" }\n" +" }\n" +" }\n" +" # General commands, sub-namespaces and advancd variable config (traces,\n" +" # etc) are *not* copied over. Classes that want that should do it\n" +" # themselves.\n" +"}\n" +"\n" "::oo::define ::oo::class method {originObject} {\n" " next $originObject\n" " # Rebuild the class inheritance delegation class\n" -" set originDelegate [::oo::DelegateName $originObject]\n" -" set targetDelegate [::oo::DelegateName [self]]\n" -" if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n" -" ::oo::copy $originDelegate $targetDelegate\n" -" ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n" -" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" -" }]\n" -" }\n" +" ::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "}\n" "\n" "::oo::class create ::oo::singleton {\n" @@ -188,37 +244,6 @@ static const char *tclOOSetupScript = "}\n" /* !END!: Do not edit above this line. */ ; - -/* - * The body of the method of oo::object. - */ - -static const char *clonedBody = -"# Copy over the procedures from the original namespace\n" -"foreach p [info procs [info object namespace $originObject]::*] {\n" -" set args [info args $p]\n" -" set idx -1\n" -" foreach a $args {\n" -" lset args [incr idx]" -" [if {[info default $p $a d]} {list $a $d} {list $a}]\n" -" }\n" -" set b [info body $p]\n" -" set p [namespace tail $p]\n" -" proc $p $args $b\n" -"}\n" -"# Copy over the variables from the original namespace\n" -"foreach v [info vars [info object namespace $originObject]::*] {\n" -" upvar 0 $v vOrigin\n" -" namespace upvar [namespace current] [namespace tail $v] vNew\n" -" if {[info exists vOrigin]} {\n" -" if {[array exists vOrigin]} {\n" -" array set vNew [array get vOrigin]\n" -" } else {\n" -" set vNew $vOrigin\n" -" }\n" -" }\n" -"}\n" -; #endif /* TCL_OO_SCRIPT_H */ diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index e0af23f..c0b4d1f 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -11,74 +11,103 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -::proc ::oo::Helpers::callback {method args} { - list [uplevel 1 {namespace which my}] $method {*}$args -} +::namespace eval ::oo::Helpers { + ::namespace path {} -::proc ::oo::Helpers::mymethod {method args} { - list [uplevel 1 {namespace which my}] $method {*}$args -} + proc callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args + } -::proc ::oo::Helpers::classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}] - } - if {[string match *::* $v]} { - return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}] - } - lappend vs $v $v + proc mymethod {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs -} -::proc ::oo::Helpers::link {args} { - set ns [uplevel 1 {namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } else { - lassign $link src - set dst $src - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src] + proc classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + variable + return -code error [format \ + {bad variable name "%s": can't create a scalar variable that looks like an array element} \ + $v] + } + if {[string match *::* $v]} { + return -code error [format \ + {bad variable name "%s": can't create a local variable with a namespace separator in it} \ + $v] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs } - return -} -::proc ::oo::Helpers::Unlink {cmd args} { - if {[namespace which $cmd] ne {}} { - rename $cmd {} + + proc link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } else { + lassign $link src + set dst $src + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] + } + return } } -::proc ::oo::DelegateName {class} { - string cat [info object namespace $class] {:: oo ::delegate} -} +::namespace eval ::oo { + proc UnlinkLinkedCommand {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } + } -proc ::oo::MixinClassDelegates {class} { - if {![info object isa class $class]} { - return + proc DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} } - set delegate [::oo::DelegateName $class] - if {![info object isa class $delegate]} { - return + + proc MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [DelegateName $c] + if {![info object isa class $d]} { + continue + } + define $delegate superclass -append $d + } + objdefine $class mixin -append $delegate } - foreach c [info class superclass $class] { - set d [::oo::DelegateName $c] - if {![info object isa class $d]} { - continue - } - ::oo::define $delegate superclass -append $d + + proc UpdateClassDelegatesAfterClone {originObject targetObject} { + # Rebuild the class inheritance delegation class + set originDelegate [DelegateName $originObject] + set targetDelegate [DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + copy $originDelegate $targetDelegate + objdefine $targetObject mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } } - ::oo::objdefine $class mixin -append $delegate } ::namespace eval ::oo::define { @@ -86,8 +115,9 @@ proc ::oo::MixinClassDelegates {class} { # Create the method on the class if the caller gave arguments and body ::set argc [::llength [::info level 0]] ::if {$argc == 3} { - ::return -code error [::string cat {wrong # args: should be "} \ - [::lindex [::info level 0] 0] { name ?args body?"}] + ::return -code error [::format \ + {wrong # args: should be "%s name ?args body?"} \ + [::lindex [::info level 0] 0]] } ::set cls [::uplevel 1 self] ::if {$argc == 4} { @@ -140,17 +170,43 @@ proc ::oo::MixinClassDelegates {class} { ::oo::objdefine ::oo::define::mixin forward --default-operation my -set ::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set +::oo::define ::oo::object method {originObject} { + # Copy over the procedures from the original namespace + foreach p [info procs [info object namespace $originObject]::*] { + set args [info args $p] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] + } + } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + foreach v [info vars [info object namespace $originObject]::*] { + upvar 0 $v vOrigin + namespace upvar [namespace current] [namespace tail $v] vNew + if {[info exists vOrigin]} { + if {[array exists vOrigin]} { + array set vNew [array get vOrigin] + } else { + set vNew $vOrigin + } + } + } + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. +} + ::oo::define ::oo::class method {originObject} { next $originObject # Rebuild the class inheritance delegation class - set originDelegate [::oo::DelegateName $originObject] - set targetDelegate [::oo::DelegateName [self]] - if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} { - ::oo::copy $originDelegate $targetDelegate - ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] { - if {$c eq $originDelegate} {set targetDelegate} {set c} - }] - } + ::oo::UpdateClassDelegatesAfterClone $originObject [self] } ::oo::class create ::oo::singleton { diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl index 8af35fc..5197da6 100644 --- a/tools/makeHeader.tcl +++ b/tools/makeHeader.tcl @@ -21,7 +21,7 @@ namespace eval makeHeader { # All Tcl metacharacters and key C backslash sequences set MAP { \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\? - \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v + \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t { } \v \\\\v } set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]} -- cgit v0.12 From 245151ad96d79fe7ec45da4d538d344edbfff4cb Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 11 Aug 2018 11:18:20 +0000 Subject: Improve script compilation. Prove that compilation works with safe interps. --- generic/tclOOScript.h | 416 +++++++++++++++++++++----------------------- generic/tclOOScript.tcl | 447 ++++++++++++++++++++++++++++++++++-------------- tests/ooUtil.test | 39 +++++ tools/makeHeader.tcl | 22 ++- 4 files changed, 572 insertions(+), 352 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index d89e81a..741a5c4 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -22,225 +22,205 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ -"::namespace eval ::oo::Helpers {\n" -" ::namespace path {}\n" -"\n" -" proc callback {method args} {\n" -" list [uplevel 1 {::namespace which my}] $method {*}$args\n" -" }\n" -"\n" -" proc mymethod {method args} {\n" -" list [uplevel 1 {::namespace which my}] $method {*}$args\n" -" }\n" -"\n" -" proc classvariable {name args} {\n" -" # Get a reference to the class\'s namespace\n" -" set ns [info object namespace [uplevel 1 {self class}]]\n" -" # Double up the list of variable names\n" -" foreach v [list $name {*}$args] {\n" -" if {[string match *(*) $v]} {\n" -" variable \n" -" return -code error [format \\\n" -" {bad variable name \"%s\": can\'t create a scalar variable that looks like an array element} \\\n" -" $v]\n" -" }\n" -" if {[string match *::* $v]} {\n" -" return -code error [format \\\n" -" {bad variable name \"%s\": can\'t create a local variable with a namespace separator in it} \\\n" -" $v]\n" -" }\n" -" lappend vs $v $v\n" -" }\n" -" # Lastly, link the caller\'s local variables to the class\'s variables\n" -" tailcall namespace upvar $ns {*}$vs\n" -" }\n" -"\n" -" proc link {args} {\n" -" set ns [uplevel 1 {::namespace current}]\n" -" foreach link $args {\n" -" if {[llength $link] == 2} {\n" -" lassign $link src dst\n" -" } else {\n" -" lassign $link src\n" -" set dst $src\n" -" }\n" -" if {![string match ::* $src]} {\n" -" set src [string cat $ns :: $src]\n" -" }\n" -" interp alias {} $src {} ${ns}::my $dst\n" -" trace add command ${ns}::my delete [list \\\n" -" ::oo::UnlinkLinkedCommand $src]\n" -" }\n" -" return\n" -" }\n" -"}\n" -"\n" "::namespace eval ::oo {\n" -" proc UnlinkLinkedCommand {cmd args} {\n" -" if {[namespace which $cmd] ne {}} {\n" -" rename $cmd {}\n" -" }\n" -" }\n" -"\n" -" proc DelegateName {class} {\n" -" string cat [info object namespace $class] {:: oo ::delegate}\n" -" }\n" -"\n" -" proc MixinClassDelegates {class} {\n" -" if {![info object isa class $class]} {\n" -" return\n" -" }\n" -" set delegate [DelegateName $class]\n" -" if {![info object isa class $delegate]} {\n" -" return\n" -" }\n" -" foreach c [info class superclass $class] {\n" -" set d [DelegateName $c]\n" -" if {![info object isa class $d]} {\n" -" continue\n" -" }\n" -" define $delegate superclass -append $d\n" -" }\n" -" objdefine $class mixin -append $delegate\n" -" }\n" -"\n" -" proc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" -" # Rebuild the class inheritance delegation class\n" -" set originDelegate [DelegateName $originObject]\n" -" set targetDelegate [DelegateName $targetObject]\n" -" if {\n" -" [info object isa class $originDelegate]\n" -" && ![info object isa class $targetDelegate]\n" -" } then {\n" -" copy $originDelegate $targetDelegate\n" -" objdefine $targetObject mixin -set \\\n" -" {*}[lmap c [info object mixin $targetObject] {\n" -" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" -" }]\n" -" }\n" -" }\n" -"}\n" -"\n" -"::namespace eval ::oo::define {\n" -" ::proc classmethod {name {args {}} {body {}}} {\n" -" # Create the method on the class if the caller gave arguments and body\n" -" ::set argc [::llength [::info level 0]]\n" -" ::if {$argc == 3} {\n" -" ::return -code error [::format \\\n" -" {wrong # args: should be \"%s name \?args body\?\"} \\\n" -" [::lindex [::info level 0] 0]]\n" -" }\n" -" ::set cls [::uplevel 1 self]\n" -" ::if {$argc == 4} {\n" -" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n" -" }\n" -" # Make the connection by forwarding\n" -" ::tailcall forward $name myclass $name\n" -" }\n" -"\n" -" ::proc initialise {body} {\n" -" ::set clsns [::info object namespace [::uplevel 1 self]]\n" -" ::tailcall apply [::list {} $body $clsns]\n" -" }\n" -"\n" -" # Make the initialise command appear with US spelling too\n" -" ::namespace export initialise\n" -" ::namespace eval tmp {::namespace import ::oo::define::initialise}\n" -" ::rename ::oo::define::tmp::initialise initialize\n" -" ::namespace delete tmp\n" -" ::namespace export -clear\n" -"}\n" -"\n" -"::oo::define ::oo::Slot {\n" -" method Get {} {return -code error unimplemented}\n" -" method Set list {return -code error unimplemented}\n" -"\n" -" method -set args {tailcall my Set $args}\n" -" method -append args {\n" -" set current [uplevel 1 [list [namespace which my] Get]]\n" -" tailcall my Set [list {*}$current {*}$args]\n" -" }\n" -" method -clear {} {tailcall my Set {}}\n" -" forward --default-operation my -append\n" -"\n" -" method unknown {args} {\n" -" set def --default-operation\n" -" if {[llength $args] == 0} {\n" -" tailcall my $def\n" -" } elseif {![string match -* [lindex $args 0]]} {\n" -" tailcall my $def {*}$args\n" -" }\n" -" next {*}$args\n" -" }\n" -"\n" -" export -set -append -clear\n" -" unexport unknown destroy\n" -"}\n" -"\n" -"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" -"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" -"\n" -"::oo::define ::oo::object method {originObject} {\n" -" # Copy over the procedures from the original namespace\n" -" foreach p [info procs [info object namespace $originObject]::*] {\n" -" set args [info args $p]\n" -" set idx -1\n" -" foreach a $args {\n" -" if {[info default $p $a d]} {\n" -" lset args [incr idx] [list $a $d]\n" -" } else {\n" -" lset args [incr idx] [list $a]\n" -" }\n" -" }\n" -" set b [info body $p]\n" -" set p [namespace tail $p]\n" -" proc $p $args $b\n" -" }\n" -" # Copy over the variables from the original namespace\n" -" foreach v [info vars [info object namespace $originObject]::*] {\n" -" upvar 0 $v vOrigin\n" -" namespace upvar [namespace current] [namespace tail $v] vNew\n" -" if {[info exists vOrigin]} {\n" -" if {[array exists vOrigin]} {\n" -" array set vNew [array get vOrigin]\n" -" } else {\n" -" set vNew $vOrigin\n" -" }\n" -" }\n" -" }\n" -" # General commands, sub-namespaces and advancd variable config (traces,\n" -" # etc) are *not* copied over. Classes that want that should do it\n" -" # themselves.\n" -"}\n" -"\n" -"::oo::define ::oo::class method {originObject} {\n" -" next $originObject\n" -" # Rebuild the class inheritance delegation class\n" -" ::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" -"}\n" -"\n" -"::oo::class create ::oo::singleton {\n" -" superclass ::oo::class\n" -" variable object\n" -" unexport create createWithNamespace\n" -" method new args {\n" -" if {![info exists object] || ![info object isa object $object]} {\n" -" set object [next {*}$args]\n" -" ::oo::objdefine $object method destroy {} {\n" -" return -code error {may not destroy a singleton object}\n" -" }\n" -" ::oo::objdefine $object method {originObject} {\n" -" return -code error {may not clone a singleton object}\n" -" }\n" -" }\n" -" return $object\n" -" }\n" -"}\n" -"\n" -"::oo::class create ::oo::abstract {\n" -" superclass ::oo::class\n" -" unexport create createWithNamespace new\n" +"\t::namespace path {}\n" +"\tnamespace eval Helpers {\n" +"\t\t::namespace path {}\n" +"\t\tproc callback {method args} {\n" +"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" +"\t\t}\n" +"\t\tnamespace export callback\n" +"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" +"\t\tnamespace export -clear\n" +"\t\trename tmp::callback mymethod\n" +"\t\tnamespace delete tmp\n" +"\t\tproc classvariable {name args} {\n" +"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" +"\t\t\tforeach v [list $name {*}$args] {\n" +"\t\t\t\tif {[string match *(*) $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tif {[string match *::* $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tlappend vs $v $v\n" +"\t\t\t}\n" +"\t\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t\t}\n" +"\t\tproc link {args} {\n" +"\t\t\tset ns [uplevel 1 {::namespace current}]\n" +"\t\t\tforeach link $args {\n" +"\t\t\t\tif {[llength $link] == 2} {\n" +"\t\t\t\t\tlassign $link src dst\n" +"\t\t\t\t} elseif {[llength $link] == 1} {\n" +"\t\t\t\t\tlassign $link src\n" +"\t\t\t\t\tset dst $src\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" +"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" +"\t\t\t\t}\n" +"\t\t\t\tif {![string match ::* $src]} {\n" +"\t\t\t\t\tset src [string cat $ns :: $src]\n" +"\t\t\t\t}\n" +"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" +"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" +"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" +"\t\t\t}\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t}\n" +"\tproc UnlinkLinkedCommand {cmd args} {\n" +"\t\tif {[namespace which $cmd] ne {}} {\n" +"\t\t\trename $cmd {}\n" +"\t\t}\n" +"\t}\n" +"\tproc DelegateName {class} {\n" +"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" +"\t}\n" +"\tproc MixinClassDelegates {class} {\n" +"\t\tif {![info object isa class $class]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tset delegate [DelegateName $class]\n" +"\t\tif {![info object isa class $delegate]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tforeach c [info class superclass $class] {\n" +"\t\t\tset d [DelegateName $c]\n" +"\t\t\tif {![info object isa class $d]} {\n" +"\t\t\t\tcontinue\n" +"\t\t\t}\n" +"\t\t\tdefine $delegate superclass -append $d\n" +"\t\t}\n" +"\t\tobjdefine $class mixin -append $delegate\n" +"\t}\n" +"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" +"\t\tset originDelegate [DelegateName $originObject]\n" +"\t\tset targetDelegate [DelegateName $targetObject]\n" +"\t\tif {\n" +"\t\t\t[info object isa class $originDelegate]\n" +"\t\t\t&& ![info object isa class $targetDelegate]\n" +"\t\t} then {\n" +"\t\t\tcopy $originDelegate $targetDelegate\n" +"\t\t\tobjdefine $targetObject mixin -set \\\n" +"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" +"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" +"\t\t\t\t}]\n" +"\t\t}\n" +"\t}\n" +"\tproc define::classmethod {name {args {}} {body {}}} {\n" +"\t\t::set argc [::llength [::info level 0]]\n" +"\t\t::if {$argc == 3} {\n" +"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" +"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" +"\t\t\t\t[::lindex [::info level 0] 0]]\n" +"\t\t}\n" +"\t\t::set cls [::uplevel 1 self]\n" +"\t\t::if {$argc == 4} {\n" +"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" +"\t\t}\n" +"\t\t::tailcall forward $name myclass $name\n" +"\t}\n" +"\tproc define::initialise {body} {\n" +"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" +"\t\t::tailcall apply [::list {} $body $clsns]\n" +"\t}\n" +"\tnamespace eval define {\n" +"\t\t::namespace export initialise\n" +"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" +"\t\t::namespace export -clear\n" +"\t\t::rename tmp::initialise initialize\n" +"\t\t::namespace delete tmp\n" +"\t}\n" +"\tdefine Slot {\n" +"\t\tmethod Get {} {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod Set list {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod -set args {tailcall my Set $args}\n" +"\t\tmethod -append args {\n" +"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n" +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" +"\t\t}\n" +"\t\tmethod -clear {} {tailcall my Set {}}\n" +"\t\tforward --default-operation my -append\n" +"\t\tmethod unknown {args} {\n" +"\t\t\tset def --default-operation\n" +"\t\t\tif {[llength $args] == 0} {\n" +"\t\t\t\ttailcall my $def\n" +"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" +"\t\t\t\ttailcall my $def {*}$args\n" +"\t\t\t}\n" +"\t\t\tnext {*}$args\n" +"\t\t}\n" +"\t\texport -set -append -clear\n" +"\t\tunexport unknown destroy\n" +"\t}\n" +"\tobjdefine define::superclass forward --default-operation my -set\n" +"\tobjdefine define::mixin forward --default-operation my -set\n" +"\tobjdefine objdefine::mixin forward --default-operation my -set\n" +"\tdefine object method {originObject} {\n" +"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" +"\t\t\tset args [info args $p]\n" +"\t\t\tset idx -1\n" +"\t\t\tforeach a $args {\n" +"\t\t\t\tif {[info default $p $a d]} {\n" +"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tlset args [incr idx] [list $a]\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\tset b [info body $p]\n" +"\t\t\tset p [namespace tail $p]\n" +"\t\t\tproc $p $args $b\n" +"\t\t}\n" +"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" +"\t\t\tupvar 0 $v vOrigin\n" +"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" +"\t\t\tif {[info exists vOrigin]} {\n" +"\t\t\t\tif {[array exists vOrigin]} {\n" +"\t\t\t\t\tarray set vNew [array get vOrigin]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tset vNew $vOrigin\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t}\n" +"\t}\n" +"\tdefine class method {originObject} {\n" +"\t\tnext $originObject\n" +"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" +"\t}\n" +"\tclass create singleton {\n" +"\t\tsuperclass class\n" +"\t\tvariable object\n" +"\t\tunexport create createWithNamespace\n" +"\t\tmethod new args {\n" +"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\t\tset object [next {*}$args]\n" +"\t\t\t\t::oo::objdefine $object {\n" +"\t\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\tmethod {originObject} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\treturn $object\n" +"\t\t}\n" +"\t}\n" +"\tclass create abstract {\n" +"\t\tsuperclass class\n" +"\t\tunexport create createWithNamespace new\n" +"\t}\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index c0b4d1f..d3706ce 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -11,70 +11,135 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -::namespace eval ::oo::Helpers { +::namespace eval ::oo { ::namespace path {} - proc callback {method args} { - list [uplevel 1 {::namespace which my}] $method {*}$args - } + # + # Commands that are made available to objects by default. + # + namespace eval Helpers { + ::namespace path {} - proc mymethod {method args} { - list [uplevel 1 {::namespace which my}] $method {*}$args - } + # ------------------------------------------------------------------ + # + # callback, mymethod -- + # + # Create a script prefix that calls a method on the current + # object. Same operation, two names. + # + # ------------------------------------------------------------------ - proc classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - variable - return -code error [format \ - {bad variable name "%s": can't create a scalar variable that looks like an array element} \ - $v] - } - if {[string match *::* $v]} { - return -code error [format \ - {bad variable name "%s": can't create a local variable with a namespace separator in it} \ - $v] - } - lappend vs $v $v + proc callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs - } - proc link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } else { - lassign $link src - set dst $src + # Make the [callback] command appear as [mymethod] too. + namespace export callback + namespace eval tmp {namespace import ::oo::Helpers::callback} + namespace export -clear + rename tmp::callback mymethod + namespace delete tmp + + # ------------------------------------------------------------------ + # + # classvariable -- + # + # Link to a variable in the class of the current object. + # + # ------------------------------------------------------------------ + + proc classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + set reason "can't create a scalar variable that looks like an array element" + return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ + [format {bad variable name "%s": %s} $v $reason] + } + if {[string match *::* $v]} { + set reason "can't create a local variable with a namespace separator in it" + return -code error -errorcode {TCL UPVAR INVERTED} \ + [format {bad variable name "%s": %s} $v $reason] + } + lappend vs $v $v } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs + } + + # ------------------------------------------------------------------ + # + # link -- + # + # Make a command that invokes a method on the current object. + # The name of the command and the name of the method match by + # default. + # + # ------------------------------------------------------------------ + + proc link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } elseif {[llength $link] == 1} { + lassign $link src + set dst $src + } else { + return -code error -errorcode {TCLOO CMDLINK FORMAT} \ + "bad link description; must only have one or two elements" + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] + return } - return } -} -::namespace eval ::oo { + # ---------------------------------------------------------------------- + # + # UnlinkLinkedCommand -- + # + # Callback used to remove linked command when the underlying mechanism + # that supports it is deleted. + # + # ---------------------------------------------------------------------- + proc UnlinkLinkedCommand {cmd args} { if {[namespace which $cmd] ne {}} { rename $cmd {} } } + # ---------------------------------------------------------------------- + # + # DelegateName -- + # + # Utility that gets the name of the class delegate for a class. It's + # trivial, but makes working with them much easier as delegate names are + # intentionally hard to create by accident. + # + # ---------------------------------------------------------------------- + proc DelegateName {class} { string cat [info object namespace $class] {:: oo ::delegate} } + # ---------------------------------------------------------------------- + # + # MixinClassDelegates -- + # + # Support code called *after* [oo::define] inside the constructor of a + # class that patches in the appropriate class delegates. + # + # ---------------------------------------------------------------------- + proc MixinClassDelegates {class} { if {![info object isa class $class]} { return @@ -93,6 +158,15 @@ objdefine $class mixin -append $delegate } + # ---------------------------------------------------------------------- + # + # UpdateClassDelegatesAfterClone -- + # + # Support code that is like [MixinClassDelegates] except for when a + # class is cloned. + # + # ---------------------------------------------------------------------- + proc UpdateClassDelegatesAfterClone {originObject targetObject} { # Rebuild the class inheritance delegation class set originDelegate [DelegateName $originObject] @@ -108,14 +182,24 @@ }] } } -} -::namespace eval ::oo::define { - ::proc classmethod {name {args {}} {body {}}} { + # ---------------------------------------------------------------------- + # + # oo::define::classmethod -- + # + # Defines a class method. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::classmethod {name {args {}} {body {}}} { # Create the method on the class if the caller gave arguments and body ::set argc [::llength [::info level 0]] ::if {$argc == 3} { - ::return -code error [::format \ + ::return -code error -errorcode {TCL WRONGARGS} [::format \ {wrong # args: should be "%s name ?args body?"} \ [::lindex [::info level 0] 0]] } @@ -127,109 +211,208 @@ ::tailcall forward $name myclass $name } - ::proc initialise {body} { + # ---------------------------------------------------------------------- + # + # oo::define::initialise, oo::define::initialize -- + # + # Do specific initialisation for a class. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::initialise {body} { ::set clsns [::info object namespace [::uplevel 1 self]] ::tailcall apply [::list {} $body $clsns] } - # Make the initialise command appear with US spelling too - ::namespace export initialise - ::namespace eval tmp {::namespace import ::oo::define::initialise} - ::rename ::oo::define::tmp::initialise initialize - ::namespace delete tmp - ::namespace export -clear -} + # Make the [initialise] definition appear as [initialize] too + namespace eval define { + ::namespace export initialise + ::namespace eval tmp {::namespace import ::oo::define::initialise} + ::namespace export -clear + ::rename tmp::initialise initialize + ::namespace delete tmp + } -::oo::define ::oo::Slot { - method Get {} {return -code error unimplemented} - method Set list {return -code error unimplemented} + # ---------------------------------------------------------------------- + # + # Slot -- + # + # The class of slot operations, which are basically lists at the low + # level of TclOO; this provides a more consistent interface to them. + # + # ---------------------------------------------------------------------- - method -set args {tailcall my Set $args} - method -append args { - set current [uplevel 1 [list [namespace which my] Get]] - tailcall my Set [list {*}$current {*}$args] - } - method -clear {} {tailcall my Set {}} - forward --default-operation my -append - - method unknown {args} { - set def --default-operation - if {[llength $args] == 0} { - tailcall my $def - } elseif {![string match -* [lindex $args 0]]} { - tailcall my $def {*}$args - } - next {*}$args - } + define Slot { + # ------------------------------------------------------------------ + # + # Slot Get -- + # + # Basic slot getter. Retrieves the contents of the slot. + # Particular slots must provide concrete non-erroring + # implementation. + # + # ------------------------------------------------------------------ - export -set -append -clear - unexport unknown destroy -} + method Get {} { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } -::oo::objdefine ::oo::define::superclass forward --default-operation my -set -::oo::objdefine ::oo::define::mixin forward --default-operation my -set -::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set - -::oo::define ::oo::object method {originObject} { - # Copy over the procedures from the original namespace - foreach p [info procs [info object namespace $originObject]::*] { - set args [info args $p] - set idx -1 - foreach a $args { - if {[info default $p $a d]} { - lset args [incr idx] [list $a $d] - } else { - lset args [incr idx] [list $a] + # ------------------------------------------------------------------ + # + # Slot Set -- + # + # Basic slot setter. Sets the contents of the slot. Particular + # slots must provide concrete non-erroring implementation. + # + # ------------------------------------------------------------------ + + method Set list { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot -set, -append, -clear, --default-operation -- + # + # Standard public slot operations. If a slot can't figure out + # what method to call directly, it uses --default-operation. + # + # ------------------------------------------------------------------ + + method -set args {tailcall my Set $args} + method -append args { + set current [uplevel 1 [list [namespace which my] Get]] + tailcall my Set [list {*}$current {*}$args] + } + method -clear {} {tailcall my Set {}} + + # Default handling + forward --default-operation my -append + method unknown {args} { + set def --default-operation + if {[llength $args] == 0} { + tailcall my $def + } elseif {![string match -* [lindex $args 0]]} { + tailcall my $def {*}$args } + next {*}$args } - set b [info body $p] - set p [namespace tail $p] - proc $p $args $b + + # Set up what is exported and what isn't + export -set -append -clear + unexport unknown destroy } - # Copy over the variables from the original namespace - foreach v [info vars [info object namespace $originObject]::*] { - upvar 0 $v vOrigin - namespace upvar [namespace current] [namespace tail $v] vNew - if {[info exists vOrigin]} { - if {[array exists vOrigin]} { - array set vNew [array get vOrigin] - } else { - set vNew $vOrigin + + # Set the default operation differently for these slots + objdefine define::superclass forward --default-operation my -set + objdefine define::mixin forward --default-operation my -set + objdefine objdefine::mixin forward --default-operation my -set + + # ---------------------------------------------------------------------- + # + # oo::object -- + # + # Handler for cloning objects that clones basic bits (only!) of the + # object's namespace. Non-procedures, traces, sub-namespaces, etc. need + # more complex (and class-specific) handling. + # + # ---------------------------------------------------------------------- + + define object method {originObject} { + # Copy over the procedures from the original namespace + foreach p [info procs [info object namespace $originObject]::*] { + set args [info args $p] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] + } + } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + foreach v [info vars [info object namespace $originObject]::*] { + upvar 0 $v vOrigin + namespace upvar [namespace current] [namespace tail $v] vNew + if {[info exists vOrigin]} { + if {[array exists vOrigin]} { + array set vNew [array get vOrigin] + } else { + set vNew $vOrigin + } } } + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. } - # General commands, sub-namespaces and advancd variable config (traces, - # etc) are *not* copied over. Classes that want that should do it - # themselves. -} -::oo::define ::oo::class method {originObject} { - next $originObject - # Rebuild the class inheritance delegation class - ::oo::UpdateClassDelegatesAfterClone $originObject [self] -} + # ---------------------------------------------------------------------- + # + # oo::class -- + # + # Handler for cloning classes, which fixes up the delegates. + # + # ---------------------------------------------------------------------- -::oo::class create ::oo::singleton { - superclass ::oo::class - variable object - unexport create createWithNamespace - method new args { - if {![info exists object] || ![info object isa object $object]} { - set object [next {*}$args] - ::oo::objdefine $object method destroy {} { - return -code error {may not destroy a singleton object} - } - ::oo::objdefine $object method {originObject} { - return -code error {may not clone a singleton object} - } - } - return $object + define class method {originObject} { + next $originObject + # Rebuild the class inheritance delegation class + ::oo::UpdateClassDelegatesAfterClone $originObject [self] } -} -::oo::class create ::oo::abstract { - superclass ::oo::class - unexport create createWithNamespace new + # ---------------------------------------------------------------------- + # + # oo::singleton -- + # + # A metaclass that is used to make classes that only permit one instance + # of them to exist. See singleton(n). + # + # ---------------------------------------------------------------------- + + class create singleton { + superclass class + variable object + unexport create createWithNamespace + method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not destroy a singleton object" + } + method {originObject} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not clone a singleton object" + } + } + } + return $object + } + } + + # ---------------------------------------------------------------------- + # + # oo::abstract -- + # + # A metaclass that is used to make classes that can't be directly + # instantiated. See abstract(n). + # + # ---------------------------------------------------------------------- + + class create abstract { + superclass class + unexport create createWithNamespace new + } } # Local Variables: diff --git a/tests/ooUtil.test b/tests/ooUtil.test index e796637..ff7093f 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -138,6 +138,45 @@ test ooUtil-1.7 {} -setup { } -cleanup { parent destroy } -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" +# Two tests to confirm that we correctly initialise the scripted part of TclOO +# in child interpreters. This is slightly tricky at the implementation level +# because we cannot count on either [source] or [open] being available. +test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { + set childinterp [interp create] +} -body { + $childinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is not the master interpreter + list [Table find foo bar] [info globals childinterp] + } +} -cleanup { + interp delete $childinterp +} -result {{::Table called with arguments: foo bar} {}} +test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { + set safeinterp [interp create -safe] +} -body { + $safeinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is a (basic) safe interpreter + list [Table find foo bar] [info commands source] + } +} -cleanup { + interp delete $safeinterp +} -result {{::Table called with arguments: foo bar} {}} test ooUtil-2.1 {TIP 478: callback generation} -setup { oo::class create parent diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl index 5197da6..e9b7ed1 100644 --- a/tools/makeHeader.tcl +++ b/tools/makeHeader.tcl @@ -21,7 +21,7 @@ namespace eval makeHeader { # All Tcl metacharacters and key C backslash sequences set MAP { \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\? - \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t { } \v \\\\v + \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v } set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]} @@ -30,12 +30,30 @@ namespace eval makeHeader { #################################################################### # + # compactLeadingSpaces -- + # Converts the leading whitespace on a line into a more compact form. + # + proc compactLeadingSpaces {line} { + set line [string map {\t { }} [string trimright $line]] + if {[regexp {^[ ]+} $line spaces]} { + regsub -all {[ ]{4}} $spaces \t replace + set len [expr {[string length $spaces] - 1}] + set line [string replace $line 0 $len $replace] + } + return $line + } + + #################################################################### + # # processScript -- # Transform a whole sequence of lines with [mapSpecial]. # proc processScript {scriptLines} { lmap line $scriptLines { - format {"%s"} [mapSpecial $line\n] + # Skip blank and comment lines; they're there in the original + # sources so we don't need to copy them over. + if {[regexp {^\s*(?:#|$)} $line]} continue + format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n] } } -- cgit v0.12 From f5efc84600e3a88460bdeb094d1cfa58ad5b3022 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 11 Aug 2018 12:01:06 +0000 Subject: Added a note about the genesis of the compiled header. --- generic/tclOOScript.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 741a5c4..e63bd86 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -18,6 +18,10 @@ /* * The scripted part of the definitions of TclOO. + * + * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which + * contains the commented version of everything; *this* file is automatically + * generated. */ static const char *tclOOSetupScript = -- cgit v0.12