Index: generic/gentclAPI.decls =================================================================== diff -u -rff41e1a0cb88c3aa7b96ca3b67b27043794991b0 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision ff41e1a0cb88c3aa7b96ca3b67b27043794991b0) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -30,7 +30,7 @@ {-argName "arg" -required 0 -type tclobj} } xotclCmd configure XOTclConfigureCmd { - {-argName "configureoption" -required 1 -type "filter|softrecreate|cacheinterface"} + {-argName "configureoption" -required 1 -type "filter|softrecreate|cacheinterface|objectsystems"} {-argName "value" -required 0 -type tclobj} } xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { @@ -80,7 +80,7 @@ } xotclCmd is XOTclIsCmd { {-argName "object" -required 1 -type tclobj} - {-argName "objectkind" -type "type|object|class|metaclass|mixin"} + {-argName "objectkind" -type "type|object|class|baseclass|metaclass|mixin"} {-argName "value" -required 0 -type tclobj} } xotclCmd method XOTclMethodCmd { Index: generic/predefined.h =================================================================== diff -u -r6b3921be54ad92034e563a09300ab2e4f49645aa -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- generic/predefined.h (.../predefined.h) (revision 6b3921be54ad92034e563a09300ab2e4f49645aa) +++ generic/predefined.h (.../predefined.h) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -128,7 +128,7 @@ ".method $methname $arglist $body}}\n" "proc ::xotcl::unsetExitHandler {} {\n" "proc ::xotcl::__exitHandler {} {}}\n" -"proc ::xotcl::setExitHandler {newbody} {proc ::xotcl::__exitHandler {} $newbody}\n" +"proc ::xotcl::setExitHandler {newbody} {::proc ::xotcl::__exitHandler {} $newbody}\n" "proc ::xotcl::getExitHandler {} {::info body ::xotcl::__exitHandler}\n" "::xotcl::unsetExitHandler\n" "namespace export Object Class}\n" @@ -192,7 +192,7 @@ "if {[info exists default]} {\n" "::xotcl::setinstvar ${class}::slot::$att default $default\n" "unset default}\n" -"$class setter $att}\n" +"::xotcl::setter $class $att}\n" "foreach att $definitions {\n" "if {[llength $att]>1} {foreach {att default} $att break}\n" "if {[info exists default]} {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r6b3921be54ad92034e563a09300ab2e4f49645aa -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- generic/predefined.xotcl (.../predefined.xotcl) (revision 6b3921be54ad92034e563a09300ab2e4f49645aa) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -260,7 +260,7 @@ # clients should append exit handlers to this proc body } } - proc ::xotcl::setExitHandler {newbody} {proc ::xotcl::__exitHandler {} $newbody} + proc ::xotcl::setExitHandler {newbody} {::proc ::xotcl::__exitHandler {} $newbody} proc ::xotcl::getExitHandler {} {::info body ::xotcl::__exitHandler} # initialize exit handler ::xotcl::unsetExitHandler @@ -385,7 +385,7 @@ ::xotcl::setinstvar ${class}::slot::$att default $default unset default } - $class setter $att + ::xotcl::setter $class $att } # do a second round to ensure that the already defined objects Index: generic/tclAPI.h =================================================================== diff -u -rff41e1a0cb88c3aa7b96ca3b67b27043794991b0 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- generic/tclAPI.h (.../tclAPI.h) (revision ff41e1a0cb88c3aa7b96ca3b67b27043794991b0) +++ generic/tclAPI.h (.../tclAPI.h) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -37,12 +37,12 @@ static int convertToConfigureoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; - static CONST char *opts[] = {"filter", "softrecreate", "cacheinterface", NULL}; + static CONST char *opts[] = {"filter", "softrecreate", "cacheinterface", "objectsystems", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "configureoption", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); return result; } -enum ConfigureoptionIdx {ConfigureoptionNULL, ConfigureoptionFilterIdx, ConfigureoptionSoftrecreateIdx, ConfigureoptionCacheinterfaceIdx}; +enum ConfigureoptionIdx {ConfigureoptionNULL, ConfigureoptionFilterIdx, ConfigureoptionSoftrecreateIdx, ConfigureoptionCacheinterfaceIdx, ConfigureoptionObjectsystemsIdx}; static int convertToSelfoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; @@ -55,12 +55,12 @@ static int convertToObjectkind(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; - static CONST char *opts[] = {"type", "object", "class", "metaclass", "mixin", NULL}; + static CONST char *opts[] = {"type", "object", "class", "baseclass", "metaclass", "mixin", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "objectkind", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); return result; } -enum ObjectkindIdx {ObjectkindNULL, ObjectkindTypeIdx, ObjectkindObjectIdx, ObjectkindClassIdx, ObjectkindMetaclassIdx, ObjectkindMixinIdx}; +enum ObjectkindIdx {ObjectkindNULL, ObjectkindTypeIdx, ObjectkindObjectIdx, ObjectkindClassIdx, ObjectkindBaseclassIdx, ObjectkindMetaclassIdx, ObjectkindMixinIdx}; static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; Index: generic/xotcl.c =================================================================== diff -u -r73eb4eccd33d1a940e2d2ca6dccc2f74216f0576 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- generic/xotcl.c (.../xotcl.c) (revision 73eb4eccd33d1a940e2d2ca6dccc2f74216f0576) +++ generic/xotcl.c (.../xotcl.c) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -8190,6 +8190,12 @@ } static int +IsBaseClass(XOTclClass *cl) { + return cl->object.flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS); +} + + +static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl, int withMixins) { /* check if class is a meta-class */ XOTclClasses *pl, *checkList = NULL, *mixinClasses = NULL, *mc; @@ -10174,7 +10180,7 @@ withCallprotection = CallprotectionPublicIdx; } - if (withApplication && object->flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS)) { + if (withApplication && object->flags & IsBaseClass((XOTclClass*)object)) { return TCL_OK; } @@ -10211,7 +10217,7 @@ /* append method keys from inheritance order */ for (pl = ComputeOrder(object->cl, object->cl->order, Super); pl; pl = pl->nextPtr) { Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); - if (withApplication && pl->cl->object.flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS)) { + if (withApplication && IsBaseClass(pl->cl)) { break; } ListMethodKeys(interp, cmdTable, pattern, methodType, withCallprotection, @@ -10515,13 +10521,27 @@ /* xotclCmd configure XOTclConfigureCmd { - {-argName "configureoption" -required 1 -type "filter|softrecreate|cacheinterface"} + {-argName "configureoption" -required 1 -type "filter|softrecreate|cacheinterface|objectsystems"} {-argName "value" -required 0 -type tclobj} } */ static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value) { int bool; + if (configureoption == ConfigureoptionObjectsystemsIdx) { + XOTclClasses *os; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + + for (os = RUNTIME_STATE(interp)->rootClasses; os; os = os->nextPtr) { + Tcl_Obj *osObj = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, osObj, os->cl->object.cmdName); + Tcl_ListObjAppendElement(interp, osObj, ((XOTclClass *)os->clientData)->object.cmdName); + Tcl_ListObjAppendElement(interp, list, osObj); + } + Tcl_SetObjResult(interp, list); + return TCL_OK; + } + if (value) { int result = Tcl_GetBooleanFromObj(interp, value, &bool); if (result != TCL_OK) @@ -10552,6 +10572,7 @@ return TCL_OK; } + /* xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { {-argName "rootClass" -required 1 -type tclobj} @@ -10926,7 +10947,7 @@ /* xotclCmd is XOTclIsCmd { {-argName "object" -required 1 -type tclobj} - {-argName "objectkind" -type "type|object|class|metaclass|mixin"} + {-argName "objectkind" -type "type|object|class|baseclass|metaclass|mixin"} {-argName "value" -required 0 -type tclobj} } */ @@ -10960,6 +10981,13 @@ && IsMetaClass(interp, (XOTclClass*)obj, 1); break; + case ObjectkindBaseclassIdx: + if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " baseclass"); + success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) + && XOTclObjectIsClass(obj) + && IsBaseClass((XOTclClass*)obj); + break; + case ObjectkindMixinIdx: if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " mixin "); success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) @@ -10968,6 +10996,7 @@ break; } + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); return TCL_OK; } @@ -12863,7 +12892,8 @@ methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_BUILTIN; break; case MethodtypeScriptedIdx: - methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_ALIAS; + /*methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_ALIAS;*/ + methodType = XOTCL_METHODTYPE_SCRIPTED; break; case MethodtypeBuiltinIdx: methodType = XOTCL_METHODTYPE_BUILTIN; @@ -13546,7 +13576,7 @@ && !ObjectHasChildren(interp, (XOTclObject*)cl) && !ClassHasInstances(cl) && !ClassHasSubclasses(cl) - && (cl->object.flags & (XOTCL_IS_ROOT_META_CLASS|XOTCL_IS_ROOT_CLASS)) == 0 + && !IsBaseClass(cl) ) { /* fprintf(stderr, " ... delete class %s %p\n", key, cl); */ freeUnsetTraceVariable(interp, &cl->object); Index: library/lib/xotcl1.xotcl =================================================================== diff -u -rc619db7db573de1047ec1810dc0a8dc4d86ce98d -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision c619db7db573de1047ec1810dc0a8dc4d86ce98d) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -118,12 +118,13 @@ # We provide a default value for superclass (when no superclass is specified explicitely) # for defining the top-level class of the object system, such that different # object systems might co-exist. - + createBootstrapAttributeSlots ::xotcl::Class { {__default_superclass ::xotcl::Object} {__default_metaclass ::xotcl::Class} } + ############################################ # system slots ############################################ @@ -149,6 +150,7 @@ } ::xotcl::register_system_slots1 ::xotcl + ######################## # Info definition ######################## @@ -273,6 +275,7 @@ } error "procedure \"$method\" doesn't have an argument \"$varName\"" } + classInfo eval { .proc instargs {o method} {::xotcl::info_args Class $o $method} .proc args {o method} {::xotcl::info_args Object $o $method} @@ -358,6 +361,7 @@ ::xotcl::alias ::xotcl::objectInfo $cmdName $cmd ::xotcl::alias ::xotcl::classInfo $cmdName $cmd } + foreach cmd [::info command ::xotcl::cmd::ClassInfo::*] { set cmdName [namespace tail $cmd] if {$cmdName in [list "forward" "method" "methods" \ @@ -366,6 +370,7 @@ "mixin" "mixinguard"]} continue ::xotcl::alias ::xotcl::classInfo $cmdName $cmd } + ::xotcl::alias ::xotcl::objectInfo is ::xotcl::is ::xotcl::alias ::xotcl::classInfo is ::xotcl::is ::xotcl::alias ::xotcl::classInfo classparent ::xotcl::cmd::ObjectInfo::parent @@ -390,7 +395,6 @@ ::xotcl::alias classInfo pre objectInfo::pre ::xotcl::alias classInfo post objectInfo::post - # emulation of isobject, isclass ... Object instproc isobject {{object:substdefault "[self]"}} {::xotcl::is $object object} Object instproc isclass {{class:substdefault "[self]"}} {::xotcl::is $class class} Index: library/serialize/Serializer.xotcl =================================================================== diff -u -rbe717fe9ef13e09dcfabf496ca61d75e4c042422 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision be717fe9ef13e09dcfabf496ca61d75e4c042422) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -4,7 +4,7 @@ namespace eval ::xotcl::serializer { - namespace import -force ::xotcl::* + ::xotcl::use xotcl2 @ @File { description { @@ -40,12 +40,12 @@ } @ Serializer proc deepSerialize { - objs "Objects to be serialized" ?-ignoreVarsRE RE? "provide regular expression; matching vars are ignored" ?-ignore obj1 obj2 ...? "provide a list of objects to be omitted" ?-map list? "translate object names in serialized code" + objs "Objects to be serialized" } { Description { Serialize object with all child objects (deep operation) @@ -59,16 +59,16 @@ object names in the serialized code.

Examples: - <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b ::x::y} + <@pre class='code'>Serializer deepSerialize -map {::a::b ::x::y} ::a::b::c Serialize the object <@tt>c which is a child of <@tt>a::b; the object will be reinitialized as object <@tt>::x::y::c, all references <@tt>::a::b will be replaced by <@tt>::x::y.

- <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b [self]} + <@pre class='code'>Serializer deepSerialize -map {::a::b [self]} ::a::b::c The serizalized object can be reinstantiated under some current object, under which the script is evaluated.

- <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b::c ${var}} + <@pre class='code'>Serializer deepSerialize -map {::a::b::c ${var} ::a::b::c} The serizalized object will be reinstantiated under a name specified by the variable <@tt>var<@tt> in the recreation context. } @@ -126,429 +126,682 @@ return {Object or Class with all currently defined methods, variables, invariants, filters and mixins} } - - ################################################################################## - # real clode starts here..... - # ################################################################################ - Class Serializer -parameter {ignoreVarsRE map} - namespace export Serializer - Serializer proc ignore args { - my set skip $args - } - Serializer instproc ignore args { - foreach i $args { - my set skip($i) 1 - # skip children of ignored objects as well - foreach j [$i info children] { - my ignore $j + ########################################################################### + # Serializer Class, independent from Object System + ########################################################################### + + Class create Serializer -parameter {ignoreVarsRE} { + + #todo: copy to oss? use ignorePattern? + .method ignore args { + # ignore the objects passed via args + foreach element $args { + foreach o [Serializer allChildren $element] { + set .skip($o) 1 + } } } - } - Serializer instproc init {} { - my ignore [self] - if {[[self class] exists skip]} { - eval my ignore [[self class] set skip] + + .method init {} { + # never serialize the (volatile) serializer object + .ignore [self] } - } - Serializer instproc method-serialize {o m prefix} { - my pcmd [my unescaped-method-serialize $o $m $prefix] - } - Serializer instproc unescaped-method-serialize {o m prefix} { - set arglist [list] - foreach v [$o info ${prefix}args $m] { - if {[$o info ${prefix}default $m $v x]} { - lappend arglist [list $v $x] } {lappend arglist $v} + + .method warn msg { + if {[info command ns_log] ne ""} { + ns_log Notice $msg + } else { + puts stderr "!!! $msg" + } } - lappend r ${prefix}proc $m \ - [concat [$o info ${prefix}nonposargs $m] $arglist] \ - [$o info ${prefix}body $m] - foreach p {pre post} { - if {[$o info ${prefix}$p $m]!=""} {lappend r [$o info ${prefix}$p $m]} + + .method addPostCmd {cmd} { + if {$cmd ne ""} {append .post_cmds $cmd "\n"} } - return $r - } - Serializer instproc pcmd list { - foreach a $list { - if {[regexp -- {^-[[:alpha:]]} $a]} { - set mustEscape 1 - break + + .method setObjectSystemSerializer {o serializer} { + set .serializer($o) $serializer + } + + .method isExportedObject {o} { + # Check, whether o is exported. For exported objects. + # we export the object tree. + set oo $o + while {1} { + if {[[self class] exists exportObjects($o)]} { + return 1 + } + # we do this for object trees without object-less namespaces + if {![::xotcl::is $o object]} { + return 0 + } + set o [$o info parent] } } - if {[info exists mustEscape]} { - return "\[list -$list\]" - } else { - return -$list - } - } - Serializer instproc collect-var-traces o { - my instvar traces - foreach v [$o info vars] { - set t [$o __trace__ info variable $v] - if {$t ne ""} { - foreach ops $t { - foreach {op cmd} $ops break - # save traces in post_cmds - my append post_cmds [list $o trace add variable $v $op $cmd] "\n" - # remove trace from object - $o trace remove variable $v $op $cmd - } + + .method topoSort {set all} { + if {[array exists .s]} {array unset .s} + if {[array exists .level]} {array unset .level} + + foreach c $set { + if {!$all && + [string match "::xotcl::*" $c] && + ![.isExportedObject $c]} continue + if {[info exists .skip($c)]} continue + set .s($c) 1 } + set stratum 0 + while {1} { + set set [array names .s] + if {[llength $set] == 0} break + incr stratum + # .warn "$stratum set=$set" + set .level($stratum) {} + foreach c $set { + set oss [set .serializer($c)] + if {[$oss needsNothing $c [self]]} { + lappend .level($stratum) $c + } + } + if {[set .level($stratum)] eq ""} { + set .level($stratum) $set + .warn "Cyclic dependency in $set" + } + foreach i [set .level($stratum)] {unset .s($i)} + } } - } - Serializer instproc Object-serialize o { - my collect-var-traces $o - append cmd [list [$o info class] create [::xotcl::dispatch $o -objscope ::xotcl::self]] - # slots needs to be initialized when optimized, since - # parametercmds are not serialized - #if {![$o istype ::xotcl::Slot]} {append cmd " -noinit"} - append cmd " -noinit" - append cmd " \\\n" - foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype scripted] { - append cmd " " [my method-serialize $o $i ""] " \\\n" + + .method needsOneOf list { + foreach e $list {if {[info exists .s($e)]} {return 1}} + return 0 } - foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype forward] { - set fwd [concat [list forward $i] [$o info forward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" + + .method serialize-objects {list all} { + set .post_cmds "" + + # register for introspection purposes "trace" under a different + # name for every object system + foreach oss [ObjectSystemSerializer info instances] { + $oss registerTrace 1 + } + + .topoSort $list $all + #foreach i [lsort [array names .level]] { .warn "$i: [set .level($i)]"} + set result "" + foreach l [lsort -integer [array names .level]] { + foreach i [set .level($l)] { + #.warn "serialize $i" + #append result "# Stratum $l\n" + set oss [set .serializer($i)] + append result [$oss serialize $i [self]] \n + } + } + foreach e $list { + set namespace($e) 1 + set namespace([namespace qualifiers $e]) 1 + } + # remove "trace" from all object systems + foreach oss [ObjectSystemSerializer info instances] { + $oss registerTrace 0 + } + + # Handling of variable traces: traces might require a + # different topological sort, which is hard to handle. + # Similar as with filters, we deactivate the variable + # traces during initialization. This happens by + # (1) replacing the XOTcl's trace method by a no-op + # (2) collecting variable traces through collect-var-traces + # (3) re-activating the traces after variable initialization + + set exports "" + set pre_cmds "" + + # delete ::xotcl from the namespace list, if it exists... + catch {unset namespace(::xotcl)} + foreach ns [array name namespace] { + if {![namespace exists $ns]} continue + if {![::xotcl::is $ns object]} { + append pre_cmds "namespace eval $ns {}\n" + } elseif {$ns ne [namespace origin $ns] } { + append pre_cmds "namespace eval $ns {}\n" + } + set exp [namespace eval $ns {namespace export}] + if {$exp ne ""} { + append exports "namespace eval $ns {namespace export $exp}" \n + } + } + return $pre_cmds$result${.post_cmds}$exports } - foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype setter] { - append cmd \t [my pcmd [list parametercmd $i]] " \\\n" + + .method deepSerialize o { + # assumes $o to be fully qualified + set instances [Serializer allChildren $o] + foreach oss [ObjectSystemSerializer info instances] { + $oss registerSerializer [self] $instances + } + .serialize-objects $instances 1 } - set vset {} - set nrVars 0 - foreach v [$o info vars] { - set setcmd [list] - if {![my exists ignoreVarsRE] || - ![regexp [my set ignoreVarsRE] ${o}::$v]} { - if {[::xotcl::dispatch $o ::array exists $v]} { - lappend setcmd array set $v [::xotcl::dispatch $o ::array get .$v] - } else { - lappend setcmd set $v [::xotcl::setinstvar $o $v] - } - incr nrVars - append cmd \t [my pcmd $setcmd] " \\\n" + + ############################### + # class object specfic methods + ############################### + + .object method allChildren o { + # return o and all its children fully qualified + set set [::xotcl::dispatch $o -objscope ::xotcl::self] + foreach c [$o info children] { + lappend set {*}[.allChildren $c] } + return $set } - set v [$o info mixin] - if {$v ne ""} {my append post_cmds [list $o mixin set $v] "\n"} - set v [::xotcl::assertion $o object-invar] - if {$v ne ""} {my append post_cmds [list ::xotcl::assertion $o object-invar $v] "\n"} - set v [$o info filter -guards] - if {$v ne ""} {append cmd [my pcmd [list filter $v]] " \\\n"} - return $cmd - } - Serializer instproc Class-serialize o { - set cmd [my Object-serialize $o] - #set p [$o info parameter] - #if {$p ne ""} { - # append cmd " " [my pcmd [list parameter $p]] " \\\n" - #} - foreach i [$o info instprocs] { - append cmd " " [my method-serialize $o $i inst] " \\\n" + + .object method exportMethods list { + foreach {o p m} $list {set .exportMethods([list $o $p $m]) 1} } - foreach i [$o info instforward] { - set fwd [concat [list instforward $i] [$o info instforward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" + + .object method exportObjects list { + foreach element $list { + foreach o [Serializer allChildren $element] { + set .exportObjects($o) 1 + } + } } - foreach i [$o info instparametercmd] { - append cmd \t [my pcmd [list instparametercmd $i]] " \\\n" + + .object method exportedMethods {} {array names .exportMethods} + .object method exportedObjects {} {array names .exportObjects} + + .object method resetPattern {} {array unset .ignorePattern} + .object method addPattern {p} {set .ignorePattern($p) 1} + + .object method checkExportedMethods {} { + foreach k [array names .exportMethods] { + foreach {o p m} $k break + set ok 0 + foreach p [array names .ignorePattern] { + if {[string match $p $o]} { + set ok 1; break + } + } + if {!$ok} { + error "method export is only for classes in\ + [join [array names .ignorePattern] {, }] not for $o" + } + } } - foreach x {superclass instinvar} { - set v [$o info $x] - if {$v ne "" && "::xotcl::Object" ne $v } { - append cmd " " [my pcmd [list $x $v]] " \\\n" + + .object method all {-ignoreVarsRE -ignore} { + + # don't filter anything during serialization + set filterstate [::xotcl::configure filter off] + set s [.new -childof [self] -volatile] + if {[info exists ignoreVarsRE]} {$s ignoreVarsRE $ignoreVarsRE} + if {[info exists ignore]} {$s ignore $ignore} + + set r [subst { + set ::xotcl::__filterstate \[::xotcl::configure filter off\] + ::xotcl::Slot mixin add ::xotcl::Slot::Nocheck + ::xotcl::configure softrecreate [::xotcl::configure softrecreate] + ::xotcl::setExitHandler [list [::xotcl::getExitHandler]] + }]\n + .resetPattern + set instances [list] + foreach oss [ObjectSystemSerializer info instances] { + append r [$oss serialize-all-start $s] + lappend instances {*}[$oss instances $s] } + + # provide error messages for invalid exports + .checkExportedMethods + + # export the objects and classes + #$s warn "export objects = [array names .exportObjects]" + #$s warn "export objects = [array names .exportMethods]" + + append r [$s serialize-objects $instances 0] + + foreach oss [ObjectSystemSerializer info instances] { + append r [$oss serialize-all-end $s] + } + + append r { + ::xotcl::Slot mixin delete ::xotcl::Slot::Nocheck + ::xotcl::configure filter $::xotcl::__filterstate + unset ::xotcl::__filterstate + } + ::xotcl::configure filter $filterstate + return $r } - foreach x {instmixin} { - set v [$o info $x] - if {$v ne "" && "::xotcl::Object" ne $v } { - my append post_cmds [list $o $x set $v] "\n" - #append cmd " " [my pcmd [list $x $v]] " \\\n" + + .object method methodSerialize {object method prefix} { + set s [.new -childof [self] -volatile] + concat $object [$s method-serialize $object $method $prefix] + } + + .object method deepSerialize {-ignoreVarsRE -ignore -map args} { + .resetPattern + set s [.new -childof [self] -volatile] + if {[info exists ignoreVarsRE]} {$s ignoreVarsRE $ignoreVarsRE} + if {[info exists ignore]} {$s ignore $ignore} + + foreach o $args { + append r [$s deepSerialize [$o]] } + if {[info exists map]} {return [string map $map $r]} + return $r } - set v [$o info instfilter -guards] - if {$v ne ""} {append cmd [my pcmd [list instfilter $v]] " \\\n"} - return $cmd\n + + # include Serializer in the serialized code + .exportObjects [self] + } + - Serializer instproc args {o prefix m} { - foreach v [$o info ${prefix}args $m] { - if {[$o info ${prefix}default $m $v x]} { - lappend arglist [list $v $x] } { - lappend arglist $v } + ########################################################################### + # Object System specific serializer + ########################################################################### + + Class create ObjectSystemSerializer { + + .method init {} { + # Include object system serializers in "Serializer all" + Serializer exportObjects [self] } - return $arglist - } - Serializer instproc category c { - if {[::xotcl::is $c type ::xotcl::Class]} {return Class} {return Object} - } - Serializer instproc allChildren o { - set set $o - foreach c [$o info children] { - eval lappend set [my allChildren $c] + + # + # Methods to be executed at the begin and end of serialize all + # + .method serialize-all-start {s} { + .getExported + return [.serializeExportedMethods $s] } - return $set - } - Serializer instproc allInstances C { - set set [$C info instances] - foreach sc [$C info subclass] { - eval lappend set [my allInstances $sc] + + .method serialize-all-end {s} { + set cmd "" + foreach o [list ${.rootClass} ${.rootMetaClass}] { + append cmd \ + [.frameWorkCmd ::xotcl::relation $o object-mixin] \ + [.frameWorkCmd ::xotcl::relation $o class-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o object-invar] \ + [.frameWorkCmd ::xotcl::assertion $o class-invar] + } + return $cmd } - return $set - } - Serializer instproc exportedObject o { - # check, whether o is exported. for exported objects. - # we export the object tree. - set oo $o - while {1} { - if {[[self class] exists exportObjects($o)]} { - #puts stderr "exported: $o -> exported $oo" - return 1 + + .method registerTrace {on} { + if {$on} { + ::xotcl::alias ${.rootClass} __trace__ -objscope ::trace + } else { + ::xotcl::method ${.rootClass} __trace__ {} {} } - # we do this for object trees without object-less name spaces - if {![my isobject $o]} {return 0} - set o [$o info parent] } - } - - Serializer instproc topoSort {set all} { - if {[array exists .s]} {array unset .s} - if {[array exists .level]} {array unset .level} - foreach c $set { - if {!$all && - [string match "::xotcl::*" $c] && - ![my exportedObject $c]} continue - if {[my exists skip($c)]} continue - my set s($c) 1 + + # + # Handle association between objects and responsible serializers + # + .method registerSerializer {s instances} { + # Communicate responsibility to serializer object $s + foreach i $instances { + if {![::xotcl::is $i type ${.rootClass}]} continue + $s setObjectSystemSerializer $i [self] + } } - set stratum 0 - while {1} { - set set [array names .s] - if {[llength $set] == 0} break - incr stratum - #my warn "$stratum set=$set" - my set level($stratum) {} - foreach c $set { - if {[my [my category $c]-needsNothing $c]} { - my lappend level($stratum) $c - } + + .method instances {s} { + # Compute all instances, for which we are responsible and + # notify serializer object $s + set instances [list] + foreach i [${.rootClass} info instances -closure] { + if {[.matchesIgnorePattern $i] && ![info exists .exportObjects($i)]} { + continue + } + $s setObjectSystemSerializer $i [self] + lappend instances $i } - if {[my set level($stratum)] eq ""} { - my set level($stratum) $set - my warn "Cyclic dependency in $set" + #$s warn "[self] handled instances: $instances" + return $instances + } + + .method getExported {} { + # + # get exported objects and methods from main Serializer for + # which this object specific serializer is responsible + # + foreach k [Serializer exportedMethods] { + foreach {o p m} $k break + if {[::xotcl::is $o type ${.rootClass}]} {set .exportMethods($k) 1} } - foreach i [my set level($stratum)] {my unset s($i)} + foreach o [Serializer exportedObjects] { + if {[::xotcl::is $o type ${.rootClass}]} {set .exportObjects($o) 1} + } + foreach p [array names .ignorePattern] {Serializer addPattern $p} } - } - Serializer instproc warn msg { - if {[info command ns_log] ne ""} { - ns_log Notice $msg - } else { - puts stderr "!!! $msg" + + + ############################### + # general method serialization + ############################### + + .method classify {o} { + if {[::xotcl::is $o type ${.rootMetaClass}]} \ + {return Class} {return Object} } - } - - Serializer instproc Class-needsNothing x { - if {![my Object-needsNothing $x]} {return 0} - set scs [$x info superclass] - if {[my needsOneOf $scs]} {return 0} - foreach sc $scs {if {[my needsOneOf [$sc info slots]]} {return 0}} - #if {[my needsOneOf [$x info instmixin ]]} {return 0} - return 1 - } - Serializer instproc Object-needsNothing x { - set p [$x info parent] - if {$p ne "::" && [my needsOneOf $p]} {return 0} - if {[my needsOneOf [$x info class]]} {return 0} - if {[my needsOneOf [[$x info class] info slots]]} {return 0} - #if {[my needsOneOf [$x info mixin ]]} {return 0} - return 1 - } - Serializer instproc needsOneOf list { - foreach e $list {if {[my exists s($e)]} { - #upvar x x; puts stderr "$x needs $e" - return 1 - }} - return 0 - } - Serializer instproc serialize {objectOrClass} { - string trimright [my [my category $objectOrClass]-serialize $objectOrClass] "\\\n" - } - Serializer instproc serialize-objects {list all} { - my instvar post_cmds - set post_cmds "" - # register for introspection purposes "trace" under a different name - ::xotcl::alias ::xotcl::Object __trace__ -objscope ::trace - ::xotcl::alias ::xotcl2::Object __trace__ -objscope ::trace - my topoSort $list $all - #foreach i [lsort [array names .level]] {my warn "$i: [my set level($i)]"} - set result "" - foreach l [lsort -integer [array names .level]] { - foreach i [my set level($l)] { - #my warn "serialize $i" - #append result "# Stratum $l\n" - append result [my serialize $i] \n + + .method collectVars o { + set setcmd [list] + foreach v [lsort [$o info vars]] { + if {![.exists ignoreVarsRE] || ![regexp [set .ignoreVarsRE] ${o}::$v]} { + if {[$o eval [list ::array exists .$v]]} { + lappend setcmd [list array set .$v [$o eval [list array get .$v]]] + } else { + lappend setcmd [list set .$v [::xotcl::setinstvar $o $v]] + } + } } + return $setcmd } - foreach e $list { - set namespace($e) 1 - set namespace([namespace qualifiers $e]) 1 + + .method frameWorkCmd {cmd o relation -unless} { + set v [$cmd $o $relation] + if {$v eq ""} {return ""} + if {[info exists unless] && $v eq $unless} {return ""} + return [list $cmd $o $relation $v]\n } - ::xotcl::Object method __trace__ {} {} - ::xotcl2::Object method __trace__ {} {} - # Handling of variable traces: traces might require a - # different topological sort, which is hard to handle. - # Similar as with filters, we deactivate the variable - # traces during initialization. This happens by - # (1) replacing the XOTcl's trace method by a no-op - # (2) collecting variable traces through collect-var-traces - # (3) re-activating the traces after variable initialization + .method serializeExportedMethods {s} { + set r "" + foreach k [array names .exportMethods] { + foreach {o p m} $k break + if {![.methodExists $o $p $m]} { + $s warn "Method does not exists: $o $p $m" + continue + } + append methods($o) [.serializeExportedMethod $o $p $m] + } + foreach o [array names methods] {set ($o) 1} + foreach o [list ${.rootClass} ${.rootMetaClass}] { + if {[info exists ($o)]} {unset ($o)} + } + foreach o [concat ${.rootClass} ${.rootMetaClass} [array names ""]] { + if {![info exists methods($o)]} continue + append r \n $methods($o) + } + #puts stderr "[self] ... exportedMethods <$r\n>" + return "$r\n" + } - set exports "" - set pre_cmds "" + ############################### + # general object serialization + ############################### - # delete ::xotcl from the namespace list, if it exists... - catch {unset namespace(::xotcl)} - foreach ns [array name namespace] { - if {![namespace exists $ns]} continue - if {![my isobject $ns]} { - append pre_cmds "namespace eval $ns {}\n" - } elseif {$ns ne [namespace origin $ns] } { - append pre_cmds "namespace eval $ns {}\n" + .method serialize {objectOrClass s} { + .[.classify $objectOrClass]-serialize $objectOrClass $s + } + + .method matchesIgnorePattern {o} { + foreach p [array names .ignorePattern] { + if {[string match $p $o]} {return 1} } - set exp [namespace eval $ns {namespace export}] - if {$exp ne ""} { - append exports "namespace eval $ns {namespace export $exp}" \n + return 0 + } + + .method collect-var-traces {o s} { + foreach v [$o info vars] { + set t [$o __trace__ info variable $v] + if {$t ne ""} { + foreach ops $t { + foreach {op cmd} $ops break + # save traces in post_cmds + $s addPostCmd [list $o trace add variable $v $op $cmd] + + # remove trace from object + $o trace remove variable $v $op $cmd + } + } } } - #append post_cmds "::xotcl::alias ::xotcl::Object trace -objscope ::trace\n" - return $pre_cmds$result$post_cmds$exports + ############################### + # general dependency handling + ############################### + + .method needsNothing {x s} { + return [.[.classify $x]-needsNothing $x $s] + } + + .method Class-needsNothing {x s} { + if {![.Object-needsNothing $x $s]} {return 0} + set scs [$x info superclass] + if {[$s needsOneOf $scs]} {return 0} + foreach sc $scs {if {[$s needsOneOf [$sc info slots]]} {return 0}} + return 1 + } + + .method Object-needsNothing {x s} { + set p [$x info parent] + if {$p ne "::" && [$s needsOneOf $p]} {return 0} + if {[$s needsOneOf [$x info class]]} {return 0} + if {[$s needsOneOf [[$x info class] info slots]]} {return 0} + return 1 + } + } - Serializer instproc deepSerialize o { - # assumes $o to be fully qualified - my serialize-objects [my allChildren $o] 1 - } - Serializer instproc serializeMethod {object kind name} { - set code "" - switch $kind { - proc { - if {[$object info methods -nocmd $name] ne ""} { - set code [my method-serialize $object $name ""] - } + + ########################################################################### + # XOTcl 2 specific serializer + ########################################################################### + + ObjectSystemSerializer create Serializer2 { + + set .rootClass ::xotcl2::Object + set .rootMetaClass ::xotcl2::Class + array set .ignorePattern [list "::xotcl2::*" 1 "::xotcl::*" 1] + + ############################### + # XOTcl 2 method serialization + ############################### + + .method methodExists {object kind name} { + expr {[$object info method type $name] != ""} + } + + .method serializeExportedMethod {object kind name} { + # todo: object modifier is missing + return [.method-serialize $object $name ""] + } + + .method method-serialize {o m modifier} { + if {![::xotcl::is $o class]} {set modifier ""} + return [$o {*}$modifier info method definition $m] + } + + ############################### + # XOTcl 2 object serialization + ############################### + + .method Object-serialize {o s} { + .collect-var-traces $o $s + append cmd [list [$o info class] create \ + [::xotcl::dispatch $o -objscope ::xotcl::self]] + + append cmd " -noinit\n" + foreach i [lsort [::xotcl::cmd::ObjectInfo::methods $o]] { + append cmd [.method-serialize $o $i "object"] "\n" } - instproc { - if {[$object info instprocs $name] ne ""} { - set code [my method-serialize $object $name inst] - } + append cmd \ + [list $o eval [join [.collectVars $o] "\n "]]\n \ + [.frameWorkCmd ::xotcl::relation $o object-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o object-invar] + + if {[::xotcl::is $o type ::xotcl::Slot]} { + # Slots needs to be initialized to ensure + # __invalidateobjectparameter to be called + append cmd [list $o init] \n } - forward - instforward { - if {[$object info $kind $name] ne ""} { - set fwd [concat [list $kind $name] [$object info $kind -definition $name]] - set code [my pcmd $fwd] - } + + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o object-filter] + return $cmd + } + + ############################### + # XOTcl 2 class serialization + ############################### + + .method Class-serialize {o s} { + + set cmd [.Object-serialize $o $s] + foreach i [lsort [::xotcl::cmd::ClassInfo::methods $o]] { + append cmd [.method-serialize $o $i ""] "\n" } + append cmd \ + [.frameWorkCmd ::xotcl::relation $o superclass -unless ${.rootClass}] \ + [.frameWorkCmd ::xotcl::relation $o class-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o class-invar] + + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o class-filter] + return $cmd\n } - return $code - } - - Serializer proc exportMethods list { - foreach {o p m} $list {my set exportMethods($o,$p,$m) 1} + # register serialize a global method + ::xotcl2::Object method serialize {} { + ::Serializer deepSerialize [self] + } + } - Serializer proc exportObjects list { - foreach o $list {my set exportObjects($o) 1} - } - Serializer proc serializeExportedMethods {s} { - set r "" - foreach k [array names .exportMethods] { - foreach {o p m} [split $k ,] break - #if {$o ne "::xotcl::Object" && $o ne "::xotcl::Class"} { - #error "method export only for ::xotcl::Object and\ - # ::xotcl::Class implemented, not for $o" - #} - if {![string match "::xotcl::*" $o]} { - error "method export is only for ::xotcl::* \ - object an classes implemented, not for $o" - } - append methods($o) [$s serializeMethod $o $p $m] " \\\n " + + + ########################################################################### + # XOTcl 1 specific serializer + ########################################################################### + + ObjectSystemSerializer create Serializer1 { + + set .rootClass ::xotcl::Object + set .rootMetaClass ::xotcl::Class + array set .ignorePattern [list "::xotcl::*" 1] + + .method serialize-all-start {s} { + return "::xotcl::Object instproc trace args {}\n[next]" } - set objects [array names methods] - foreach o [list ::xotcl::Object ::xotcl::Class] { - set p [lsearch $o $objects] - if {$p == -1} continue - set objects [lreplace $objects $p $p] + + .method serialize-all-end {s} { + return "[next]\n::xotcl::alias ::xotcl::Object trace -objscope ::trace\n" } - foreach o [concat ::xotcl::Object ::xotcl::Class $objects] { - if {![info exists methods($o)]} continue - append r \n "$o configure \\\n " \ - [string trimright $methods($o) "\\\n "] + + + ############################### + # XOTcl 1 method serialization + ############################### + + .method methodExists {object kind name} { + switch $kind { + proc - instproc { + return [expr {[$object info ${kind}s $name] ne ""}] + } + forward - instforward { + return [expr {[$object info ${kind} $name] ne ""}] + } + } } - #puts stderr "... exportedMethods <$r\n>" - return "$r\n" - } - Serializer proc all {args} { - # don't filter anything during serialization - set filterstate [::xotcl::configure filter off] - set s [eval my new -childof [self] -volatile $args] - # always export __exitHandler - my exportMethods [list ::xotcl::Object proc __exitHandler] - set r { - set ::xotcl::__filterstate [::xotcl::configure filter off] - ::xotcl::Object instproc trace args {} - ::xotcl::Slot instmixin add ::xotcl::Slot::Nocheck - } - append r "::xotcl::configure softrecreate [::xotcl::configure softrecreate]" - append r \n [my serializeExportedMethods $s] - # export the objects and classes - #$s warn "export objects = [array names .exportObjects]" - #$s warn "export objects = [array names .exportMethods]" - append r [$s serialize-objects [$s allInstances ::xotcl::Object] 0] - foreach o [list ::xotcl::Object ::xotcl::Class] { - foreach x {mixin instmixin invar instinvar} { - set v [$o info $x] - if {$v ne "" && $v ne "::xotcl::Object"} { - append r "$o configure " [$s pcmd [list $x $v]] "\n" - } + .method serializeExportedMethod {object kind name} { + set code "" + switch $kind { + proc - instproc { + if {[$object info ${kind}s $name] ne ""} { + set code [.method-serialize $object $name ""] + } + } + forward - instforward { + if {[$object info $kind $name] ne ""} { + set code [list $kind $name [$object info $kind -definition $name]] + } + } } + return $code } - append r { - ::xotcl::alias ::xotcl::Object trace -objscope ::trace - ::xotcl::Slot instmixin delete ::xotcl::Slot::Nocheck - ::xotcl::configure filter $::xotcl::__filterstate - unset ::xotcl::__filterstate + + .method method-serialize {o m prefix} { + set arglist [list] + foreach v [$o info ${prefix}args $m] { + if {[$o info ${prefix}default $m $v x]} { + lappend arglist [list $v $x] } {lappend arglist $v} + } + lappend r $o ${prefix}proc $m \ + [concat [$o info ${prefix}nonposargs $m] $arglist] \ + [$o info ${prefix}body $m] + foreach p {pre post} { + if {[$o info ${prefix}$p $m] ne ""} {lappend r [$o info ${prefix}$p $m]} + } + return $r } - ::xotcl::configure filter $filterstate - return $r - } - Serializer proc methodSerialize {object method prefix} { - set s [my new -childof [self] -volatile] - concat $object [$s unescaped-method-serialize $object $method $prefix] - } - Serializer proc deepSerialize args { - set s [my new -childof [self] -volatile] - foreach o [eval $s configure $args] { - append r [$s deepSerialize [$o]] + + ############################### + # XOTcl 1 object serialization + ############################### + + .method Object-serialize {o s} { + .collect-var-traces $o $s + append cmd [list [$o info class] create [::xotcl::dispatch $o -objscope ::xotcl::self]] + # slots needs to be initialized when optimized, since + # parametercmds are not serialized + append cmd " -noinit\n" + foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype scripted] { + append cmd [.method-serialize $o $i ""] "\n" + } + foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype forward] { + append cmd [concat [list $o] forward $i [$o info forward -definition $i]] "\n" + } + foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype setter] { + append cmd [list $o parametercmd $i] "\n" + } + append cmd \ + [list $o eval [join [.collectVars $o] "\n "]] \n \ + [.frameWorkCmd ::xotcl::relation $o object-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o object-invar] + + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o object-filter] + + return $cmd } - if {[$s exists map]} {return [string map [$s map] $r]} - return $r - } - # register serialize a global method - ::xotcl::Object instproc serialize {} { - ::Serializer deepSerialize [self] - } + ############################### + # XOTcl 1 class serialization + ############################### + + .method Class-serialize {o s} { + set cmd [.Object-serialize $o $s] + foreach i [$o info instprocs] { + append cmd [.method-serialize $o $i inst] "\n" + } + foreach i [$o info instforward] { + append cmd [concat [list $o] instforward $i [$o info instforward -definition $i]] "\n" + } + foreach i [$o info instparametercmd] { + append cmd [list $o instparametercmd $i] "\n" + } + append cmd \ + [.frameWorkCmd ::xotcl::relation $o superclass -unless ${.rootClass}] \ + [.frameWorkCmd ::xotcl::relation $o class-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o class-invar] - # include this method in the serialized code - Serializer exportMethods { - ::xotcl::Object instproc contains + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o class-filter] + return $cmd + } + + # register serialize a global method for xotcl1 + ::xotcl::Object instproc serialize {} { + ::Serializer deepSerialize [self] + } + + # include this method in the serialized code + #Serializer exportMethods { + # ::xotcl::Object instproc contains + #} } - # include Serializer in the serialized code - Serializer exportObjects [namespace current]::Serializer + namespace export Serializer namespace eval :: "namespace import -force [namespace current]::*" } Index: tests/aliastest.xotcl =================================================================== diff -u -r73eb4eccd33d1a940e2d2ca6dccc2f74216f0576 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- tests/aliastest.xotcl (.../aliastest.xotcl) (revision 73eb4eccd33d1a940e2d2ca6dccc2f74216f0576) +++ tests/aliastest.xotcl (.../aliastest.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -28,7 +28,8 @@ ? {Foo info methods -methodtype alias} "foo" ? {Base info methods -methodtype scripted} {foo} -? {Foo info methods -methodtype scripted} {foo} +? {Foo info methods -methodtype scripted} {} +? {Foo info methods -methodtype alias} {foo} Base method foo {} {} ? {Foo info methods -methodtype alias} "" ? {Base info methods -methodtype scripted} {} @@ -40,10 +41,10 @@ ::xotcl::alias ::Foo foo ::xotcl::classes::Base::foo ? {Base info methods -methodtype scripted} {foo} "defined again" -? {Foo info methods -methodtype scripted} {foo} "aliased again" +? {Foo info methods -methodtype alias} {foo} "aliased again" Foo method foo {} {} ? {Base info methods -methodtype scripted} {foo} "still defined" -? {Foo info methods -methodtype scripted} {} "removed" +? {Foo info methods -methodtype alias} {} "removed" # # chaining aliases @@ -61,9 +62,9 @@ ? {t foo} ::T->foo ? {t FOO} ::T->foo -? {lsort [T info methods -methodtype scripted]} {FOO foo} +? {lsort [T info methods]} {FOO foo} T method foo {} {} -? {lsort [T info methods -methodtype scripted]} {} "alias is deleted" +? {lsort [T info methods]} {} "alias is deleted" # puts stderr "double indirection" T method foo args { return [self class]->[self proc] } @@ -72,38 +73,38 @@ ? {T info methods -methodtype alias} "FOO" ? {T info method definition FOO} "::T alias FOO ::xotcl::classes::T::foo" -? {lsort [T info methods -methodtype scripted]} {FOO foo} -? {S info methods -methodtype scripted} {BAR} +? {lsort [T info methods]} {FOO foo} +? {S info methods} {BAR} T method FOO {} {} -? {T info methods -methodtype scripted} {foo} -? {S info methods -methodtype scripted} {BAR} +? {T info methods} {foo} +? {S info methods} {BAR} ? {s BAR} ::S->foo ? {t foo} ::T->foo ? {S info method definition BAR} "::S alias BAR ::xotcl::classes::T::FOO" T method foo {} {} -? {T info methods -methodtype scripted} {} -? {S info methods -methodtype scripted} {} +? {T info methods} {} +? {S info methods} {} T method foo args { return [self class]->[self proc] } ::xotcl::alias T FOO ::xotcl::classes::T::foo ::xotcl::alias S BAR ::xotcl::classes::T::FOO -? {lsort [T info methods -methodtype scripted]} {FOO foo} -? {S info methods -methodtype scripted} {BAR} +? {lsort [T info methods]} {FOO foo} +? {S info methods} {BAR} T method foo {} {} -? {S info methods -methodtype scripted} {} -? {T info methods -methodtype scripted} {} +? {S info methods} {} +? {T info methods} {} T method foo args { return [self class]->[self proc] } T object method bar args { return [self class]->[self proc] } ::xotcl::alias T -per-object FOO ::xotcl::classes::T::foo ::xotcl::alias T -per-object BAR ::T::FOO ::xotcl::alias T -per-object ZAP ::T::BAR -? {T info methods -methodtype scripted} {foo} +? {T info methods} {foo} ? {lsort [T object info methods -methodtype alias]} {BAR FOO ZAP} -? {lsort [T object info methods -methodtype scripted]} {BAR FOO ZAP bar} +? {lsort [T object info methods]} {BAR FOO ZAP bar} ? {t foo} ::T->foo ? {T object info method definition ZAP} {::T object alias ZAP ::T::BAR} @@ -112,39 +113,39 @@ ? {T ZAP} ->foo ? {T bar} ->bar T object method FOO {} {} -? {T info methods -methodtype scripted} {foo} -? {lsort [T object info methods -methodtype scripted]} {BAR ZAP bar} +? {T info methods} {foo} +? {lsort [T object info methods]} {BAR ZAP bar} ? {T BAR} ->foo ? {T ZAP} ->foo rename ::T::BAR "" -? {T info methods -methodtype scripted} {foo} -? {lsort [T object info methods -methodtype scripted]} {ZAP bar} +? {T info methods} {foo} +? {lsort [T object info methods]} {ZAP bar} #? {T BAR} ""; # now calling the proc defined above, alias chain seems intact ? {T ZAP} ->foo; # is ok, still pointing to 'foo' #T object method BAR {} {} -? {T info methods -methodtype scripted} {foo} -? {lsort [T object info methods -methodtype scripted]} {ZAP bar} +? {T info methods} {foo} +? {lsort [T object info methods]} {ZAP bar} ? {T ZAP} ->foo T method foo {} {} -? {T info methods -methodtype scripted} {} -? {lsort [T object info methods -methodtype scripted]} {bar} +? {T info methods} {} +? {lsort [T object info methods]} {bar} # # per-object methods as per-object aliases # T object method m1 args { return [self class]->[self proc] } ::xotcl::alias T -per-object M1 ::T::m1 ::xotcl::alias T -per-object M11 ::T::M1 -? {lsort [T object info methods -methodtype scripted]} {M1 M11 bar m1} +? {lsort [T object info methods]} {M1 M11 bar m1} ? {T m1} ->m1 ? {T M1} ->m1 ? {T M11} ->m1 T object method M1 {} {} -? {lsort [T object info methods -methodtype scripted]} {M11 bar m1} +? {lsort [T object info methods]} {M11 bar m1} ? {T m1} ->m1 ? {T M11} ->m1 T object method m1 {} {} -? {lsort [T object info methods -methodtype scripted]} {bar} +? {lsort [T object info methods]} {bar} # # a proc as alias @@ -157,17 +158,17 @@ # ! per-object alias referenced as per-class alias ! # ::xotcl::alias T BAR ::T::FOO2 -? {lsort [T object info methods -methodtype scripted]} {FOO2 bar} -? {lsort [T info methods -methodtype scripted]} {BAR FOO1} +? {lsort [T object info methods]} {FOO2 bar} +? {lsort [T info methods]} {BAR FOO1} ? {T FOO2} ->foo ? {t FOO1} ::T->foo ? {t BAR} ::T->foo # # delete proc # rename foo "" -? {lsort [T object info methods -methodtype scripted]} {bar} -? {lsort [T info methods -methodtype scripted]} {} +? {lsort [T object info methods]} {bar} +? {lsort [T info methods]} {} # namespaced procs + namespace deletion @@ -180,14 +181,14 @@ ::xotcl::alias T FOO ::ns1::foo ::xotcl::alias T BAR ::ns1::bar ::xotcl::alias T BAR2 ::ns1::bar2 -? {lsort [T info methods -methodtype scripted]} {BAR BAR2 FOO} +? {lsort [T info methods]} {BAR BAR2 FOO} set _ GOTYA ? {t FOO} ::T->foo ? {t BAR} GOTYA ? {t BAR2} GOTYA namespace delete ::ns1 ? {info procs ::ns1::*} {} -? {lsort [T info methods -methodtype scripted]} {} +? {lsort [T info methods]} {} # per-object namespaces @@ -201,12 +202,12 @@ U object method bar args { return [self class]->[self proc] } ::xotcl::alias U -per-object BAR ::U::bar -? {lsort [U object info methods -methodtype scripted]} {BAR ZAP bar zap} +? {lsort [U object info methods]} {BAR ZAP bar zap} ? {U BAR} ->bar ? {U ZAP} ->zap namespace delete ::U ? {namespace exists ::U} 0 -? {lsort [U object info methods -methodtype scripted]} {} +? {lsort [U object info methods]} {} ? {U info callable BAR} "" ? {U info callable ZAP} "" @@ -229,14 +230,14 @@ ::xotcl::alias V FOO1 ::foo ::xotcl::alias V -per-object FOO2 ::foo -? {lsort [V object info methods -methodtype scripted]} {FOO2 bar} -? {lsort [V info methods -methodtype scripted]} {FOO1 bar} +? {lsort [V object info methods]} {FOO2 bar} +? {lsort [V info methods]} {FOO1 bar} ? {V FOO2} 1-1-1 ? {v FOO1} 2-2-2 V method FOO1 {} {} -? {lsort [V info methods -methodtype scripted]} {bar} +? {lsort [V info methods]} {bar} rename ::foo "" -? {lsort [V object info methods -methodtype scripted]} {bar} +? {lsort [V object info methods]} {bar} # Index: tests/forwardtest.xotcl =================================================================== diff -u -r73eb4eccd33d1a940e2d2ca6dccc2f74216f0576 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision 73eb4eccd33d1a940e2d2ca6dccc2f74216f0576) +++ tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -5,6 +5,7 @@ ########################################### # trivial object delegation ########################################### +Test case delegation Object dog Object tail tail proc wag args { return $args } @@ -16,6 +17,7 @@ ########################################### # evaluating in scope ########################################### +Test case inscope Class X -parameter {{x 1}} X instforward Incr -objscope incr @@ -29,6 +31,7 @@ ########################################### # adding ########################################### +Test case adding Object obj obj forward addOne expr 1 + @@ -38,6 +41,7 @@ ########################################### # more arguments ########################################### +Test case multiple-args Object target target proc foo args {return $args} obj forward foo target %proc %self a1 a2 @@ -53,6 +57,7 @@ ########################################### # mixin example ########################################### +Test case mixin-via-forward Object create mixin mixin proc unknown {m args} {return [concat [self] $m $args]} @@ -71,6 +76,7 @@ ########################################### # sketching extensibe info ########################################### +Test case info-via-forward Object Info Info proc @mixin {o} { $o info mixin @@ -90,6 +96,7 @@ ########################################### # variations of placement of options ########################################### +Test case incr obj set x 1 obj forward i1 -objscope incr x @@ -99,6 +106,7 @@ ########################################### # introspeciton options ########################################### +Test case introspection Class C C instforward Info -methodprefix @ Info %1 %self @@ -126,6 +134,7 @@ ########################################### # test serializer ########################################### +Test case serializer package require xotcl::serializer obj proc test {} {puts "i am [self proc]"} set a [Serializer deepSerialize obj] @@ -136,6 +145,7 @@ ########################################### # test optional target cmd ########################################### +Test case optional-target obj set x 2 obj forward append -objscope ? {obj append x y z} 2yz @@ -147,14 +157,15 @@ ########################################### # arg including instvar ########################################### +Test case percent-cmd obj set x 10 obj forward x* expr {%my set x} * ? {obj x* 10} "100" ########################################### # positional arguments ########################################### - +Test case positioning-args obj forward @end-13 list {%@end 13} ? {obj @end-13 1 2 3 } [list 1 2 3 13] @@ -210,7 +221,7 @@ ############################################### # substitution depending on number of arguments ############################################### - +Test case num-args obj forward f %self [list %argclindex [list a b c]] obj proc a args {return [list [self proc] $args]} obj proc b args {return [list [self proc] $args]} @@ -223,6 +234,7 @@ ############################################### # option earlybinding ############################################### +Test case earlyinging obj forward s -earlybinding ::set %proc ? {obj s 100} 100 ? {obj s} 100 @@ -309,7 +321,7 @@ ########################################### # forward to expr + callstack ########################################### - +Test case callstack Object instforward expr -objscope Class C Index: tests/testx.xotcl =================================================================== diff -u -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b --- tests/testx.xotcl (.../testx.xotcl) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) +++ tests/testx.xotcl (.../testx.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) @@ -3114,13 +3114,13 @@ ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objectparameter objproc parametercmd proc procsearch requireNamespace residualargs self set setFilter signature subst trace unknown unset uplevel upvar volatile vwait" "b info methods" - ::errorCheck [lsort [b info methods -nocmds]] "abstract check contains copy defaultmethod extractConfigureArg f filtersearch hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds" + ::errorCheck [lsort [b info methods -nocmds]] "abstract check extractConfigureArg f filtersearch hasclass init isclass ismetaclass ismixin isobject istype method myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc proc procsearch self setFilter signature unknown" "b info methods -nocmds" ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname class cleanup configure destroy eval exists filter filterguard forward incr info instvar invar lappend mixin mixinguard noinit requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" - ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract check contains copy defaultmethod extractConfigureArg f filtersearch hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" + ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract check extractConfigureArg f filtersearch hasclass init isclass ismetaclass ismixin isobject istype method myProc myProc2 objectparameter objproc proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances check contains copy defaultmethod extractConfigureArg f filtersearch hasclass init instparametercmd instproc isclass ismetaclass ismixin isobject istype method move objectparameter parameter parametercmd proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances check extractConfigureArg f filtersearch hasclass init instproc isclass ismetaclass ismixin isobject istype method objectparameter proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" namespace eval a { proc o args {return o}