Index: generic/predefined.h =================================================================== diff -u -r98250df246d466fa544dd4aa10e0f5028f5883e7 -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 --- generic/predefined.h (.../predefined.h) (revision 98250df246d466fa544dd4aa10e0f5028f5883e7) +++ generic/predefined.h (.../predefined.h) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) @@ -488,6 +488,7 @@ "puts stderr \"current=[namespace current], ul=[uplevel {namespace current}]\"\n" "if {$callingNs ne \"::xotcl\"} {uplevel {namespace import -force ::xotcl::*}}}\n" "default {\n" +"if {$callingNs ne \"::xotcl\"} {uplevel {namespace import -force ::xotcl::*}}\n" "if {$callingNs ne \"::xotcl2\"} {uplevel {namespace import -force ::xotcl2::*}}}}}\n" "unset bootstrap}\n" ""; Index: generic/predefined.xotcl =================================================================== diff -u -r98250df246d466fa544dd4aa10e0f5028f5883e7 -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 98250df246d466fa544dd4aa10e0f5028f5883e7) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) @@ -919,6 +919,7 @@ if {$callingNs ne "::xotcl"} {uplevel {namespace import -force ::xotcl::*}} } default { + if {$callingNs ne "::xotcl"} {uplevel {namespace import -force ::xotcl::*}} if {$callingNs ne "::xotcl2"} {uplevel {namespace import -force ::xotcl2::*}} } } Index: generic/xotcl.c =================================================================== diff -u -re767edf5c498094f6e00150541bfb7beab52b619 -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 --- generic/xotcl.c (.../xotcl.c) (revision e767edf5c498094f6e00150541bfb7beab52b619) +++ generic/xotcl.c (.../xotcl.c) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) @@ -141,6 +141,7 @@ typedef struct AliasCmdClientData { XOTclObject *obj; + XOTclClass *class; Tcl_Obj *cmdName; Tcl_ObjCmdProc *objProc; Tcl_Command aliasedCmd; @@ -8729,7 +8730,7 @@ char *methodName = ObjStr(objv[0]); /*TODO: resolve the 'real' command at the end of the imported cmd chain */ - return MethodDispatch((ClientData)self, interp, objc, objv, tcd->aliasedCmd, self, self->cl, + return MethodDispatch((ClientData)self, interp, objc, objv, tcd->aliasedCmd, self, tcd->class, methodName, 0); } @@ -9796,6 +9797,7 @@ tcd = NEW(AliasCmdClientData); tcd->cmdName = NULL; tcd->obj = object; + tcd->class = allocation == 'c' ? (XOTclClass *) object : NULL; tcd->objProc = objProc; tcd->aliasedCmd = cmd; tcd->clientData = Tcl_Command_objClientData(cmd); @@ -12118,7 +12120,7 @@ int withNomixins, int withIncontext, char *pattern) { - int methodType; + int methodType = 0; switch (withMethodtype) { case MethodtypeNULL: /* default */ Index: library/lib/test.xotcl =================================================================== diff -u -r217d826e64107056ae97176552cae3c776991b9e -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 --- library/lib/test.xotcl (.../test.xotcl) (revision 217d826e64107056ae97176552cae3c776991b9e) +++ library/lib/test.xotcl (.../test.xotcl) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) @@ -2,7 +2,7 @@ package require XOTcl namespace eval ::xotcl::test { - namespace import ::xotcl2::* + ::xotcl::use xotcl2 @ @File {description { Simple regression test support. Index: tests/aliastest.xotcl =================================================================== diff -u --- tests/aliastest.xotcl (revision 0) +++ tests/aliastest.xotcl (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) @@ -0,0 +1,252 @@ +package require XOTcl +package require xotcl::test + +proc ? {cmd expected {msg ""}} { + set count 10 + if {$msg ne ""} { + set t [Test new -cmd $cmd -count $count -msg $msg] + } else { + set t [Test new -cmd $cmd -count $count] + } + $t expected $expected + $t run +} + +::xotcl::use xotcl2 + +Class create Base +Base method foo {{-x 1}} {return $x} + +Class create Foo +::xotcl::alias ::Foo foo ::xotcl::classes::Base::foo + +Foo create f1 +? {f1 foo} 1 +? {f1 foo -x 2} 2 + +? {Base info methods -defined -methodtype scripted} {foo} +? {Foo info methods -defined -methodtype scripted} {foo} +Base method foo {} {} +? {Base info methods -defined -methodtype scripted} {} +? {Foo info methods -defined -methodtype scripted} {} + +Base method foo {{-x 1}} {return $x} +::xotcl::alias ::Foo foo ::xotcl::classes::Base::foo + +? {Base info methods -defined -methodtype scripted} {foo} "defined again" +? {Foo info methods -defined -methodtype scripted} {foo} "aliased again" +# When the next three lines are added, we crash on exit +Foo method foo {} {} +? {Base info methods -defined -methodtype scripted} {foo} "still defined" +? {Foo info methods -defined -methodtype scripted} {} "removed" + +::xotcl::use xotcl1 + +::xotcl::alias ::xotcl::Object contains ::xotcl::classes::xotcl2::Object::contains + +::xotcl::Class create C +::C contains -object ::C::slot { + Attribute create x -initcmd {set x 1} + Attribute create y -initcmd {incr ::hu} + Attribute create z -initcmd {my trace add variable z read T1} +} + +? {::C info slots} "::C::slot::x ::C::slot::y ::C::slot::z" + +? {catch {::C contains -x 1 -object ::C::slot { + Attribute create w -initcmd {my trace add variable z read T1} +}}} 1 + +::xotcl::use xotcl2 + +# +# chaining aliases +# + + +Class create T +Class create S +T create t +S create s + + +T method foo args { return [self class]->[self proc] } +::xotcl::alias T FOO ::xotcl::classes::T::foo + +? {t foo} ::T->foo +? {t FOO} ::T->foo + +? {lsort [T info methods -defined -methodtype scripted]} {FOO foo} +T method foo {} {} +? {lsort [T info methods -defined -methodtype scripted]} {} "alias is deleted" + +# puts stderr "double indirection" +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 -defined -methodtype scripted]} {FOO foo} +? {S info methods -defined -methodtype scripted} {BAR} +T method FOO {} {} +? {T info methods -defined -methodtype scripted} {foo} +? {S info methods -defined -methodtype scripted} {BAR} +? {s BAR} ::S->foo +? {t foo} ::T->foo + +T method foo {} {} +? {T info methods -defined -methodtype scripted} {} +? {S info methods -defined -methodtype scripted} {} + +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 -defined -methodtype scripted]} {FOO foo} +? {S info methods -defined -methodtype scripted} {BAR} +T method foo {} {} +? {S info methods -defined -methodtype scripted} {} +? {T info methods -defined -methodtype scripted} {} + +T method foo args { return [self class]->[self proc] } +T method -per-object bar args { return [self class]->[self proc] } +::xotcl::alias T FOO -per-object ::xotcl::classes::T::foo +::xotcl::alias T BAR -per-object ::T::FOO +::xotcl::alias T ZAP -per-object ::T::BAR +? {T info methods -defined -methodtype scripted} {foo} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {BAR FOO ZAP bar} +? {t foo} ::T->foo +# +# ISSUE: Why does a [self class] in per-object aliases on method procs +# resolves to [::xotcl::Class] +# +? {T FOO} ->foo +? {T BAR} ->foo +? {T ZAP} ->foo +? {T bar} ->bar +T method -per-object FOO {} {} +? {T info methods -defined -methodtype scripted} {foo} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {BAR ZAP bar} +? {T BAR} ->foo +? {T ZAP} ->foo +rename ::T::BAR "" +? {T info methods -defined -methodtype scripted} {foo} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {ZAP bar} +#? {T BAR} ""; # now calling the proc defined above, alias chain seems intact +? {T ZAP} ->foo; # is ok, still pointing to 'foo' +#T method -per-object BAR {} {} +? {T info methods -defined -methodtype scripted} {foo} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {ZAP bar} +? {T ZAP} ->foo +T method foo {} {} +? {T info methods -defined -methodtype scripted} {} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {bar} + +# +# per-object methods as per-object aliases +# +T method -per-object m1 args { return [self class]->[self proc] } +::xotcl::alias T M1 -per-object ::T::m1 +::xotcl::alias T M11 -per-object ::T::M1 +? {lsort [T info methods -per-object -defined -methodtype scripted]} {M1 M11 bar m1} +? {T m1} ->m1 +? {T M1} ->m1 +? {T M11} ->m1 +T method -per-object M1 {} {} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {M11 bar m1} +? {T m1} ->m1 +? {T M11} ->m1 +T method -per-object m1 {} {} +? {lsort [T info methods -per-object -defined -methodtype scripted]} {bar} + +# +# a proc as alias +# + +proc foo args { return [self class]->[self proc] } +::xotcl::alias T FOO1 ::foo +::xotcl::alias T FOO2 -per-object ::foo +# +# ! per-object alias referenced as per-class alias ! +# +::xotcl::alias T BAR ::T::FOO2 +? {lsort [T info methods -per-object -defined -methodtype scripted]} {FOO2 bar} +? {lsort [T info methods -defined -methodtype scripted]} {BAR FOO1} +? {T FOO2} ->foo +? {t FOO1} ::T->foo +? {t BAR} ::T->foo +# +# delete proc +# +rename foo "" +? {lsort [T info methods -per-object -defined -methodtype scripted]} {bar} +? {lsort [T info methods -defined -methodtype scripted]} {} + +# namespaced procs + namespace deletion + +namespace eval ::ns1 { + proc foo args { return [self class]->[self proc] } + proc bar args { return [uplevel 2 {set _}] } + proc bar2 args { upvar 2 _ __; return $__} +} + +::xotcl::alias T FOO ::ns1::foo +::xotcl::alias T BAR ::ns1::bar +::xotcl::alias T BAR2 ::ns1::bar2 +? {lsort [T info methods -defined -methodtype scripted]} {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 -defined -methodtype scripted]} {} + +# per-object namespaces + +Class create U +U create u +? {namespace exists ::U} 0 +U method -per-object zap args { return [self class]->[self proc] } +::xotcl::alias ::U ZAP -per-object ::U::zap +U requireNamespace +? {namespace exists ::U} 1 + +U method -per-object bar args { return [self class]->[self proc] } +::xotcl::alias U BAR -per-object ::U::bar +? {lsort [U info methods -per-object -defined -methodtype scripted]} {BAR ZAP bar zap} +? {U BAR} ->bar +? {U ZAP} ->zap +namespace delete ::U +? {namespace exists ::U} 0 +? {lsort [U info methods -per-object -defined -methodtype scripted]} {} +? {U procsearch BAR} "" +? {U procsearch ZAP} "" + +::U destroy + +# dot-resolver/ dot-dispatcher used in aliased proc + +Class create V { + set .z 1 +} + +V create v { + set .z 2 +} + +V method bar {z} { return $z } + +V method -per-object bar {z} { return $z } + +proc foo args { return [.bar ${.z}]-[set .z]-[my bar [set .z]] } + +::xotcl::alias V FOO1 ::foo +::xotcl::alias V FOO2 -per-object ::foo +? {lsort [V info methods -per-object -defined -methodtype scripted]} {FOO2 bar} +? {lsort [V info methods -defined -methodtype scripted]} {FOO1 bar} +? {V FOO2} 1-1-1 +? {v FOO1} 2-2-2 +V method FOO1 {} {} +? {lsort [V info methods -defined -methodtype scripted]} {bar} +rename ::foo "" +? {lsort [V info methods -per-object -defined -methodtype scripted]} {bar} \ No newline at end of file Index: unix/tclAppInit.c =================================================================== diff -u -r2111020b49da8ce57758e51accf0b6073037f0d2 -r9f7fa883bf6ed48f1401f815caca1e34f56584a1 --- unix/tclAppInit.c (.../tclAppInit.c) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ unix/tclAppInit.c (.../tclAppInit.c) (revision 9f7fa883bf6ed48f1401f815caca1e34f56584a1) @@ -160,8 +160,7 @@ } Tcl_StaticPackage(interp, "XOTcl", Xotcl_Init, 0); - if (Tcl_Import(interp, Tcl_GetGlobalNamespace(interp), - "::xotcl::*", /* allowOverwrite */ 1) != TCL_OK) { + if (Tcl_Eval(interp, "::xotcl::use xotcl2") != TCL_OK) { return TCL_ERROR; }