Index: TODO =================================================================== diff -u -r4f5bfece93be68c6c0ce6dde9c1102a6b6e70b23 -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- TODO (.../TODO) (revision 4f5bfece93be68c6c0ce6dde9c1102a6b6e70b23) +++ TODO (.../TODO) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -1123,6 +1123,10 @@ - deactivated "abstract" +- implemented experimental delegating version of "object as method" + that keeps the original self. + + TODO: - deeper analysis of "contains" Index: generic/xotcl.c =================================================================== diff -u -r513f795175db0329e73b1c7d14fb73255d62235a -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- generic/xotcl.c (.../xotcl.c) (revision 513f795175db0329e73b1c7d14fb73255d62235a) +++ generic/xotcl.c (.../xotcl.c) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -166,6 +166,7 @@ static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc,Tcl_Obj *CONST objv[]); XOTCLINLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags); +static int DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int DoDealloc(Tcl_Interp *interp, XOTclObject *object); static int RecreateObject(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *object, int objc, Tcl_Obj *CONST objv[]); @@ -5895,17 +5896,35 @@ /* * invoke an aliased object via method interface */ + XOTclRuntimeState *rst = RUNTIME_STATE(interp); XOTclObject *invokeObj = (XOTclObject *)cp; + if (invokeObj->flags & XOTCL_DELETED) { /* - * when we try to call a deleted object, the cmd (alias) is + * When we try to call a deleted object, the cmd (alias) is * automatically removed. */ Tcl_DeleteCommandFromToken(interp, cmd); XOTclCleanupObject(invokeObj); return XOTclVarErrMsg(interp, "Trying to dispatch deleted object via method '", methodName, "'", (char *) NULL); } + + /* + * The client data cp is still the obj of the called method, + * i.e. self changes. In order to prevent this, we save the + * actual object in the runtime state, flag ObjectDispatch via + * XOTCL_CM_DELGATE to use it. + */ + /*xxxx*/ + /*fprintf(stderr, "save self %p %s\n", object, objectName(object));*/ + rst->delegatee = object; + if (objc < 2) { + result = DispatchDefaultMethod(cp, interp, objc, objv); + } else { + result = ObjectDispatch(cp, interp, objc, objv, XOTCL_CM_DELGATE); + } + return result; } else if (proc == XOTclForwardMethod || proc == XOTclObjscopedMethod || proc == XOTclSetterMethod @@ -5957,6 +5976,7 @@ cmdObj = object->cmdName; methodObj = objv[0]; } else { + assert(objc>1); shift = 1; cmdObj = objv[0]; methodObj = objv[1]; @@ -6111,8 +6131,31 @@ } if (!unknown) { - /*fprintf(stderr, "ObjectDispatch calls MethodDispatch with obj = %s frameType %d method %s\n", - objectName(object), frameType, methodName);*/ + XOTclObject *originator = NULL; + /* xxxx */ + /*fprintf(stderr, "ObjectDispatch calls MethodDispatch with obj = %s frameType %d method %s flags %.6x\n", + objectName(object), frameType, methodName, flags);*/ + if (flags & XOTCL_CM_DELGATE && rst->delegatee) { + /* + * We want to execute the method on the delegatee, so we have + * to flip the object. + * + * Note: there is a object->refCount ++; at the begin of this + * function and a XOTclCleanupObject(object) at the end. So, + * we have to keep track of the refcounts here. Either mangle + * refcounts, or save originator. + * + */ + originator = object; + /*XOTclCleanupObject(object);*/ + clientData = rst->delegatee; + object = rst->delegatee; + /*object->refCount ++; */ + /*fprintf(stderr, " ... clientData %p %s object %p %s methodName %s\n", + clientData, objectName(((XOTclObject *)clientData)), object, objectName(object), + methodName);*/ + } + if ((result = MethodDispatch(clientData, interp, objc-shift, objv+shift, cmd, object, cl, methodName, frameType)) == TCL_ERROR) { /*fprintf(stderr, "Call ErrInProc cl = %p, cmd %p, flags %.6x\n", @@ -6121,6 +6164,11 @@ cl && cl->object.teardown ? cl->object.cmdName : NULL, methodName); } + if (originator) { + clientData = originator; + object = originator; + } + unknown = rst->unknown; } } else { @@ -6192,6 +6240,24 @@ return result; } + +static int +DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int result; + Tcl_Obj *methodObj = XOTclMethodObj(interp, (XOTclObject *)clientData, XO_o_defaultmethod_idx); + + if (methodObj) { + Tcl_Obj *tov[2]; + tov[0] = objv[0]; + tov[1] = methodObj; + result = ObjectDispatch(clientData, interp, 2, tov, XOTCL_CM_NO_UNKNOWN); + } else { + result = TCL_OK; + } + return result; +} + + int XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int result; @@ -6207,17 +6273,8 @@ /* normal dispatch */ result = ObjectDispatch(clientData, interp, objc, objv, 0); } else { - Tcl_Obj *methodObj = XOTclMethodObj(interp, (XOTclObject *)clientData, XO_o_defaultmethod_idx); - if (methodObj) { - Tcl_Obj *tov[2]; - tov[0] = objv[0]; - tov[1] = methodObj; - result = ObjectDispatch(clientData, interp, 2, tov, XOTCL_CM_NO_UNKNOWN); - } else { - result = TCL_OK; - } + result = DispatchDefaultMethod(clientData, interp, objc, objv); } - return result; } Index: generic/xotcl.h =================================================================== diff -u -raf4326a00a0f2d0b2f1e0369af71637f48c2d56a -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- generic/xotcl.h (.../xotcl.h) (revision af4326a00a0f2d0b2f1e0369af71637f48c2d56a) +++ generic/xotcl.h (.../xotcl.h) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -78,17 +78,14 @@ #define NDEBUG 1 */ - /* activate/deacticate memory tracing #define XOTCL_MEM_TRACE 1 #define XOTCL_MEM_COUNT 1 */ -/* +/* turn tracing output on/off #define XOTCLOBJ_TRACE 1 -*/ -/* turn tracing output on/off #define CALLSTACK_TRACE 1 #define DISPATCH_TRACE 1 #define NAMESPACE_TRACE 1 Index: generic/xotclInt.h =================================================================== diff -u -ra588ad9e5d66f12c4b2a5baf9153b652932a5912 -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- generic/xotclInt.h (.../xotclInt.h) (revision a588ad9e5d66f12c4b2a5baf9153b652932a5912) +++ generic/xotclInt.h (.../xotclInt.h) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -248,6 +248,7 @@ #define XOTCL_CM_NO_UNKNOWN 1 #define XOTCL_CM_NO_SHIFT 2 #define XOTCL_CM_NO_PROTECT 4 +#define XOTCL_CM_DELGATE 0x10 /* * @@ -666,6 +667,7 @@ int overloadedMethods; long newCounter; XOTclStringIncrStruct iss; + XOTclObject *delegatee; Proc fakeProc; Tcl_Namespace *fakeNS; NxStubs *nxStubs; Index: library/lib/test.tcl =================================================================== diff -u -r496dfc7bd5088b8a90f1fe532cd22336c151b06d -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- library/lib/test.tcl (.../test.tcl) (revision 496dfc7bd5088b8a90f1fe532cd22336c151b06d) +++ library/lib/test.tcl (.../test.tcl) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -61,10 +61,11 @@ :public object method parameter {name value:optional} { if {[info exists value]} { #[[current] slot $name] default $value - :slot $name default $value - ::nsf::invalidateobjectparameter [::nsf::current object] + #:slot $name default $value + [self]::slot::$name default $value + ::nsf::invalidateobjectparameter [self] } else { - return [:slot $name default] + return [[self]::slot::$name $name default] } } Index: library/xotcl/library/comm/Httpd.xotcl =================================================================== diff -u -rf3b7952aabc9e4f9079febd1f5b7f5fb833fd50c -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- library/xotcl/library/comm/Httpd.xotcl (.../Httpd.xotcl) (revision f3b7952aabc9e4f9079febd1f5b7f5fb833fd50c) +++ library/xotcl/library/comm/Httpd.xotcl (.../Httpd.xotcl) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -106,19 +106,19 @@ next my makeConnection $socket my log Connect "$ipaddr $port" - my connection translation {auto crlf} - my connection event readable [self] firstLine + [self]::connection translation {auto crlf} + [self]::connection event readable [self] firstLine } Httpd::Wrk instproc makeConnection {socket} { Connection create [self]::connection -socket $socket -req [self] } Httpd::Wrk instproc close {} { # logical close of a single request #my showCall my instvar version timeout meta - set eof [my connection eof] + set eof [[self]::connection eof] if {$version > 1.0 && !$eof} { #my showMsg "!EOF in http/$version" - my connection flush + [self]::connection flush set timeout [after [[my info parent] workerTimeout] [self] destroy] ### reset parameters, worker will be potentially reused if {[array exists meta]} { @@ -134,39 +134,39 @@ my set replyHeaderFields [list] my set formData {} #my showVars - my connection translation {auto crlf} - my connection event readable [self] firstLine + [self]::connection translation {auto crlf} + [self]::connection event readable [self] firstLine } elseif {$eof} { #my showMsg "Destroy in http/$version" # the client side has closed the connection my destroy } else { #my showMsg "!EOF in http/$version ???" # we close the conneciton actively (e.g. forced by an error) - my connection flush + [self]::connection flush #puts stderr "DESTROY----this line should never show up" my destroy } } Httpd::Wrk instproc destroy {} { #my showCall if {[my isobject [self]::connection]} { - my connection close + [self]::connection close } next } Httpd::Wrk instproc freeConnection {} { } Httpd::Wrk instproc firstLine {} { # Read the first line of the request - #my showCall + my showCall my instvar method resourceName hasFormData query fileName \ version timeout if {[info exists timeout]} { after cancel $timeout unset timeout } my lappend replyHeaderFields Date [Httpd Date [clock seconds]] - set n [my connection gets firstLine] + set n [[self]::connection gets firstLine] if {$n > 0} { #::puts stderr "[self] firstline=<$firstLine>" # parse request line, ignore HTTP version for now @@ -184,8 +184,8 @@ if {[my exists forceVersion1.0]} { set version 1.0 } - my connection makePersistent [expr {$version > 1.0}] - my connection event readable [self] header + [self]::connection makePersistent [expr {$version > 1.0}] + [self]::connection event readable [self] header } else { set version 1.0 set resourceName ??? @@ -194,18 +194,18 @@ my replyCode 400 my replyErrorMsg } - } elseif {![my connection eof]} { - #my showMsg "+++ not completed EOF=[my connection eof]" + } elseif {![[self]::connection eof]} { + #my showMsg "+++ not completed EOF=[[self]::connection eof]" } else { set version 1.0 - #my showMsg "+++ n=negative ($n) EOF=[my connection eof] version set to 1.0" + #my showMsg "+++ n=negative ($n) EOF=[[self]::connection eof] version set to 1.0" my close } } Httpd::Wrk instproc header {} { # Read the header #my showCall my instvar method data - if {[my connection gets line] > 0} { + if {[[self]::connection gets line] > 0} { #puts stderr line=$line if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} { my set meta([string tolower $key]) $value @@ -215,17 +215,17 @@ if {[my exists meta(content-length)] && [my set meta(content-length)]>0} { #puts stderr "we have content-length [my set meta(content-length)]" set data "" - my connection translation binary - my connection event readable [self] receive-body + [self]::connection translation binary + [self]::connection event readable [self] receive-body } elseif {[my exists meta(content-type)] && [regexp -nocase {multipart/form-data; *boundary=} \ [my set meta(content-type)]]} { #puts stderr "formdata" set data "" - my connection event readable [self] receive-body + [self]::connection event readable [self] receive-body } else { #puts stderr "no-content-length, triggering respond" - my connection event readable [self] "" + [self]::connection event readable [self] "" [my info parent] instvar requiresBody if {$requiresBody($method)} { my replyCode 411 @@ -239,18 +239,18 @@ Httpd::Wrk instproc receive-body {} { ;# ... now we have to read the body #my showCall my instvar method data meta - set d [my connection read] + set d [[self]::connection read] if {$d ne ""} { append data $d #my showMsg "datal=[string length $data], cl=$meta(content-length)" if {[string length $data] >= $meta(content-length)} { - my connection event readable [self] "" + [self]::connection event readable [self] "" if {$method eq "POST"} { my decode-POST-query } my check-redirect } } else { ;# 0 byte, must be eof... my showMsg "received 0 bytes" - my connection event readable [self] "" + [self]::connection event readable [self] "" if {[string length $data] < $meta(content-length)} { my replyCode 404 my replyErrorMsg @@ -307,7 +307,7 @@ Last-Modified [Httpd Date [file mtime $fileName]] \ Content-Type [Mime guessContentType $fileName] \ Content-Length [file size $fileName] - my connection puts "" + [self]::connection puts "" #my log Done "$fileName [Mime guessContentType $fileName]" my close } else { @@ -319,13 +319,13 @@ my replyCode 200 \ Allow "OPTIONS, GET, HEAD, POST" \ Public "OPTIONS, GET, HEAD, POST" - my connection puts "" + [self]::connection puts "" my close } Httpd::Wrk instproc respond-PUT {} { my instvar data method fileName my replyCode [expr {[file writable $fileName] ? 200 : 201}] - my connection puts "" + [self]::connection puts "" set out [open $fileName w] fconfigure $out -translation binary puts -nonewline $out $data @@ -337,7 +337,7 @@ my instvar fileName if {[file executable $fileName]} { my replyCode 200 - my connection puts [exec $fileName] ;# no parameter handling yet + [self]::connection puts [exec $fileName] ;# no parameter handling yet my close } else { my replyCode 403 @@ -403,7 +403,7 @@ Httpd::Wrk instproc replyErrorMsg {{msg ""} args} { my instvar replyCode [self class] instvar codes - foreach {tag value} $args {my connection puts "$tag: $value"} + foreach {tag value} $args {[self]::connection puts "$tag: $value"} my sendText "\nStatus Code: $replyCode\n\ $msg

\n\ Status Code $replyCode: $codes($replyCode)
\n\ @@ -415,9 +415,9 @@ my instvar version [self class] instvar codes my set replyCode $code - my connection puts "HTTP/$version $code $codes($code)" - foreach {tag value} [my set replyHeaderFields] {my connection puts "$tag: $value"} - foreach {tag value} $args {my connection puts "$tag: $value"} + [self]::connection puts "HTTP/$version $code $codes($code)" + foreach {tag value} [my set replyHeaderFields] {[self]::connection puts "$tag: $value"} + foreach {tag value} $args {[self]::connection puts "$tag: $value"} if {$code >= 400} { my log Error "$code $codes($code)\tmeta: [my array get meta]" } else { @@ -426,13 +426,13 @@ } Httpd::Wrk instproc sendText {response {type text/html}} { #my showCall - my connection puts "Content-Type: $type" + [self]::connection puts "Content-Type: $type" # bei einer leeren Responses blockieren Klienten und melden Fehler if {$response eq ""} { set response " " } - my connection puts "Content-Length: [string length $response]\n" + [self]::connection puts "Content-Length: [string length $response]\n" if {[my set method] ne "HEAD"} { - my connection fconfigure -translation {auto binary} - my connection puts-nonewline $response + [self]::connection fconfigure -translation {auto binary} + [self]::connection puts-nonewline $response } else { my showMsg HEAD! } @@ -497,11 +497,11 @@ Last-Modified [Httpd Date $mtime] \ Content-Type $type \ Content-Length [file size $fn] - my connection puts "" - my connection fconfigure -translation binary ;#-buffersize 65536 + [self]::connection puts "" + [self]::connection fconfigure -translation binary ;#-buffersize 65536 set localFile [open $fn] fconfigure $localFile -translation binary -buffersize 65536 - fcopy $localFile [my connection set socket] \ + fcopy $localFile [[self]::connection set socket] \ -command [list [self] fcopy-end $localFile] } else { my replyCode 404 @@ -510,7 +510,7 @@ } Httpd::Wrk instproc fcopy-end {localFile args} { # End of fcopy close $localFile - my connection fconfigure -blocking false ;# fconfigure changes blocking in 8.3.2! + [self]::connection fconfigure -blocking false ;# fconfigure changes blocking in 8.3.2! my close } Httpd::Wrk instproc log {reason arg} { # trivial logging @@ -567,7 +567,7 @@ # -server bool --> Handshake as server if true, else handshake as # client.(default: false) - my connection importSSL -server 1 \ + [self]::connection importSSL -server 1 \ -certfile $certfile \ -keyfile $keyfile \ -cafile $cafile \ Index: library/xotcl/tests/slottest.xotcl =================================================================== diff -u -re548a952433b4d26794f535995c9ed1ababe8807 -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- library/xotcl/tests/slottest.xotcl (.../slottest.xotcl) (revision e548a952433b4d26794f535995c9ed1ababe8807) +++ library/xotcl/tests/slottest.xotcl (.../slottest.xotcl) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -322,10 +322,12 @@ ? {a0 procsearch f3} "::a0 proc f3" ? {a0 procsearch f4} "::a0 forward f4" ? {a0 procsearch set} "::xotcl::Object instcmd set" -? {A slot foo info callable method assign} "::nsf::classes::nx::ObjectParameterSlot::assign" +#? {A slot foo info callable method assign} "::nsf::classes::nx::ObjectParameterSlot::assign" +? {A::slot::foo info callable method assign} "::nsf::classes::nx::ObjectParameterSlot::assign" # redefine setter for foo of class A -A slot foo method assign {domain var val} { +#A slot foo method assign {domain var val} ... +A::slot::foo method assign {domain var val} { # Do something with [self] that isn't valid pre-init puts setter-[self proc] $domain set $var $val @@ -457,11 +459,17 @@ } } +#? {r0 color} pink +#? {r0 r1 color} red +#? {r0 r1 x1 x} 1 +#? {r0 r1 x2 y} 2 +#? {r0 r2 color} green + ? {r0 color} pink -? {r0 r1 color} red -? {r0 r1 x1 x} 1 -? {r0 r1 x2 y} 2 -? {r0 r2 color} green +? {r0::r1 color} red +? {r0::r1::x1 x} 1 +? {r0::r1::x2 y} 2 +? {r0::r2 color} green #puts [r0 serialize] ####################################################### Index: tests/destroytest.tcl =================================================================== diff -u -r15d57478e3976d747741fd3df9bcb6ecccc7076d -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- tests/destroytest.tcl (.../destroytest.tcl) (revision 15d57478e3976d747741fd3df9bcb6ecccc7076d) +++ tests/destroytest.tcl (.../destroytest.tcl) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -442,14 +442,12 @@ ? {o x info vars} "" "call info on aliased object" ? {o2 set x 10} 10 "set variable on object" ? {o2 info vars} x "query vars" -? {o x info vars} x "query vars via alias" -? {o x set x} 10 "set var via alias" +## TODO: changed xxxx +#? {o x info vars} x "query vars via alias" +#? {o x set x} 10 "set var via alias" o2 destroy -catch {o x info vars} errMsg -? {set errMsg} "Trying to dispatch deleted object via method 'x'" "1st call on deleted object" -#? {set errMsg} "::o: unable to dispatch method 'x'" "1st call on deleted object" -catch {o x info vars} errMsg -? {set errMsg} "::o: unable to dispatch method 'x'" "2nd call on deleted object" +? {o x info vars} "Trying to dispatch deleted object via method 'x'" "1st call on deleted object" +? {o x info vars} "::o: unable to dispatch method 'x'" "2nd call on deleted object" o destroy set case "deleting object with alias to object" @@ -479,7 +477,8 @@ ::nsf::alias o x o3 Object create o3 o3 set a 13 -? {o x set a} 13 "aliased object works after recreate" +## TODO: changed xxxx +#? {o x set a} 13 "aliased object works after recreate" o destroy set case "create an alias on the class level, double aliasing, delete aliased object" @@ -492,11 +491,12 @@ C create c1 ? {c1 b set B 2} 2 "call 1st level" ? {c1 b a set A 3} 3 "call 2nd level" -? {o set B} 2 "call 1st level ok" -? {o3 set A} 3 "call 2nd level ok" + +## TODO: changed xxxx +#? {o set B} 2 "call 1st level ok" +#? {o3 set A} 3 "call 2nd level ok" o destroy -catch {c1 b} errMsg -? {set errMsg} "Trying to dispatch deleted object via method 'b'" "call via alias to deleted object" +? {c1 b} "Trying to dispatch deleted object via method 'b'" "call via alias to deleted object" C destroy c1 destroy o3 destroy @@ -570,7 +570,6 @@ ::module destroy } -puts stderr XXXXXXXXXXXXXX # to avoid CallDirectly, we could activate this line ::nx::Class create M {:method dealloc args {next}} Test case delete-parent-namespace-dealloc Index: tests/parameters.tcl =================================================================== diff -u -ra588ad9e5d66f12c4b2a5baf9153b652932a5912 -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 --- tests/parameters.tcl (.../parameters.tcl) (revision a588ad9e5d66f12c4b2a5baf9153b652932a5912) +++ tests/parameters.tcl (.../parameters.tcl) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) @@ -355,7 +355,7 @@ ? {Foo create foo -ints {1 a 2}} {invalid value in "1 a 2": expected integer but got "a" for parameter -ints} # make slot incremental - Foo slot ints eval { + Foo::slot::ints eval { set :incremental 1 :optimize } @@ -807,7 +807,7 @@ ? {ParamTest create p -u c1} {expected upper but got "c1" for parameter -u} ? {ParamTest create p -us {A B c}} \ {invalid value in "A B c": expected upper but got "c" for parameter -us} - ParamTest slot us eval { + ParamTest::slot::us eval { set :incremental 1 :optimize }