Index: Makefile.in =================================================================== diff -u -N -r183ec0e7c071586238bf5ed90a05dbbda91d4582 -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- Makefile.in (.../Makefile.in) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) +++ Makefile.in (.../Makefile.in) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -463,8 +463,8 @@ # $(COMPILE) -c `@CYGPATH@ $(srcdir)/src/win/exampleA.c` -o $@ #======================================================================== -$(src_generic_dir)/predefined.h: $(src_generic_dir)/mk_predefined.xotcl $(src_generic_dir)/predefined.xotcl - (cd $(src_generic_dir); $(TCLSH) mk_predefined.xotcl > predefined.h) +$(src_generic_dir)/predefined.h: $(src_generic_dir)/mk_predefined.tcl $(src_generic_dir)/predefined.tcl + (cd $(src_generic_dir); $(TCLSH) mk_predefined.tcl > predefined.h) $(src_generic_dir)/tclAPI.h: $(src_generic_dir)/gentclAPI.tcl $(src_generic_dir)/gentclAPI.decls $(TCLSH) $(src_generic_dir)/gentclAPI.tcl > $(src_generic_dir)/tclAPI.h Index: TODO =================================================================== diff -u -N -r183ec0e7c071586238bf5ed90a05dbbda91d4582 -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- TODO (.../TODO) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) +++ TODO (.../TODO) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -857,6 +857,19 @@ - renamed xotcl.tcl to xotcl2.tcl - added proc finalize to xotcl2.tcl +- renamed mk_predefined.xotcl -> mk_predefined.tcl +- renamed predefined.xotcl -> predefined.tcl +- additional subcommand "info method parametersyntax " + returns parameters in a syntax similar to the tcl man pages +- added ability to pass syntax for forwarded methods + via set ::nx::core::signature(::nx::Object-method-forward) + (experimental) +- fixed documentation system to work with actual version +- added undocumented methods for quality control in documentation +- added checks for documented, but unavailable methods in documentation +- added comparison of documented parameters vs. actual parameters in documentation + + TODO: - nameing * .c-code: @@ -910,7 +923,15 @@ TODO "Kleinigkeiten" -- rename predefined.xotcl to .tcl +- decide on syntax in documentation + (info method parameter | info method parametersyntax | mixture) +- systematic way of specifying results of methods +- systematic way of reporting results in documentation +- reduce indenting for code examples in documentation (high indentation makes readability worse). +- make quality checks (missing documentation, ...) optional (maybe?) +- handle object methods as well in quality checks +- info method pararmetersyntax not defined for classical tcl procs (needed?) + - migrate further test from .xotcl to .tcl (based on next instead of xotcl) - check ::xotcl references in serializer Index: generic/gentclAPI.decls =================================================================== diff -u -N -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -291,20 +291,20 @@ # index. This numeric index is incremented upon each call to # {{{autoname}}}. # {{{ -# set obj [Object new] -# $obj autoname a; # yields "a1" -# $obj autoname -instance B; # yields "b1" -# $obj autoname a; # yields "a2" -# $obj autoname b; # yields "b1" -# $obj autoname -reset a; # "" -# $obj autoname -reset -instance B; # "" -# $obj autoname -instance a; # yields "a1", and NOT "a3"! -# $obj autoname -instance B; # yields "b1" -# $obj autoname b; # yields "b2" +# set obj [Object new] +# $obj autoname a; # yields "a1" +# $obj autoname -instance B; # yields "b1" +# $obj autoname a; # yields "a2" +# $obj autoname b; # yields "b1" +# $obj autoname -reset a; # "" +# $obj autoname -reset -instance B; # "" +# $obj autoname -instance a; # yields "a1", and NOT "a3"! +# $obj autoname -instance B; # yields "b1" +# $obj autoname b; # yields "b2" # }}} # The seeding string may also contain {{{[format]}}} expressions (see ...): # {{{ -# $obj autoname a%06d; # gives you "a000001", ... +# $obj autoname a%06d; # gives you "a000001", ... # }}} # # @param -instance Have the generated name start with a lower letter (though the seed string has a major first letter) @@ -355,8 +355,8 @@ # The method lays out the default object destruction process. By # calling {{{destroy}}} on an object, you request its destruction: # {{{ -# Object create anObject -# anObject destroy +# Object create anObject +# anObject destroy # }}} # Upon calling {{{destroy}}} on a given object, {{{destroy}}} # delegates the actual destruction to {{@method ::nx::Class class dealloc}} @@ -368,9 +368,9 @@ # }}} # Essentially, the behaviour could be scripted as: # {{{ -# Object method destroy {} { -# [:info class] dealloc [self] -# } +# Object method destroy {} { +# [:info class] dealloc [self] +# } # }}} # Note, however, that {{{destroy}}} is protected against # application-level redefinition. You must refine it in a subclass @@ -386,15 +386,15 @@ # defined on the object and assigned a value. You may use a variable # name with or without prefix, both will resolve to the object scope: # {{{ -# $obj eval { -# set :foo 1 -# set bar 2 -# } +# $obj eval { +# set :foo 1 +# set bar 2 +# } # -# $obj exists foo; # returns 1 -# $obj exists :foo; # returns 1 -# $obj exists bar; # returns 0 -# $obj exists :bar; # returns 0 +# $obj exists foo; # returns 1 +# $obj exists :foo; # returns 1 +# $obj exists bar; # returns 0 +# $obj exists :bar; # returns 0 # }}} # # @param var The name of the variable to verify @@ -403,9 +403,9 @@ {-argName "var" -required 1} } -# @method ::nx::Object#filter +# @method ::nx::Object#filterguard # -# Adds gateway conditions to guard a filter registration point. The +# Adds conditions to guard invocations of a filter. The # filter will only execute, if the guards evaluate to true. Otherwise, # the filters are ignored the filter. If no guards are given, we # always execute the filter. @@ -766,7 +766,7 @@ } infoObjectMethod method XOTclObjInfoMethodMethod { {-argName "object" -type object} - {-argName "infomethodsubcmd" -type "args|definition|name|parameter|type|precondition|postcondition"} + {-argName "infomethodsubcmd" -type "args|definition|name|parameter|parametersyntax|type|precondition|postcondition"} {-argName "name"} } infoObjectMethod methods XOTclObjInfoMethodsMethod { @@ -833,7 +833,7 @@ } infoClassMethod method XOTclClassInfoMethodMethod { {-argName "class" -type class} - {-argName "infomethodsubcmd" -type "args|body|definition|name|parameter|type|precondition|postcondition"} + {-argName "infomethodsubcmd" -type "args|body|definition|name|parameter|parametersyntax|type|precondition|postcondition"} {-argName "name"} } infoClassMethod methods XOTclClassInfoMethodsMethod { Index: generic/mk_predefined.tcl =================================================================== diff -u -N --- generic/mk_predefined.tcl (revision 0) +++ generic/mk_predefined.tcl (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -0,0 +1,26 @@ +#!./nxsh +# +# A small script file that creates a static array from a tcl- +# script for inclusion in c programs -gn +# +set f [open predefined.tcl] +set content [read $f] +close $f + +regsub -all {\\} $content && content +regsub -all {"} $content {\"} content ;#" +regsub -all "\[ \]+\n" $content \n content ;# remove trailing space +regsub -all "\n\[ \t\]+" $content \n content ;# remove leading space +while {[regsub -all "\n#\[^\n\]*\n" $content \n content]>0} { + ;# remove comment lines +} +regsub -all "\n#\[^\n\]*\n" $content \n content ;# remove comment lines +regsub -all "\[\n\]+" $content \n content ;# remove empty lines +regsub -all "\n}" $content "}" content ;# newlines btwn braces +regsub -all "\n" $content "\\n\"\n\"" content + +puts "static char cmd\[\] = " +puts "\"$content\";" +puts "" + + Index: generic/mk_predefined.xotcl =================================================================== diff -u -N --- generic/mk_predefined.xotcl (revision 2d07f2bafa5332c5e30f4969b4233d2345eab832) +++ generic/mk_predefined.xotcl (revision 0) @@ -1,26 +0,0 @@ -#!./xotclsh -# -# A small script file that creates a static array from a tcl- -# script for inclusion in c programs -gn -# -set f [open predefined.xotcl] -set content [read $f] -close $f - -regsub -all {\\} $content && content -regsub -all {"} $content {\"} content ;#" -regsub -all "\[ \]+\n" $content \n content ;# remove trailing space -regsub -all "\n\[ \t\]+" $content \n content ;# remove leading space -while {[regsub -all "\n#\[^\n\]*\n" $content \n content]>0} { - ;# remove comment lines -} -regsub -all "\n#\[^\n\]*\n" $content \n content ;# remove comment lines -regsub -all "\[\n\]+" $content \n content ;# remove empty lines -regsub -all "\n}" $content "}" content ;# newlines btwn braces -regsub -all "\n" $content "\\n\"\n\"" content - -puts "static char cmd\[\] = " -puts "\"$content\";" -puts "" - - Index: generic/nxDecls.h =================================================================== diff -u -N -raf4326a00a0f2d0b2f1e0369af71637f48c2d56a -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- generic/nxDecls.h (.../nxDecls.h) (revision af4326a00a0f2d0b2f1e0369af71637f48c2d56a) +++ generic/nxDecls.h (.../nxDecls.h) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -28,208 +28,206 @@ #ifndef Nx_Init_TCL_DECLARED #define Nx_Init_TCL_DECLARED /* 0 */ -EXTERN int Nx_Init (Tcl_Interp * interp); +EXTERN int Nx_Init(Tcl_Interp *interp); #endif /* Slot 1 is reserved */ #ifndef XOTclIsClass_TCL_DECLARED #define XOTclIsClass_TCL_DECLARED /* 2 */ -EXTERN struct XOTcl_Class * XOTclIsClass (Tcl_Interp * interp, ClientData cd); +EXTERN struct XOTcl_Class * XOTclIsClass(Tcl_Interp *interp, ClientData cd); #endif /* Slot 3 is reserved */ #ifndef XOTclGetObject_TCL_DECLARED #define XOTclGetObject_TCL_DECLARED /* 4 */ -EXTERN struct XOTcl_Object * XOTclGetObject (Tcl_Interp * interp, - CONST char * name); +EXTERN struct XOTcl_Object * XOTclGetObject(Tcl_Interp *interp, + CONST char *name); #endif #ifndef XOTclGetClass_TCL_DECLARED #define XOTclGetClass_TCL_DECLARED /* 5 */ -EXTERN struct XOTcl_Class * XOTclGetClass (Tcl_Interp * interp, - CONST char * name); +EXTERN struct XOTcl_Class * XOTclGetClass(Tcl_Interp *interp, + CONST char *name); #endif #ifndef XOTclCreateObject_TCL_DECLARED #define XOTclCreateObject_TCL_DECLARED /* 6 */ -EXTERN int XOTclCreateObject (Tcl_Interp * interp, - Tcl_Obj * name, struct XOTcl_Class * cl); +EXTERN int XOTclCreateObject(Tcl_Interp *interp, Tcl_Obj *name, + struct XOTcl_Class *cl); #endif /* Slot 7 is reserved */ /* Slot 8 is reserved */ #ifndef XOTclDeleteObject_TCL_DECLARED #define XOTclDeleteObject_TCL_DECLARED /* 9 */ -EXTERN int XOTclDeleteObject (Tcl_Interp * interp, - struct XOTcl_Object * obj); +EXTERN int XOTclDeleteObject(Tcl_Interp *interp, + struct XOTcl_Object *obj); #endif /* Slot 10 is reserved */ /* Slot 11 is reserved */ /* Slot 12 is reserved */ #ifndef XOTclRemoveObjectMethod_TCL_DECLARED #define XOTclRemoveObjectMethod_TCL_DECLARED /* 13 */ -EXTERN int XOTclRemoveObjectMethod (Tcl_Interp * interp, - struct XOTcl_Object * obj, CONST char * nm); +EXTERN int XOTclRemoveObjectMethod(Tcl_Interp *interp, + struct XOTcl_Object *obj, CONST char *nm); #endif #ifndef XOTclRemoveClassMethod_TCL_DECLARED #define XOTclRemoveClassMethod_TCL_DECLARED /* 14 */ -EXTERN int XOTclRemoveClassMethod (Tcl_Interp * interp, - struct XOTcl_Class * cl, CONST char * nm); +EXTERN int XOTclRemoveClassMethod(Tcl_Interp *interp, + struct XOTcl_Class *cl, CONST char *nm); #endif #ifndef XOTclOSetInstVar_TCL_DECLARED #define XOTclOSetInstVar_TCL_DECLARED /* 15 */ -EXTERN Tcl_Obj * XOTclOSetInstVar (struct XOTcl_Object * obj, - Tcl_Interp * interp, Tcl_Obj * name, - Tcl_Obj * value, int flgs); +EXTERN Tcl_Obj * XOTclOSetInstVar(struct XOTcl_Object *obj, + Tcl_Interp *interp, Tcl_Obj *name, + Tcl_Obj *value, int flgs); #endif #ifndef XOTclOGetInstVar_TCL_DECLARED #define XOTclOGetInstVar_TCL_DECLARED /* 16 */ -EXTERN Tcl_Obj * XOTclOGetInstVar (struct XOTcl_Object * obj, - Tcl_Interp * interp, Tcl_Obj * name, - int flgs); +EXTERN Tcl_Obj * XOTclOGetInstVar(struct XOTcl_Object *obj, + Tcl_Interp *interp, Tcl_Obj *name, int flgs); #endif /* Slot 17 is reserved */ /* Slot 18 is reserved */ #ifndef XOTcl_ObjSetVar2_TCL_DECLARED #define XOTcl_ObjSetVar2_TCL_DECLARED /* 19 */ -EXTERN Tcl_Obj * XOTcl_ObjSetVar2 (struct XOTcl_Object * obj, - Tcl_Interp * interp, Tcl_Obj * name1, - Tcl_Obj * name2, Tcl_Obj * value, int flgs); +EXTERN Tcl_Obj * XOTcl_ObjSetVar2(struct XOTcl_Object *obj, + Tcl_Interp *interp, Tcl_Obj *name1, + Tcl_Obj *name2, Tcl_Obj *value, int flgs); #endif #ifndef XOTcl_ObjGetVar2_TCL_DECLARED #define XOTcl_ObjGetVar2_TCL_DECLARED /* 20 */ -EXTERN Tcl_Obj * XOTcl_ObjGetVar2 (struct XOTcl_Object * obj, - Tcl_Interp * interp, Tcl_Obj * name1, - Tcl_Obj * name2, int flgs); +EXTERN Tcl_Obj * XOTcl_ObjGetVar2(struct XOTcl_Object *obj, + Tcl_Interp *interp, Tcl_Obj *name1, + Tcl_Obj *name2, int flgs); #endif #ifndef XOTclUnsetInstVar2_TCL_DECLARED #define XOTclUnsetInstVar2_TCL_DECLARED /* 21 */ -EXTERN int XOTclUnsetInstVar2 (struct XOTcl_Object * obj, - Tcl_Interp * interp, CONST char * name1, - CONST char * name2, int flgs); +EXTERN int XOTclUnsetInstVar2(struct XOTcl_Object *obj, + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flgs); #endif /* Slot 22 is reserved */ #ifndef XOTclErrMsg_TCL_DECLARED #define XOTclErrMsg_TCL_DECLARED /* 23 */ -EXTERN int XOTclErrMsg (Tcl_Interp * interp, char * msg, - Tcl_FreeProc * type); +EXTERN int XOTclErrMsg(Tcl_Interp *interp, char *msg, + Tcl_FreeProc *type); #endif #ifndef XOTclVarErrMsg_TCL_DECLARED #define XOTclVarErrMsg_TCL_DECLARED /* 24 */ -EXTERN int XOTclVarErrMsg (Tcl_Interp * interp, ...); +EXTERN int XOTclVarErrMsg(Tcl_Interp *interp, ...); #endif #ifndef XOTclErrInProc_TCL_DECLARED #define XOTclErrInProc_TCL_DECLARED /* 25 */ -EXTERN int XOTclErrInProc (Tcl_Interp * interp, - Tcl_Obj * objName, Tcl_Obj * clName, - CONST char * procName); +EXTERN int XOTclErrInProc(Tcl_Interp *interp, Tcl_Obj *objName, + Tcl_Obj *clName, CONST char *procName); #endif /* Slot 26 is reserved */ #ifndef XOTclErrBadVal__TCL_DECLARED #define XOTclErrBadVal__TCL_DECLARED /* 27 */ -EXTERN int XOTclErrBadVal_ (Tcl_Interp * interp, - char * expected, char * value); +EXTERN int XOTclErrBadVal_(Tcl_Interp *interp, char *expected, + char *value); #endif #ifndef XOTclObjErrType_TCL_DECLARED #define XOTclObjErrType_TCL_DECLARED /* 28 */ -EXTERN int XOTclObjErrType (Tcl_Interp * interp, Tcl_Obj * nm, - char * wt, char * parameterName); +EXTERN int XOTclObjErrType(Tcl_Interp *interp, Tcl_Obj *nm, + char *wt, char *parameterName); #endif #ifndef XOTclStackDump_TCL_DECLARED #define XOTclStackDump_TCL_DECLARED /* 29 */ -EXTERN void XOTclStackDump (Tcl_Interp * interp); +EXTERN void XOTclStackDump(Tcl_Interp *interp); #endif /* Slot 30 is reserved */ /* Slot 31 is reserved */ #ifndef XOTclSetObjClientData_TCL_DECLARED #define XOTclSetObjClientData_TCL_DECLARED /* 32 */ -EXTERN void XOTclSetObjClientData (XOTcl_Object * obj, +EXTERN void XOTclSetObjClientData(XOTcl_Object *obj, ClientData data); #endif #ifndef XOTclGetObjClientData_TCL_DECLARED #define XOTclGetObjClientData_TCL_DECLARED /* 33 */ -EXTERN ClientData XOTclGetObjClientData (XOTcl_Object * obj); +EXTERN ClientData XOTclGetObjClientData(XOTcl_Object *obj); #endif #ifndef XOTclSetClassClientData_TCL_DECLARED #define XOTclSetClassClientData_TCL_DECLARED /* 34 */ -EXTERN void XOTclSetClassClientData (XOTcl_Class * cl, +EXTERN void XOTclSetClassClientData(XOTcl_Class *cl, ClientData data); #endif #ifndef XOTclGetClassClientData_TCL_DECLARED #define XOTclGetClassClientData_TCL_DECLARED /* 35 */ -EXTERN ClientData XOTclGetClassClientData (XOTcl_Class * cl); +EXTERN ClientData XOTclGetClassClientData(XOTcl_Class *cl); #endif #ifndef XOTclRequireObjNamespace_TCL_DECLARED #define XOTclRequireObjNamespace_TCL_DECLARED /* 36 */ -EXTERN void XOTclRequireObjNamespace (Tcl_Interp * interp, - XOTcl_Object * obj); +EXTERN void XOTclRequireObjNamespace(Tcl_Interp *interp, + XOTcl_Object *obj); #endif #ifndef XOTclErrBadVal_TCL_DECLARED #define XOTclErrBadVal_TCL_DECLARED /* 37 */ -EXTERN int XOTclErrBadVal (Tcl_Interp * interp, char * context, - char * expected, CONST char * value); +EXTERN int XOTclErrBadVal(Tcl_Interp *interp, char *context, + char *expected, CONST char *value); #endif #ifndef XOTclNextObjCmd_TCL_DECLARED #define XOTclNextObjCmd_TCL_DECLARED /* 38 */ -EXTERN int XOTclNextObjCmd (ClientData cd, Tcl_Interp * interp, +EXTERN int XOTclNextObjCmd(ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); #endif #ifndef XOTclCallMethodWithArgs_TCL_DECLARED #define XOTclCallMethodWithArgs_TCL_DECLARED /* 39 */ -EXTERN int XOTclCallMethodWithArgs (ClientData cd, - Tcl_Interp * interp, Tcl_Obj * method, - Tcl_Obj * arg, int objc, +EXTERN int XOTclCallMethodWithArgs(ClientData cd, + Tcl_Interp *interp, Tcl_Obj *method, + Tcl_Obj *arg, int objc, Tcl_Obj *CONST objv[], int flags); #endif #ifndef XOTclObjErrArgCnt_TCL_DECLARED #define XOTclObjErrArgCnt_TCL_DECLARED /* 40 */ -EXTERN int XOTclObjErrArgCnt (Tcl_Interp * interp, - Tcl_Obj * cmdName, Tcl_Obj * methodName, - char * arglist); +EXTERN int XOTclObjErrArgCnt(Tcl_Interp *interp, + Tcl_Obj *cmdName, Tcl_Obj *methodName, + char *arglist); #endif #ifndef XOTclAddObjectMethod_TCL_DECLARED #define XOTclAddObjectMethod_TCL_DECLARED /* 41 */ -EXTERN int XOTclAddObjectMethod (Tcl_Interp * interp, - struct XOTcl_Object * obj, CONST char * nm, - Tcl_ObjCmdProc * proc, ClientData cd, - Tcl_CmdDeleteProc * dp, int flags); +EXTERN int XOTclAddObjectMethod(Tcl_Interp *interp, + struct XOTcl_Object *obj, CONST char *nm, + Tcl_ObjCmdProc *proc, ClientData cd, + Tcl_CmdDeleteProc *dp, int flags); #endif #ifndef XOTclAddClassMethod_TCL_DECLARED #define XOTclAddClassMethod_TCL_DECLARED /* 42 */ -EXTERN int XOTclAddClassMethod (Tcl_Interp * interp, - struct XOTcl_Class * cl, CONST char * nm, - Tcl_ObjCmdProc * proc, ClientData cd, - Tcl_CmdDeleteProc * dp, int flags); +EXTERN int XOTclAddClassMethod(Tcl_Interp *interp, + struct XOTcl_Class *cl, CONST char *nm, + Tcl_ObjCmdProc *proc, ClientData cd, + Tcl_CmdDeleteProc *dp, int flags); #endif #ifndef XOTclCreate_TCL_DECLARED #define XOTclCreate_TCL_DECLARED /* 43 */ -EXTERN int XOTclCreate (Tcl_Interp * in, XOTcl_Class * class, - Tcl_Obj * name, ClientData data, int objc, +EXTERN int XOTclCreate(Tcl_Interp *in, XOTcl_Class *class, + Tcl_Obj *name, ClientData data, int objc, Tcl_Obj *CONST objv[]); #endif @@ -241,50 +239,50 @@ int magic; struct NxStubHooks *hooks; - int (*nx_Init) (Tcl_Interp * interp); /* 0 */ + int (*nx_Init) (Tcl_Interp *interp); /* 0 */ void *reserved1; - struct XOTcl_Class * (*xOTclIsClass) (Tcl_Interp * interp, ClientData cd); /* 2 */ + struct XOTcl_Class * (*xOTclIsClass) (Tcl_Interp *interp, ClientData cd); /* 2 */ void *reserved3; - struct XOTcl_Object * (*xOTclGetObject) (Tcl_Interp * interp, CONST char * name); /* 4 */ - struct XOTcl_Class * (*xOTclGetClass) (Tcl_Interp * interp, CONST char * name); /* 5 */ - int (*xOTclCreateObject) (Tcl_Interp * interp, Tcl_Obj * name, struct XOTcl_Class * cl); /* 6 */ + struct XOTcl_Object * (*xOTclGetObject) (Tcl_Interp *interp, CONST char *name); /* 4 */ + struct XOTcl_Class * (*xOTclGetClass) (Tcl_Interp *interp, CONST char *name); /* 5 */ + int (*xOTclCreateObject) (Tcl_Interp *interp, Tcl_Obj *name, struct XOTcl_Class *cl); /* 6 */ void *reserved7; void *reserved8; - int (*xOTclDeleteObject) (Tcl_Interp * interp, struct XOTcl_Object * obj); /* 9 */ + int (*xOTclDeleteObject) (Tcl_Interp *interp, struct XOTcl_Object *obj); /* 9 */ void *reserved10; void *reserved11; void *reserved12; - int (*xOTclRemoveObjectMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char * nm); /* 13 */ - int (*xOTclRemoveClassMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char * nm); /* 14 */ - Tcl_Obj * (*xOTclOSetInstVar) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * value, int flgs); /* 15 */ - Tcl_Obj * (*xOTclOGetInstVar) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name, int flgs); /* 16 */ + int (*xOTclRemoveObjectMethod) (Tcl_Interp *interp, struct XOTcl_Object *obj, CONST char *nm); /* 13 */ + int (*xOTclRemoveClassMethod) (Tcl_Interp *interp, struct XOTcl_Class *cl, CONST char *nm); /* 14 */ + Tcl_Obj * (*xOTclOSetInstVar) (struct XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name, Tcl_Obj *value, int flgs); /* 15 */ + Tcl_Obj * (*xOTclOGetInstVar) (struct XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name, int flgs); /* 16 */ void *reserved17; void *reserved18; - Tcl_Obj * (*xOTcl_ObjSetVar2) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name1, Tcl_Obj * name2, Tcl_Obj * value, int flgs); /* 19 */ - Tcl_Obj * (*xOTcl_ObjGetVar2) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name1, Tcl_Obj * name2, int flgs); /* 20 */ - int (*xOTclUnsetInstVar2) (struct XOTcl_Object * obj, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flgs); /* 21 */ + Tcl_Obj * (*xOTcl_ObjSetVar2) (struct XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, Tcl_Obj *value, int flgs); /* 19 */ + Tcl_Obj * (*xOTcl_ObjGetVar2) (struct XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, int flgs); /* 20 */ + int (*xOTclUnsetInstVar2) (struct XOTcl_Object *obj, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flgs); /* 21 */ void *reserved22; - int (*xOTclErrMsg) (Tcl_Interp * interp, char * msg, Tcl_FreeProc * type); /* 23 */ - int (*xOTclVarErrMsg) (Tcl_Interp * interp, ...); /* 24 */ - int (*xOTclErrInProc) (Tcl_Interp * interp, Tcl_Obj * objName, Tcl_Obj * clName, CONST char * procName); /* 25 */ + int (*xOTclErrMsg) (Tcl_Interp *interp, char *msg, Tcl_FreeProc *type); /* 23 */ + int (*xOTclVarErrMsg) (Tcl_Interp *interp, ...); /* 24 */ + int (*xOTclErrInProc) (Tcl_Interp *interp, Tcl_Obj *objName, Tcl_Obj *clName, CONST char *procName); /* 25 */ void *reserved26; - int (*xOTclErrBadVal_) (Tcl_Interp * interp, char * expected, char * value); /* 27 */ - int (*xOTclObjErrType) (Tcl_Interp * interp, Tcl_Obj * nm, char * wt, char * parameterName); /* 28 */ - void (*xOTclStackDump) (Tcl_Interp * interp); /* 29 */ + int (*xOTclErrBadVal_) (Tcl_Interp *interp, char *expected, char *value); /* 27 */ + int (*xOTclObjErrType) (Tcl_Interp *interp, Tcl_Obj *nm, char *wt, char *parameterName); /* 28 */ + void (*xOTclStackDump) (Tcl_Interp *interp); /* 29 */ void *reserved30; void *reserved31; - void (*xOTclSetObjClientData) (XOTcl_Object * obj, ClientData data); /* 32 */ - ClientData (*xOTclGetObjClientData) (XOTcl_Object * obj); /* 33 */ - void (*xOTclSetClassClientData) (XOTcl_Class * cl, ClientData data); /* 34 */ - ClientData (*xOTclGetClassClientData) (XOTcl_Class * cl); /* 35 */ - void (*xOTclRequireObjNamespace) (Tcl_Interp * interp, XOTcl_Object * obj); /* 36 */ - int (*xOTclErrBadVal) (Tcl_Interp * interp, char * context, char * expected, CONST char * value); /* 37 */ - int (*xOTclNextObjCmd) (ClientData cd, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 38 */ - int (*xOTclCallMethodWithArgs) (ClientData cd, Tcl_Interp * interp, Tcl_Obj * method, Tcl_Obj * arg, int objc, Tcl_Obj *CONST objv[], int flags); /* 39 */ - int (*xOTclObjErrArgCnt) (Tcl_Interp * interp, Tcl_Obj * cmdName, Tcl_Obj * methodName, char * arglist); /* 40 */ - int (*xOTclAddObjectMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); /* 41 */ - int (*xOTclAddClassMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char * nm, Tcl_ObjCmdProc * proc, ClientData cd, Tcl_CmdDeleteProc * dp, int flags); /* 42 */ - int (*xOTclCreate) (Tcl_Interp * in, XOTcl_Class * class, Tcl_Obj * name, ClientData data, int objc, Tcl_Obj *CONST objv[]); /* 43 */ + void (*xOTclSetObjClientData) (XOTcl_Object *obj, ClientData data); /* 32 */ + ClientData (*xOTclGetObjClientData) (XOTcl_Object *obj); /* 33 */ + void (*xOTclSetClassClientData) (XOTcl_Class *cl, ClientData data); /* 34 */ + ClientData (*xOTclGetClassClientData) (XOTcl_Class *cl); /* 35 */ + void (*xOTclRequireObjNamespace) (Tcl_Interp *interp, XOTcl_Object *obj); /* 36 */ + int (*xOTclErrBadVal) (Tcl_Interp *interp, char *context, char *expected, CONST char *value); /* 37 */ + int (*xOTclNextObjCmd) (ClientData cd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* 38 */ + int (*xOTclCallMethodWithArgs) (ClientData cd, Tcl_Interp *interp, Tcl_Obj *method, Tcl_Obj *arg, int objc, Tcl_Obj *CONST objv[], int flags); /* 39 */ + int (*xOTclObjErrArgCnt) (Tcl_Interp *interp, Tcl_Obj *cmdName, Tcl_Obj *methodName, char *arglist); /* 40 */ + int (*xOTclAddObjectMethod) (Tcl_Interp *interp, struct XOTcl_Object *obj, CONST char *nm, Tcl_ObjCmdProc *proc, ClientData cd, Tcl_CmdDeleteProc *dp, int flags); /* 41 */ + int (*xOTclAddClassMethod) (Tcl_Interp *interp, struct XOTcl_Class *cl, CONST char *nm, Tcl_ObjCmdProc *proc, ClientData cd, Tcl_CmdDeleteProc *dp, int flags); /* 42 */ + int (*xOTclCreate) (Tcl_Interp *in, XOTcl_Class *class, Tcl_Obj *name, ClientData data, int objc, Tcl_Obj *CONST objv[]); /* 43 */ } NxStubs; #ifdef __cplusplus Index: generic/predefined.h =================================================================== diff -u -N -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- generic/predefined.h (.../predefined.h) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) +++ generic/predefined.h (.../predefined.h) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -81,7 +81,8 @@ ":protected method defaultmethod {} {::nx::core::current object}\n" ":protected method objectparameter {} {;}}\n" "::nx::core::forward Object forward ::nx::core::forward %self -per-object\n" -"::nx::core::forward Class forward ::nx::core::forward %self\n" +"set ::nx::core::signature(::nx::Object-method-forward) {(methodName) obj forward name ?-default default? ?-earlybinding? ?-methodprefix name? ?-objscope? ?-onerror proc? ?-verbose? target ?args?}\n" +"::nx::core::forward Class forward ::nx::core::forward %self\n" "Class protected object method __unknown {name} {}\n" "Object public method alias {-nonleaf:switch -objscope:switch methodName cmd} {\n" "::nx::core::alias [::nx::core::current object] -per-object $methodName \\\n" Index: generic/predefined.tcl =================================================================== diff -u -N --- generic/predefined.tcl (revision 0) +++ generic/predefined.tcl (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -0,0 +1,1456 @@ +namespace eval ::nx { + # + # By setting the variable bootstrap, we can check later, whether we + # are in bootstrapping mode + # + set bootstrap 1 + + #namespace path ::xotcl + + # + # First create the ::nx object system. + # + ::nx::core::createobjectsystem ::nx::Object ::nx::Class { + -class.alloc alloc + -class.create create + -class.dealloc dealloc + -class.recreate recreate + -class.requireobject __unknown + -object.configure configure + -object.defaultmethod defaultmethod + -object.destroy destroy + -object.init init + -object.move move + -object.objectparameter objectparameter + -object.residualargs residualargs + -object.unknown unknown + } + + # + # get frequenly used primitiva into the ::next namespace + # + namespace eval ::nx::core { + namespace export next self \ + my is relation interp + } + + + namespace import ::nx::core::next ::nx::core::self + + # + # provide the standard command set for ::nx::Object + # + foreach cmd [info command ::nx::core::cmd::Object::*] { + set cmdName [namespace tail $cmd] + if {$cmdName in [list "exists" "instvar"]} continue + ::nx::core::alias Object $cmdName $cmd + } + + # provide ::eval as method for ::nx::Object + ::nx::core::alias Object eval -nonleaf ::eval + + # provide the standard command set for Class + foreach cmd [info command ::nx::core::cmd::Class::*] { + set cmdName [namespace tail $cmd] + ::nx::core::alias Class $cmdName $cmd + } + + # set a few aliases as protected + foreach cmd [list __next cleanup noinit residualargs uplevel upvar] { + ::nx::core::methodproperty Object $cmd protected 1 + } + + foreach cmd [list recreate] { + ::nx::core::methodproperty Class $cmd protected 1 + } + # TODO: info methods shows finally "slots" and "slot". Wanted? + + # protect some methods against redefinition + ::nx::core::methodproperty Object destroy redefine-protected true + ::nx::core::methodproperty Class alloc redefine-protected true + ::nx::core::methodproperty Class dealloc redefine-protected true + ::nx::core::methodproperty Class create redefine-protected true + + # define method "method" for Class and Object + + # @method ::nx::Class#method + # + # Defines a per-class method, similarly to Tcl specifying + # {{{procs}}}. Optionally assertions may be specified by two + # additional arguments. Therefore, to specify only post-assertions + # an empty pre-assertion list must be given. All assertions are a + # list of ordinary Tcl {{{expr}}} statements. When {{{method}}} is + # called with an empty argument list and an empty body, the + # specified method is deleted. + # {{{ + # Class create AClass { + # :method foo args {;} + # } + # + # AClass create anInstance + # anInstance foo; # invokes "foo" + # }}} + # + # @param name The method name + # @param arguments:list A list specifying non-positional and positional parameters + # @param body The script which forms the method body + # @param preAssertion Optional assertions that must hold before the proc executes + # @param postAssertion Optional assertions that must hold after the proc executes + + ::nx::core::method Class method { + name arguments body -precondition -postcondition + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::nx::core::method [::nx::core::current object] $name $arguments $body {*}$conditions + } + + # @method ::nx::Object#method + # + # Defines a per-object method, similarly to Tcl specifying + # {{{procs}}}. Optionally assertions may be specified by two + # additional arguments. Therefore, to specify only post-assertions + # an empty pre-assertion list must be given. All assertions are a + # list of ordinary Tcl {{{expr}}} statements. When {{{method}}} is + # called with an empty argument list and an empty body, the + # specified method is deleted. + # {{{ + # Object create anObject { + # :method foo args {;} + # } + # anObject foo; # invokes "foo" + # }}} + # + # @param name The method name + # @param arguments:list A list specifying non-positional and positional parameters + # @param body The script which forms the method body + # @param preAssertion Optional assertions that must hold before the proc executes + # @param postAssertion Optional assertions that must hold after the proc executes + ::nx::core::method Object method { + name arguments body -precondition -postcondition + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::nx::core::method [::nx::core::current object] -per-object $name $arguments $body {*}$conditions + } + + # define method modifiers "object", "public" and "protected" + Class eval { + + # method-modifier for object specific methos + :method object {what args} { + if {$what in [list "alias" "attribute" "forward" "method" "setter"]} { + return [::nx::core::dispatch [::nx::core::current object] ::nx::core::classes::nx::Object::$what {*}$args] + } + if {$what in [list "info"]} { + return [::nx::objectInfo [lindex $args 0] [::nx::core::current object] {*}[lrange $args 1 end]] + } + if {$what in [list "filter" "mixin"]} { + return [:object-$what {*}$args] + } + if {$what in [list "filterguard" "mixinguard"]} { + return [::nx::core::dispatch [::nx::core::current object] ::nx::core::cmd::Object::$what {*}$args] + } + } + + # define unknown handler for class + :method unknown {m args} { + error "Method '$m' unknown for [::nx::core::current object].\ + Consider '[::nx::core::current object] create $m $args' instead of '[::nx::core::current object] $m $args'" + } + # protected is not jet defined + ::nx::core::methodproperty [::nx::core::current object] unknown protected 1 + } + + + Object eval { + + # method modifier "public" + :method public {args} { + set p [lsearch -regexp $args {^(method|alias|attribute|forward|setter)$}] + if {$p == -1} {error "$args is not a method defining method"} + set r [{*}:$args] + ::nx::core::methodproperty [::nx::core::current object] $r protected false + return $r + } + + # method modifier "protected" + :method protected {args} { + set p [lsearch -regexp $args {^(method|alias|attribute|forward|setter)$}] + if {$p == -1} {error "$args is not a method defining command"} + set r [{*}:$args] + ::nx::core::methodproperty [::nx::core::current object] $r [::nx::core::current method] true + return $r + } + + # unknown handler for Object + :protected method unknown {m args} { + if {![::nx::core::current isnext]} { + error "[::nx::core::current object]: unable to dispatch method '$m'" + } + } + + # "init" must exist on Object. per default it is empty. + :protected method init args {} + + # this method is called on calls to object without a specified method + :protected method defaultmethod {} {::nx::core::current object} + + # provide a placeholder for the bootup process. The real definition + # is based on slots, which are not available at this point. + :protected method objectparameter {} {;} + } + + # define forward methods + + # @method ::nx::Object#forward + # + # Register a per-object method (similar to a {{{proc}}}) for + # forward-delegating calls to a callee (target Tcl command, other + # object). When the forwarder method is called, the actual arguments + # of the invocation are appended to the specified arguments. In + # callee an arguments certain substitutions can take place: + # + # {{{%proc}}} substituted by name of the forwarder method + # + # {{{%self}}} substitute by name of the object + # + # {{{%1}}} substitute by first argument of the invocation + # + # {{{ {%@POS value} }}} substitute the specified value in the + # argument list on position POS, where POS can be a positive or + # negative integer or end. Positive integers specify the position + # from the begin of the list, while negative integer specify the + # position from the end. + # + # {{{ {%argclindex LIST} }}} take the nth argument of the specified + # list as substitution value, where n is the number of arguments + # from the invocation. + # + # {{{%%}}} a single percent. + # + # {{{%Tcl-command}}} command to be executed; substituted by result. + # + # Additionally each argument can be prefixed by the positional prefix + # %@POS (note the delimiting space at the end) that can be used to + # specify an explicit position. POS can be a positive or negative + # integer or the word end. The positional arguments are evaluated from + # left to right and should be used in ascending order. + # + # @param name The name of the delegating or forward method + # @param -objscope:optional Causes the target to be evaluated in the scope of the object. + # @param -methodprefix Prepends the specified prefix to the second argument of the invocation. + # @param -default Is used for default method names (only in connection with %1) + # @param -earlybinding Look up the function pointer of the called Tcl command at definition time of the forwarder instead of invocation time. This option should only be used for calling C-implemented Tcl commands, no scripted procs + # @param -verbose Print the substituted command to stderr before executing + # @param callee + # @param args + ::nx::core::forward Object forward ::nx::core::forward %self -per-object + set ::nx::core::signature(::nx::Object-method-forward) {(methodName) obj forward name ?-default default? ?-earlybinding? ?-methodprefix name? ?-objscope? ?-onerror proc? ?-verbose? target ?args?} + + # @method ::nx::Class#forward + # + # Register a per-class method (similar to a {{{proc}}}) for + # forward-delegating calls to a callee (target Tcl command, other + # object). When the forwarder method is called on an instance of the + # class, the actual arguments of the invocation are appended to the + # specified arguments. In callee an arguments certain substitutions + # can take place: + # + # {{{%proc}}} substituted by name of the forwarder method + # + # {{{%self}}} substitute by name of the object + # + # {{{%1}}} substitute by first argument of the invocation + # + # {{{ {%@POS value} }}} substitute the specified value in the + # argument list on position POS, where POS can be a positive or + # negative integer or end. Positive integers specify the position + # from the begin of the list, while negative integer specify the + # position from the end. + # + # {{{ {%argclindex LIST} }}} take the nth argument of the specified + # list as substitution value, where n is the number of arguments + # from the invocation. + # + # {{{%%}}} a single percent. + # + # {{{%Tcl-command}}} command to be executed; substituted by result. + # + # Additionally each argument can be prefixed by the positional prefix + # %@POS (note the delimiting space at the end) that can be used to + # specify an explicit position. POS can be a positive or negative + # integer or the word end. The positional arguments are evaluated from + # left to right and should be used in ascending order. + # + # @param name The name of the delegating or forward method + # @param -objscope:optional Causes the target to be evaluated in the scope of the object. + # @param -methodprefix Prepends the specified prefix to the second argument of the invocation. + # @param -default Is used for default method names (only in connection with %1) + # @param -earlybinding Look up the function pointer of the called Tcl command at definition time of the forwarder instead of invocation time. This option should only be used for calling C-implemented Tcl commands, no scripted procs + # @param -verbose Print the substituted command to stderr before executing + # @param callee + # @param args + ::nx::core::forward Class forward ::nx::core::forward %self + + # The method __unknown is called in cases, where we try to resolve + # an unkown class. one could define a custom resolver with this name + # to load the class on the fly. After the call to __unknown, XOTcl + # tries to resolve the class again. This meachnism is used e.g. by + # the ::ttrace mechanism for partial loading by Zoran. + # + Class protected object method __unknown {name} {} + + # Add alias methods. cmdName for XOTcl method can be added via + # [... info method name ] + # + # -nonleaf and -objscope make only sense for c-defined cmds, + # -objscope implies -nonleaf + # + Object public method alias {-nonleaf:switch -objscope:switch methodName cmd} { + ::nx::core::alias [::nx::core::current object] -per-object $methodName \ + {*}[expr {${objscope} ? "-objscope" : ""}] \ + {*}[expr {${nonleaf} ? "-nonleaf" : ""}] \ + $cmd + } + Class public method alias {-nonleaf:switch -objscope:switch methodName cmd} { + ::nx::core::alias [::nx::core::current object] $methodName \ + {*}[expr {${objscope} ? "-objscope" : ""}] \ + {*}[expr {${nonleaf} ? "-nonleaf" : ""}] \ + $cmd + } + + # Add setter methods. + # + Object public method setter {methodName} { + ::nx::core::setter [::nx::core::current object] -per-object $methodName + } + Class public method setter {methodName} { + ::nx::core::setter [::nx::core::current object] $methodName + } + + ######################## + # Info definition + ######################## + Object create ::nx::objectInfo + Object create ::nx::classInfo + + # + # It would be nice to do here "objectInfo configure {alias ..}", but + # we have no working objectparameter yet due to bootstrapping + # + objectInfo eval { + :alias is ::nx::core::objectproperty + + # info info + :public method info {obj} { + set methods [list] + foreach name [::nx::core::cmd::ObjectInfo::methods [::nx::core::current object]] { + if {$name eq "unknown"} continue + lappend methods $name + } + return "valid options are: [join [lsort $methods] {, }]" + } + + :method unknown {method obj args} { + error "[::nx::core::current object] unknown info option \"$method\"; [$obj info info]" + } + } + + classInfo eval { + :alias is ::nx::core::objectproperty + :alias classparent ::nx::core::cmd::ObjectInfo::parent + :alias classchildren ::nx::core::cmd::ObjectInfo::children + :alias info [::nx::core::cmd::ObjectInfo::method objectInfo name info] + :alias unknown [::nx::core::cmd::ObjectInfo::method objectInfo name info] + } + + foreach cmd [info command ::nx::core::cmd::ObjectInfo::*] { + ::nx::core::alias ::nx::objectInfo [namespace tail $cmd] $cmd + ::nx::core::alias ::nx::classInfo [namespace tail $cmd] $cmd + } + foreach cmd [info command ::nx::core::cmd::ClassInfo::*] { + set cmdName [namespace tail $cmd] + if {$cmdName in [list "object-mixin-of" "class-mixin-of"]} continue + ::nx::core::alias ::nx::classInfo $cmdName $cmd + } + unset cmd + + # register method "info" on Object and Class + Object forward info -onerror ::nx::core::infoError ::nx::objectInfo %1 {%@2 %self} + Class forward info -onerror ::nx::core::infoError ::nx::classInfo %1 {%@2 %self} + + proc ::nx::core::infoError msg { + #puts stderr "INFO ERROR: <$msg>\n$::errorInfo" + regsub -all " " $msg "" msg + regsub -all " " $msg "" msg + regsub {\"} $msg "\"info " msg + error $msg "" + } + + # + # definition of "abstract method foo ...." + # + Object method abstract {methtype -per-object:switch methname arglist} { + if {$methtype ne "method"} { + error "invalid method type '$methtype', must be 'method'" + } + set body " + if {!\[::nx::core::current isnextcall\]} { + error \"Abstract method $methname $arglist called\" + } else {::nx::core::next} + " + if {${per-object}} { + :method -per-object $methname $arglist $body + } else { + :method $methname $arglist $body + } + } + + # + # exit handlers + # + proc ::nx::core::unsetExitHandler {} { + proc ::nx::core::__exitHandler {} { + # clients should append exit handlers to this proc body + } + } + proc ::nx::core::setExitHandler {newbody} {::proc ::nx::core::__exitHandler {} $newbody} + proc ::nx::core::getExitHandler {} {::info body ::nx::core::__exitHandler} + # initialize exit handler + ::nx::core::unsetExitHandler + + namespace export Object Class next self +} + + +######################################## +# Slot definitions +######################################## +namespace eval ::nx { + # + # We are in bootstrap code; we cannot use slots/parameter to define + # slots, so the code is a little low level. After the defintion of + # the slots, we can use slot-based code such as "-parameter" or + # "objectparameter". + # + ::nx::Class create ::nx::MetaSlot + ::nx::core::relation ::nx::MetaSlot superclass ::nx::Class + + ::nx::MetaSlot public method slotName {name baseObject} { + # Create slot parent object if needed + set slotParent ${baseObject}::slot + if {![::nx::core::objectproperty ${slotParent} object]} { + ::nx::Object create ${slotParent} + } + return ${slotParent}::$name + } + + ::nx::MetaSlot method createFromParameterSyntax { + target -per-object:switch + {-initblock ""} + value default:optional + } { + set opts [list] + set colonPos [string first : $value] + if {$colonPos == -1} { + set name $value + } else { + set properties [string range $value [expr {$colonPos+1}] end] + set name [string range $value 0 [expr {$colonPos -1}]] + foreach property [split $properties ,] { + if {$property eq "required"} { + lappend opts -required 1 + } elseif {$property eq "multivalued"} { + lappend opts -multivalued 1 + } elseif {[string match type=* $property]} { + set type [string range $property 5 end] + if {![string match ::* $type]} {set type ::$type} + } elseif {[string match arg=* $property]} { + set argument [string range $property 4 end] + lappend opts -arg $argument + } else { + set type $property + } + } + } + if {[info exists type]} { + lappend opts -type $type + } + + if {[info exists default]} { + lappend opts -default $default + } + if {${per-object}} { + lappend opts -per-object true + set info ObjectInfo + } else { + set info ClassInfo + } + + :create [:slotName $name $target] {*}$opts $initblock + return [::nx::core::cmd::${info}::method $target name $name] + } + + # @object ::nx::Slot + # + # A slot is a meta-object that manages property changes of + # objects. A property is either an attribute or a role taken by an + # object in an inter-object relation (e.g., in system slots). The + # predefined system slots are {{{class}}}, {{{superclass}}}, + # {{{mixin}}}, and {{{filter}}}. These slots appear as methods of + # {{@object ::nx::Object}} or {{@object ::nx::Class}}. The slots + # provide a common getter and setter interface. Every multivalued + # slot provides e.g. a method {{{add}}} to append a value to the + # list of values, and a method {{{delete}}} which removes it. + # + # @superclass ::nx::doc::entities::object::nx::Object + ::nx::MetaSlot create ::nx::Slot + + # @object ::nx::ObjectParameterSlot + # + # @superclass ::nx::doc::entities::object::nx::Slot + ::nx::MetaSlot create ::nx::ObjectParameterSlot + ::nx::core::relation ::nx::ObjectParameterSlot superclass ::nx::Slot + + ::nx::MetaSlot create ::nx::MethodParameterSlot + ::nx::core::relation ::nx::MethodParameterSlot superclass ::nx::Slot + + # create an object for dispatching + ::nx::MethodParameterSlot create ::nx::methodParameterSlot + + # use low level interface for defining slot values. Normally, this is + # done via slot objects, which are defined later. + + proc createBootstrapAttributeSlots {class definitions} { + foreach att $definitions { + if {[llength $att]>1} {foreach {att default} $att break} + set slotObj [::nx::ObjectParameterSlot slotName $att $class] + ::nx::ObjectParameterSlot create $slotObj + if {[info exists default]} { + ::nx::core::setvar $slotObj default $default + unset default + } + ::nx::core::setter $class $att + } + + # + # Perform a second round to set default values for already defined + # objects. + # + foreach att $definitions { + if {[llength $att]>1} {foreach {att default} $att break} + if {[info exists default]} { + + # checking subclasses is not required during bootstrap + foreach i [::nx::core::cmd::ClassInfo::instances $class] { + if {![::nx::core::existsvar $i $att]} { + if {[string match {*\[*\]*} $default]} { + set value [::nx::core::dispatch $i -objscope ::eval subst $default] + } else { + set value $default + } + ::nx::core::setvar $i $att $value + } + } + unset default + } + } + + #puts stderr "Bootstrapslot for $class calls __invalidateobjectparameter" + $class __invalidateobjectparameter + } + + ############################################ + # Define slots for slots + ############################################ + + # @param ::nx::Slot#name + # + # Name of the slot which can be used to access the slot from an object + + # @param ::nx::Slot#multivalued + # + # Boolean value for specifying single or multiple values (lists) + + # @param ::nx::Slot#required + # + # Denotes whether a value must be provided + + # @param ::nx::Slot#default + # + # Allows you to define a default value (to be set upon object creation) + + # @param ::nx::Slot#type + # + # You may specify a type constraint on the value range to managed by the slot + + createBootstrapAttributeSlots ::nx::Slot { + {name} + {multivalued false} + {required false} + default + type + } + + # @param ::nx::ObjectParameterSlot#name + # + # Name of the slot which can be used to access the slot from an + # object. It defaults to unqualified name of an instance. + + # @param ::nx::ObjectParameterSlot#methodname + # + # The name of the accessor methods to be registed on behalf of the + # slot object with its domains can vary from the slot name. + + # @param ::nx::ObjectParameterSlot#domain + # + # The domain (object or class) of a slot on which it can be used + + # @param ::nx::ObjectParameterSlot#defaultmethods + # + # A list of two elements for specifying which methods are called per + # default, when no slot method is explicitly specified in a call. + + # @param ::nx::ObjectParameterSlot#manager + # + # The manager object of the slot (per default, the slot object takes + # this role, i.e. {{{[self]}}}) + + # @param ::nx::ObjectParameterSlot#per-object + # + # If set to {{{true}}}, the accessor methods are registered with the + # domain object scope only. It defaults to {{{false}}}. + + createBootstrapAttributeSlots ::nx::ObjectParameterSlot { + {name "[namespace tail [::nx::core::current object]]"} + {methodname} + {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::nx::core::current object]] 1]"} + {defaultmethods {get assign}} + {manager "[::nx::core::current object]"} + {per-object false} + } + # maybe add the following slots at some later time here + # initcmd + # valuecmd + # valuechangedcmd + + ::nx::core::alias ::nx::ObjectParameterSlot get ::nx::core::setvar + ::nx::core::alias ::nx::ObjectParameterSlot assign ::nx::core::setvar + + ::nx::ObjectParameterSlot public method add {obj prop value {pos 0}} { + if {![set :multivalued]} { + error "Property $prop of [set :domain]->$obj ist not multivalued" + } + if {[::nx::core::existsvar $obj $prop]} { + ::nx::core::setvar $obj $prop [linsert [::nx::core::setvar $obj $prop] $pos $value] + } else { + ::nx::core::setvar $obj $prop [list $value] + } + } + ::nx::ObjectParameterSlot public method delete {-nocomplain:switch obj prop value} { + set old [::nx::core::setvar $obj $prop] + set p [lsearch -glob $old $value] + if {$p>-1} {::nx::core::setvar $obj $prop [lreplace $old $p $p]} else { + error "$value is not a $prop of $obj (valid are: $old)" + } + } + + ::nx::ObjectParameterSlot method unknown {method args} { + set methods [list] + foreach m [:info callable] { + if {[::nx::Object info callable $m] ne ""} continue + if {[string match __* $m]} continue + lappend methods $m + } + error "Method '$method' unknown for slot [::nx::core::current object]; valid are: {[lsort $methods]}" + } + + ::nx::ObjectParameterSlot public method destroy {} { + if {${:domain} ne "" && [::nx::core::objectproperty ${:domain} class]} { + ${:domain} __invalidateobjectparameter + } + ::nx::core::next + } + + ::nx::ObjectParameterSlot protected method init {args} { + if {${:domain} eq ""} { + set :domain [::nx::core::current callingobject] + } + if {${:domain} ne ""} { + if {![info exists :methodname]} { + set :methodname ${:name} + } + if {[::nx::core::objectproperty ${:domain} class]} { + ${:domain} __invalidateobjectparameter + } + if {${:per-object} && [info exists :default] } { + ::nx::core::setvar ${:domain} ${:name} ${:default} + } + set cl [expr {${:per-object} ? "Object" : "Class"}] + #puts stderr "Slot [::nx::core::current object] init, forwarder on ${:domain}" + ::nx::core::forward ${:domain} ${:name} \ + ${:manager} \ + [list %1 [${:manager} defaultmethods]] %self \ + ${:methodname} + } + } + + ################################################################# + # We have no working objectparameter yet, since it requires a + # minimal slot infrastructure to build object parameters from + # slots. The above definitions should be sufficient. We provide the + # definition here before we refine the slot definitions. + # + # Invalidate previously defined object parameter. + ::nx::MetaSlot __invalidateobjectparameter + + # Provide the a slot based mechanism for building an object + # configuration interface from slot definitions + ::nx::ObjectParameterSlot method toParameterSyntax {{name:substdefault ${:name}}} { + set objparamdefinition $name + set methodparamdefinition "" + set objopts [list] + set methodopts [list] + set type "" + if {[info exists :required] && ${:required}} { + lappend objopts required + lappend methodopts required + } + if {[info exists :type]} { + if {[string match ::* ${:type}]} { + set type [expr {[::nx::core::objectproperty ${:type} metaclass] ? "class" : "object"}] + lappend objopts type=${:type} + lappend methodopts type=${:type} + } else { + set type ${:type} + } + } + # TODO: remove multivalued check on relations by handling multivalued + # not in relation, but in the converters + if {[info exists :multivalued] && ${:multivalued}} { + if {!([info exists :type] && ${:type} eq "relation")} { + lappend objopts multivalued + } else { + #puts stderr "ignore multivalued for $name in relation" + } + } + if {[info exists :arg]} { + set prefix [expr {$type eq "object" || $type eq "class" ? "type" : "arg"}] + lappend objopts $prefix=${:arg} + lappend methodopts $prefix=${:arg} + } + if {[info exists :default]} { + set arg ${:default} + # deactivated for now: || [string first {$} $arg] > -1 + if {[string match {*\[*\]*} $arg] + && $type ne "substdefault"} { + lappend objopts substdefault + } + } elseif {[info exists :initcmd]} { + set arg ${:initcmd} + lappend objopts initcmd + } + if {[info exists :methodname]} { + if {${:methodname} ne ${:name}} { + lappend objopts arg=${:methodname} + lappend methodopts arg=${:methodname} + #puts stderr "..... setting arg for methodname: [::nx::core::current object] has arg arg=${:methodname}" + } + } + if {$type ne ""} { + set objopts [linsert $objopts 0 $type] + # Never add "substdefault" to methodopts, since these are for + # provided values, not for defaults. + if {$type ne "substdefault"} {set methodopts [linsert $methodopts 0 $type]} + } + lappend objopts slot=[::nx::core::current object] + + if {[llength $objopts] > 0} { + append objparamdefinition :[join $objopts ,] + } + if {[llength $methodopts] > 0} { + set methodparamdefinition [join $methodopts ,] + } + if {[info exists arg]} { + lappend objparamdefinition $arg + } + #puts stderr "[::nx::core::current method] ${name} returns [list oparam $objparamdefinition mparam $methodparamdefinition]" + return [list oparam $objparamdefinition mparam $methodparamdefinition] + } + + + proc ::nx::core::parametersFromSlots {obj} { + set parameterdefinitions [list] + foreach slot [::nx::objectInfo slotobjects $obj] { + # Skip some slots for xotcl; + # TODO: maybe different parameterFromSlots for xotcl? + if {[::nx::core::objectproperty ::xotcl::Object class] + && [::nx::core::objectproperty $obj type ::xotcl::Object] && + ([$slot name] eq "mixin" || [$slot name] eq "filter") + } continue + array set "" [$slot toParameterSyntax] + lappend parameterdefinitions -$(oparam) + } + return $parameterdefinitions + } + + # @method ::nx::Object#objectparameter + ::nx::Object protected method objectparameter {{lastparameter __initcmd:initcmd,optional}} { + #puts stderr "... objectparameter [::nx::core::current object]" + set parameterdefinitions [::nx::core::parametersFromSlots [::nx::core::current object]] + if {[::nx::core::objectproperty [::nx::core::current object] class]} { + lappend parameterdefinitions -parameter:method,optional + } + lappend parameterdefinitions \ + -noinit:method,optional,noarg \ + -volatile:method,optional,noarg \ + {*}$lastparameter + #puts stderr "*** parameter definition for [::nx::core::current object]: $parameterdefinitions" + return $parameterdefinitions + } + + + ############################################ + # RelationSlot + ############################################ + ::nx::MetaSlot create ::nx::RelationSlot + createBootstrapAttributeSlots ::nx::RelationSlot { + {multivalued true} + {type relation} + {elementtype ::nx::Class} + } + ::nx::core::relation ::nx::RelationSlot superclass ::nx::ObjectParameterSlot + ::nx::core::alias ::nx::RelationSlot assign ::nx::core::relation + + ::nx::RelationSlot protected method init {} { + if {${:type} ne "relation"} { + error "RelationSlot requires type == \"relation\"" + } + ::nx::core::next + } + ::nx::RelationSlot protected method delete_value {obj prop old value} { + if {[string first * $value] > -1 || [string first \[ $value] > -1} { + # value contains globbing meta characters + if {${:elementtype} ne "" && ![string match ::* $value]} { + # prefix glob pattern with ::, since all object names have leading :: + set value ::$value + } + return [lsearch -all -not -glob -inline $old $value] + } elseif {${:elementtype} ne ""} { + # value contains no globbing meta characters, but elementtype is given + if {[string first :: $value] == -1} { + # get fully qualified name + if {![::nx::core::objectproperty $value object]} { + error "$value does not appear to be an object" + } + set value [::nx::core::dispatch $value -objscope ::nx::core::current object] + } + if {![::nx::core::objectproperty ${:elementtype} class]} { + error "$value does not appear to be of type ${:elementtype}" + } + } + set p [lsearch -exact $old $value] + if {$p > -1} { + return [lreplace $old $p $p] + } else { + error "$value is not a $prop of $obj (valid are: $old)" + } + } + + ::nx::RelationSlot public method delete {-nocomplain:switch obj prop value} { + #puts stderr RelationSlot-delete-[::nx::core::current args] + $obj $prop [:delete_value $obj $prop [$obj info $prop] $value] + } + + ::nx::RelationSlot public method get {obj prop} { + ::nx::core::relation $obj $prop + } + + ::nx::RelationSlot public method add {obj prop value {pos 0}} { + if {![set :multivalued]} { + error "Property $prop of ${:domain}->$obj ist not multivalued" + } + set oldSetting [::nx::core::relation $obj $prop] + # use uplevel to avoid namespace surprises + uplevel [list ::nx::core::relation $obj $prop [linsert $oldSetting $pos $value]] + } + ::nx::RelationSlot public method delete {-nocomplain:switch obj prop value} { + uplevel [list ::nx::core::relation $obj $prop [:delete_value $obj $prop [::nx::core::relation $obj $prop] $value]] + } + + + ############################################ + # system slots + ############################################ + proc ::nx::core::register_system_slots {os} { + ${os}::Object alloc ${os}::Class::slot + ${os}::Object alloc ${os}::Object::slot + + # @param ::nx::Class#superclass + # + # Specifies superclasses for a given class. As a setter, + # {{{superclass}}} changes the list of superclasses. When used as + # a getter, the method returns the current superclasses. + # + # @return :list If called as a getter (without arguments), + # {{{superclass}}} returns the current superclasses of the object + ::nx::RelationSlot create ${os}::Class::slot::superclass + ::nx::core::alias ${os}::Class::slot::superclass assign ::nx::core::relation + + # @param ::nx::Object#class + # + # Sets or retrieves the class of an object. When {{{class}}} is + # called without arguments, it returns the current class of the + # object. + # + # @return If called as a getter (without arguments), {{{class}}} returns the current class of the object + ::nx::RelationSlot create ${os}::Object::slot::class -multivalued false + ::nx::core::alias ${os}::Object::slot::class assign ::nx::core::relation + + # @param ::nx::Object#mixin + # + # As a setter, {{{mixin}}} specifies a list of mixins to + # set. Every mixin must be an existing class. In getter mode, you + # can retrieve the list of mixins active for the given object. + # + # @return :list If called as a getter (without arguments), {{{mixin}}} returns the list of current mixin classes registered with the object + ::nx::RelationSlot create ${os}::Object::slot::mixin -methodname object-mixin + + # @param ::nx::Object#filter + # + # In its setter mode, {{{filter}}} allows you to register methods + # as per-object filters. Every filter must be an existing method + # in the scope of the object. When acting as a getter, you can + # retrieve the list of filter methods active for the given object. + # + # @return :list If called as a getter (without arguments), + # {{{filter}}} returns the list of current filters + # registered with the object + ::nx::RelationSlot create ${os}::Object::slot::filter -elementtype "" + + # @param ::nx::Class#mixin + # + # As a setter, {{{mixin}}} specifies a list of mixins to set for + # the class. Every mixin must be an existing class. In getter + # mode, you can retrieve the list of mixins active for the given + # class. + # + # @return :list If called as a getter (without arguments), {{{mixin}}} returns the list of current mixin classes registered with the class + ::nx::RelationSlot create ${os}::Class::slot::mixin -methodname class-mixin + + # @param ::nx::Class#filter + # + # In its setter mode, {{{filter}}} allows you to register methods + # as per-class filters. Every filter must be an existing method + # in the scope of the class. When acting as a getter, you can + # retrieve the list of filter methods active for the given class. + # + # @return :list If called as a getter (without arguments), + # {{{filter}}} returns the list of current filters + # registered with the class + ::nx::RelationSlot create ${os}::Class::slot::filter -elementtype "" \ + -methodname class-filter + + # Create two conveniance slots to allow configuration of + # object-slots for classes via object-mixin + ::nx::RelationSlot create ${os}::Class::slot::object-mixin + ::nx::RelationSlot create ${os}::Class::slot::object-filter -elementtype "" + } + + ::nx::core::register_system_slots ::nx + proc ::nx::core::register_system_slots {} {} + + + ############################################ + # Attribute slots + ############################################ + ::nx::MetaSlot __invalidateobjectparameter + + # @object ::nx::Attribute + # + # Attribute slots are used to manage the access, mutation, and + # querying of instance variables. One defines Attribute slots + # for objects and classes usually via the helper method + # {{@method ::nx::Object class attribute}} + # **** TODO STEFAN, kein Link? GEPLANT? MIT 2 GESCHWEIFTEN KLAMMER UM SALARY GIBT ES EINEN LAUFZEITFEHLER??? ******** + # The following example defines a class with + # three attribute slots. The attribute {salary} has + # a default of {0}, the attribute {projects} has the + # empty list as default and is defined as multivalued. + # {{{ + # Class create Person { + # :attribute name + # :attribute {salary:integer 0} + # :attribute {projects:multivalued ""} { + # set :incremental true + # } + # } + # }}} + # + # @param incremental A boolean value, only useful for multivalued slots. When set, one can add/delete incrementally values to the multivalued set (e.g., through an incremental {{{add}}}) + # @param valuecmd A Tcl command to be executed whenever the managed object variable is read + # @param valuechangedcmd A Tcl command to be executed whenever the value of the managed object variable changes + # @param arg + # @superclass ::nx::doc::entities::object::nx::ObjectParameterSlot + ::nx::MetaSlot create ::nx::Attribute -superclass ::nx::ObjectParameterSlot + + createBootstrapAttributeSlots ::nx::Attribute { + {value_check once} + incremental + initcmd + valuecmd + valuechangedcmd + arg + } + + ::nx::Attribute method __default_from_cmd {obj cmd var sub op} { + #puts "GETVAR [::nx::core::current method] obj=$obj cmd=$cmd, var=$var, op=$op" + $obj trace remove variable $var $op [list [::nx::core::current object] [::nx::core::current method] $obj $cmd] + ::nx::core::setvar $obj $var [$obj eval $cmd] + } + ::nx::Attribute method __value_from_cmd {obj cmd var sub op} { + #puts "GETVAR [::nx::core::current method] obj=$obj cmd=$cmd, var=$var, op=$op" + ::nx::core::setvar $obj $var [$obj eval $cmd] + } + ::nx::Attribute method __value_changed_cmd {obj cmd var sub op} { + # puts stderr "**************************" + # puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op, ...\n$obj exists $var -> [::nx::core::setvar $obj $var]" + eval $cmd + } + ::nx::Attribute protected method init {} { + ::nx::core::next ;# do first ordinary slot initialization + # there might be already default values registered on the class + set __initcmd "" + if {[info exists :default]} { + } elseif [info exists :initcmd] { + append __initcmd ":trace add variable [list ${:name}] read \ + \[list [::nx::core::current object] __default_from_cmd \[::nx::core::current object\] [list [set :initcmd]]\]\n" + } elseif [info exists :valuecmd] { + append __initcmd ":trace add variable [list ${:name}] read \ + \[list [::nx::core::current object] __value_from_cmd \[::nx::core::current object\] [list [set :valuecmd]]\]" + } + array set "" [:toParameterSyntax ${:name}] + + #puts stderr "Attribute.init valueParam for [::nx::core::current object] is $(mparam)" + if {$(mparam) ne ""} { + if {[info exists :multivalued] && ${:multivalued}} { + #puts stderr "adding assign [list obj var value:$(mparam),multivalued] // for [::nx::core::current object] with $(mparam)" + :method assign [list obj var value:$(mparam),multivalued,slot=[::nx::core::current object]] { + ::nx::core::setvar $obj $var $value + } + #puts stderr "adding add method for [::nx::core::current object] with value:$(mparam)" + :method add [list obj prop value:$(mparam),slot=[::nx::core::current object] {pos 0}] { + ::nx::core::next + } + } else { + #puts stderr "SV adding assign [list obj var value:$(mparam)] // for [::nx::core::current object] with $(mparam)" + :method assign [list obj var value:$(mparam),slot=[::nx::core::current object]] { + ::nx::core::setvar $obj $var $value + } + + } + } + if {[info exists :valuechangedcmd]} { + append __initcmd ":trace add variable [list ${:name}] write \ + \[list [::nx::core::current object] __value_changed_cmd \[::nx::core::current object\] [list [set :valuechangedcmd]]\]" + } + if {$__initcmd ne ""} { + set :initcmd $__initcmd + } + } + + # mixin class for optimizing slots + ::nx::Class create ::nx::Attribute::Optimizer { + + :method method args {::nx::core::next; :optimize} + :method forward args {::nx::core::next; :optimize} + :protected method init args {::nx::core::next; :optimize} + + :public method optimize {} { + #puts stderr OPTIMIZER-[info exists :incremental] + if {![info exists :methodname]} {return} + set object [expr {${:per-object} ? {object} : {}}] + if {${:per-object}} { + set perObject -per-object + set infokind Object + } else { + set perObject "" + set infokind Class + } + if {[::nx::core::cmd::${infokind}Info::method ${:domain} name ${:name}] ne ""} { + #puts stderr "OPTIMIZER RESETTING ${:domain} slot ${:name}" + ::nx::core::forward ${:domain} {*}$perObject ${:name} \ + ${:manager} \ + [list %1 [${:manager} defaultmethods]] %self \ + ${:methodname} + } + #puts stderr "OPTIMIZER incremental [info exists :incremental] def '[set :defaultmethods]'" + if {[info exists :incremental] && ${:incremental}} return + if {[set :defaultmethods] ne {get assign}} return + set assignInfo [:info callable -which assign] + #puts stderr "OPTIMIZER assign=$assignInfo//[lindex $assignInfo {end 0}]//[:info precedence]" + + if {$assignInfo ne "::nx::ObjectParameterSlot alias assign ::nx::core::setvar" && + [lindex $assignInfo {end 0}] ne "::nx::core::setvar" } return + if {[:info callable -which get] ne "::nx::ObjectParameterSlot alias get ::nx::core::setvar"} return + + array set "" [:toParameterSyntax ${:name}] + if {$(mparam) ne ""} { + set setterParam [lindex $(oparam) 0] + #puts stderr "setterParam=$setterParam, op=$(oparam)" + } else { + set setterParam ${:name} + } + ::nx::core::setter ${:domain} {*}$perObject $setterParam + #puts stderr "::nx::core::setter ${:domain} {*}$perObject $setterParam" + } + } + # register the optimizer per default + ::nx::Attribute mixin add ::nx::Attribute::Optimizer + + ############################################ + # Define method "attribute" for convenience + ############################################ + ::nx::Class method attribute {spec {-slotclass ::nx::Attribute} {initblock ""}} { + $slotclass createFromParameterSyntax [::nx::core::current object] -initblock $initblock {*}$spec + } + ::nx::Object method attribute {spec {-slotclass ::nx::Attribute} {initblock ""}} { + $slotclass createFromParameterSyntax [::nx::core::current object] -per-object -initblock $initblock {*}$spec + } + ############################################ + # Define method "parameter" for backward + # compatibility and convenience + ############################################ + ::nx::Class public method parameter arglist { + + foreach arg $arglist { + ::nx::Attribute createFromParameterSyntax [::nx::core::current object] {*}$arg + } + # todo needed? + set slot [::nx::core::current object]::slot + if {![::nx::core::objectproperty $slot object]} {::nx::Object create $slot} + ::nx::core::setvar $slot __parameter $arglist + } + ::nx::core::method ::nx::classInfo parameter {class} { + set slot ${class}::slot + if {![::nx::core::objectproperty $slot object]} {::nx::Object create $slot} + if {[::nx::core::existsvar $slot __parameter]} { + return [::nx::core::setvar $slot __parameter] + } + return "" + } + + ################################################################## + # now the slots are defined; now we can defines the Objects or + # classes with parameters more easily than above. + ################################################################## + + # remove helper proc + proc createBootstrapAttributeSlots {} {} + + ################################################################## + # create user-level converter/checker based on ::nx::core primitves + ################################################################## + + ::nx::Slot method type=hasmixin {name value arg} { + if {![::nx::core::objectproperty $value hasmixin $arg]} { + error "expected object with mixin $arg but got \"$value\" for parameter $name" + } + return $value + } + + ::nx::Slot method type=baseclass {name value} { + if {![::nx::core::objectproperty $value baseclass]} { + error "expected baseclass but got \"$value\" for parameter $name" + } + return $value + } + + ::nx::Slot method type=metaclass {name value} { + if {![::nx::core::objectproperty $value metaclass]} { + error "expected metaclass but got \"$value\" for parameter $name" + } + return $value + } + +} + +################################################################## +# Create a mixin class to overload method "new" such it does not +# allocate new objects in ::nx::*, but in the specified object +# (without syntactic overhead). +################################################################## + +::nx::Class create ::nx::ScopedNew -superclass ::nx::Class { + + :attribute {withclass ::nx::Object} + :attribute container + + :protected method init {} { + :public method new {-childof args} { + ::nx::core::importvar [::nx::core::current class] {container object} withclass + if {![::nx::core::objectproperty $object object]} { + $withclass create $object + } + eval ::nx::core::next -childof $object $args + } + } +} + +################################################################## +# The method 'contains' changes the namespace in which objects with +# realtive names are created. Therefore, 'contains' provides a +# friendly notation for creating nested object structures. Optionally, +# creating new objects in the specified scope can be turned off. +################################################################## + +::nx::Object public method contains { + {-withnew:boolean true} + -object + {-class ::nx::Object} + cmds + } { + if {![info exists object]} {set object [::nx::core::current object]} + if {![::nx::core::objectproperty $object object]} {$class create $object} + $object requireNamespace + if {$withnew} { + set m [::nx::ScopedNew new -volatile \ + -container $object -withclass $class] + ::nx::Class mixin add $m end + # TODO: the following is not pretty; however, contains might build xotcl1 and next objects. + if {[::nx::core::objectproperty ::xotcl::Class class]} {::xotcl::Class instmixin add $m end} + namespace eval $object $cmds + ::nx::Class mixin delete $m + if {[::nx::core::objectproperty ::xotcl::Class class]} {::xotcl::Class instmixin delete $m} + } else { + namespace eval $object $cmds + } +} +::nx::Class forward slots %self contains \ + -object {%::nx::core::dispatch [::nx::core::current object] -objscope ::subst [::nx::core::current object]::slot} + +################################################################## +# copy/move implementation +################################################################## + +::nx::Class create ::nx::CopyHandler { + + :attribute {targetList ""} + :attribute {dest ""} + :attribute objLength + + :method makeTargetList {t} { + lappend :targetList $t + #puts stderr "COPY makeTargetList $t target= ${:targetList}" + # if it is an object without namespace, it is a leaf + if {[::nx::core::objectproperty $t object]} { + if {[$t info hasnamespace]} { + # make target list from all children + set children [$t info children] + } else { + # ok, no namespace -> no more children + return + } + } + # now append all namespaces that are in the obj, but that + # are not objects + foreach c [namespace children $t] { + if {![::nx::core::objectproperty $c object]} { + lappend children [namespace children $t] + } + } + + # a namespace or an obj with namespace may have children + # itself + foreach c $children { + :makeTargetList $c + } + } + + + :method copyNSVarsAndCmds {orig dest} { + ::nx::core::namespace_copyvars $orig $dest + ::nx::core::namespace_copycmds $orig $dest + } + + # construct destination obj name from old qualified ns name + :method getDest origin { + set tail [string range $origin [set :objLength] end] + return ::[string trimleft [set :dest]$tail :] + } + + :method copyTargets {} { + #puts stderr "COPY will copy targetList = [set :targetList]" + foreach origin [set :targetList] { + set dest [:getDest $origin] + if {[::nx::core::objectproperty $origin object]} { + # copy class information + if {[::nx::core::objectproperty $origin class]} { + set cl [[$origin info class] create $dest -noinit] + # class object + set obj $cl + $cl superclass [$origin info superclass] + ::nx::core::assertion $cl class-invar [::nx::core::assertion $origin class-invar] + ::nx::core::relation $cl class-filter [::nx::core::relation $origin class-filter] + ::nx::core::relation $cl class-mixin [::nx::core::relation $origin class-mixin] + :copyNSVarsAndCmds ::nx::core::classes$origin ::nx::core::classes$dest + } else { + # create obj + set obj [[$origin info class] create $dest -noinit] + } + # copy object -> may be a class obj + ::nx::core::assertion $obj check [::nx::core::assertion $origin check] + ::nx::core::assertion $obj object-invar [::nx::core::assertion $origin object-invar] + ::nx::core::relation $obj object-filter [::nx::core::relation $origin object-filter] + ::nx::core::relation $obj object-mixin [::nx::core::relation $origin object-mixin] + if {[$origin info hasnamespace]} { + $obj requireNamespace + } + } else { + namespace eval $dest {} + } + :copyNSVarsAndCmds $origin $dest + foreach i [::nx::core::cmd::ObjectInfo::forward $origin] { + eval [concat ::nx::core::forward $dest -per-object $i [::nx::core::cmd::ObjectInfo::forward $origin -definition $i]] + } + if {[::nx::core::objectproperty $origin class]} { + foreach i [::nx::core::cmd::ClassInfo::forward $origin] { + eval [concat ::nx::core::forward $dest $i [::nx::core::cmd::ClassInfo::forward $origin -definition $i]] + } + } + set traces [list] + foreach var [$origin info vars] { + set cmds [::nx::core::dispatch $origin -objscope ::trace info variable $var] + if {$cmds ne ""} { + foreach cmd $cmds { + foreach {op def} $cmd break + #$origin trace remove variable $var $op $def + if {[lindex $def 0] eq $origin} { + set def [concat $dest [lrange $def 1 end]] + } + $dest trace add variable $var $op $def + } + } + } + #puts stderr "=====" + } + # alter 'domain' and 'manager' in slot objects for classes + foreach origin [set :targetList] { + if {[::nx::core::objectproperty $origin class]} { + set dest [:getDest $origin] + foreach oldslot [$origin info slots] { + set newslot [::nx::Slot slotName [namespace tail $oldslot] $dest] + if {[$oldslot domain] eq $origin} {$newslot domain $cl} + if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot} + } + } + } + } + + :public method copy {obj dest} { + #puts stderr "[::nx::core::current object] copy <$obj> <$dest>" + set :objLength [string length $obj] + set :dest $dest + :makeTargetList $obj + :copyTargets + } +} + + +::nx::Object public method copy newName { + if {[string compare [string trimleft $newName :] [string trimleft [::nx::core::current object] :]]} { + [::nx::CopyHandler new -volatile] copy [::nx::core::current object] $newName + } +} + +::nx::Object public method move newName { + if {[string trimleft $newName :] ne [string trimleft [::nx::core::current object] :]} { + if {$newName ne ""} { + :copy $newName + } + ### let all subclasses get the copied class as superclass + if {[::nx::core::objectproperty [::nx::core::current object] class] && $newName ne ""} { + foreach subclass [:info subclass] { + set scl [$subclass info superclass] + if {[set index [lsearch -exact $scl [::nx::core::current object]]] != -1} { + set scl [lreplace $scl $index $index $newName] + $subclass superclass $scl + } + } + } + :destroy + } +} + +####################################################### +# some utilities +####################################################### + +namespace eval ::nx { + # + # Provide an ensemble-like interface to the nx::core primitiva to + # access variables. Note that aliasing in the next scripting + # framework is faster than namespace-ensembles. + # + Object create ::nx::var { + :alias exists ::nx::core::existsvar + :alias import ::nx::core::importvar + :alias set ::nx::core::setvar + } +} + + +namespace eval ::nx::core { + # + # determine platform aware temp directory + # + proc tmpdir {} { + foreach e [list TMPDIR TEMP TMP] { + if {[info exists ::env($e)] \ + && [file isdirectory $::env($e)] \ + && [file writable $::env($e)]} { + return $::env($e) + } + } + if {$::tcl_platform(platform) eq "windows"} { + foreach d [list "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"] { + if {[file isdirectory $d] && [file writable $d]} { + return $d + } + } + } + return /tmp + } + + namespace export tmpdir +} + +####################################################################### +# common code for all xotcl versions +namespace eval ::nx { + + # export the contents for all xotcl versions + namespace export Attribute current + + # if HOME is not set, and ~ is resolved, Tcl chokes on that + if {![info exists ::env(HOME)]} {set ::env(HOME) /root} + + set ::nx::confdir ~/.xotcl + set ::nx::logdir $::nx::confdir/log + + unset bootstrap +} + +# +# The following will go away +# +#namespace eval ::xotcl { +# namespace import ::nx::core::use +#} + +#foreach ns {::next ::nx::core} { +# puts stderr "$ns exports [namespace eval $ns {lsort [namespace export]}]" +#} Index: generic/predefined.xotcl =================================================================== diff -u -N --- generic/predefined.xotcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) +++ generic/predefined.xotcl (revision 0) @@ -1,1449 +0,0 @@ -namespace eval ::nx { - # - # By setting the variable bootstrap, we can check later, whether we - # are in bootstrapping mode - # - set bootstrap 1 - - #namespace path ::xotcl - - # - # First create the ::nx object system. - # - ::nx::core::createobjectsystem ::nx::Object ::nx::Class { - -class.alloc alloc - -class.create create - -class.dealloc dealloc - -class.recreate recreate - -class.requireobject __unknown - -object.configure configure - -object.defaultmethod defaultmethod - -object.destroy destroy - -object.init init - -object.move move - -object.objectparameter objectparameter - -object.residualargs residualargs - -object.unknown unknown - } - - # - # get frequenly used primitiva into the ::next namespace - # - namespace eval ::nx::core { - namespace export next self \ - my is relation interp - } - - - namespace import ::nx::core::next ::nx::core::self - - # - # provide the standard command set for ::nx::Object - # - foreach cmd [info command ::nx::core::cmd::Object::*] { - set cmdName [namespace tail $cmd] - if {$cmdName in [list "exists" "instvar"]} continue - ::nx::core::alias Object $cmdName $cmd - } - - # provide ::eval as method for ::nx::Object - ::nx::core::alias Object eval -nonleaf ::eval - - # provide the standard command set for Class - foreach cmd [info command ::nx::core::cmd::Class::*] { - set cmdName [namespace tail $cmd] - ::nx::core::alias Class $cmdName $cmd - } - - # set a few aliases as protected - foreach cmd [list __next cleanup noinit residualargs uplevel upvar] { - ::nx::core::methodproperty Object $cmd protected 1 - } - - foreach cmd [list recreate] { - ::nx::core::methodproperty Class $cmd protected 1 - } - # TODO: info methods shows finally "slots" and "slot". Wanted? - - # protect some methods against redefinition - ::nx::core::methodproperty Object destroy redefine-protected true - ::nx::core::methodproperty Class alloc redefine-protected true - ::nx::core::methodproperty Class dealloc redefine-protected true - ::nx::core::methodproperty Class create redefine-protected true - - # define method "method" for Class and Object - - # @method ::nx::Class#method - # - # Defines a per-class method, similarly to Tcl specifying - # {{{procs}}}. Optionally assertions may be specified by two - # additional arguments. Therefore, to specify only post-assertions - # an empty pre-assertion list must be given. All assertions are a - # list of ordinary Tcl {{{expr}}} statements. When {{{method}}} is - # called with an empty argument list and an empty body, the - # specified method is deleted. - # {{{ - # Class create AClass { - # :method foo args {;} - # } - # - # AClass create anInstance - # anInstance foo; # invokes "foo" - # }}} - # - # @param name The method name - # @param arguments:list A list specifying non-positional and positional parameters - # @param body The script which forms the method body - # @param preAssertion Optional assertions that must hold before the proc executes - # @param postAssertion Optional assertions that must hold after the proc executes - - ::nx::core::method Class method { - name arguments body -precondition -postcondition - } { - set conditions [list] - if {[info exists precondition]} {lappend conditions -precondition $precondition} - if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} - ::nx::core::method [::nx::core::current object] $name $arguments $body {*}$conditions - } - - # @method ::nx::Object#method - # - # Defines a per-object method, similarly to Tcl specifying - # {{{procs}}}. Optionally assertions may be specified by two - # additional arguments. Therefore, to specify only post-assertions - # an empty pre-assertion list must be given. All assertions are a - # list of ordinary Tcl {{{expr}}} statements. When {{{method}}} is - # called with an empty argument list and an empty body, the - # specified method is deleted. - # {{{ - # Object create anObject { - # :method foo args {;} - # } - # anObject foo; # invokes "foo" - # }}} - # - # @param name The method name - # @param arguments:list A list specifying non-positional and positional parameters - # @param body The script which forms the method body - # @param preAssertion Optional assertions that must hold before the proc executes - # @param postAssertion Optional assertions that must hold after the proc executes - ::nx::core::method Object method { - name arguments body -precondition -postcondition - } { - set conditions [list] - if {[info exists precondition]} {lappend conditions -precondition $precondition} - if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} - ::nx::core::method [::nx::core::current object] -per-object $name $arguments $body {*}$conditions - } - - # define method modifiers "object", "public" and "protected" - Class eval { - - # method-modifier for object specific methos - :method object {what args} { - if {$what in [list "alias" "attribute" "forward" "method" "setter"]} { - return [::nx::core::dispatch [::nx::core::current object] ::nx::core::classes::nx::Object::$what {*}$args] - } - if {$what in [list "info"]} { - return [::nx::objectInfo [lindex $args 0] [::nx::core::current object] {*}[lrange $args 1 end]] - } - if {$what in [list "filter" "mixin"]} { - return [:object-$what {*}$args] - } - if {$what in [list "filterguard" "mixinguard"]} { - return [::nx::core::dispatch [::nx::core::current object] ::nx::core::cmd::Object::$what {*}$args] - } - } - - # define unknown handler for class - :method unknown {m args} { - error "Method '$m' unknown for [::nx::core::current object].\ - Consider '[::nx::core::current object] create $m $args' instead of '[::nx::core::current object] $m $args'" - } - # protected is not jet defined - ::nx::core::methodproperty [::nx::core::current object] unknown protected 1 - } - - - Object eval { - - # method modifier "public" - :method public {args} { - set p [lsearch -regexp $args {^(method|alias|attribute|forward|setter)$}] - if {$p == -1} {error "$args is not a method defining method"} - set r [{*}:$args] - ::nx::core::methodproperty [::nx::core::current object] $r protected false - return $r - } - - # method modifier "protected" - :method protected {args} { - set p [lsearch -regexp $args {^(method|alias|attribute|forward|setter)$}] - if {$p == -1} {error "$args is not a method defining command"} - set r [{*}:$args] - ::nx::core::methodproperty [::nx::core::current object] $r [::nx::core::current method] true - return $r - } - - # unknown handler for Object - :protected method unknown {m args} { - if {![::nx::core::current isnext]} { - error "[::nx::core::current object]: unable to dispatch method '$m'" - } - } - - # "init" must exist on Object. per default it is empty. - :protected method init args {} - - # this method is called on calls to object without a specified method - :protected method defaultmethod {} {::nx::core::current object} - - # provide a placeholder for the bootup process. The real definition - # is based on slots, which are not available at this point. - :protected method objectparameter {} {;} - } - - # define forward methods - - # @method ::nx::Object#forward - # - # Register a per-object method (similar to a {{{proc}}}) for - # forward-delegating calls to a callee (target Tcl command, other - # object). When the forwarder method is called, the actual arguments - # of the invocation are appended to the specified arguments. In - # callee an arguments certain substitutions can take place: - # - # {{{%proc}}} substituted by name of the forwarder method - # - # {{{%self}}} substitute by name of the object - # - # {{{%1}}} substitute by first argument of the invocation - # - # {{{ {%@POS value} }}} substitute the specified value in the - # argument list on position POS, where POS can be a positive or - # negative integer or end. Positive integers specify the position - # from the begin of the list, while negative integer specify the - # position from the end. - # - # {{{ {%argclindex LIST} }}} take the nth argument of the specified - # list as substitution value, where n is the number of arguments - # from the invocation. - # - # {{{%%}}} a single percent. - # - # {{{%Tcl-command}}} command to be executed; substituted by result. - # Additionally each argument can be prefixed by the positional prefix - # %@POS (note the delimiting space at the end) that can be used to - # specify an explicit position. POS can be a positive or negative - # integer or the word end. The positional arguments are evaluated from - # left to right and should be used in ascending order. - # - # @param name The name of the delegating or forward method - # @param -objscope:optional Causes the target to be evaluated in the scope of the object. - # @param -methodprefix Prepends the specified prefix to the second argument of the invocation. - # @param -default Is used for default method names (only in connection with %1) - # @param -earlybinding Look up the function pointer of the called Tcl command at definition time of the forwarder instead of invocation time. This option should only be used for calling C-implemented Tcl commands, no scripted procs - # @param -verbose Print the substituted command to stderr before executing - # @param callee - # @param args - ::nx::core::forward Object forward ::nx::core::forward %self -per-object - - # @method ::nx::Class#forward - # - # Register a per-class method (similar to a {{{proc}}}) for - # forward-delegating calls to a callee (target Tcl command, other - # object). When the forwarder method is called on an instance of the - # class, the actual arguments of the invocation are appended to the - # specified arguments. In callee an arguments certain substitutions - # can take place: - # - # {{{%proc}}} substituted by name of the forwarder method - # - # {{{%self}}} substitute by name of the object - # - # {{{%1}}} substitute by first argument of the invocation - # - # {{{ {%@POS value} }}} substitute the specified value in the - # argument list on position POS, where POS can be a positive or - # negative integer or end. Positive integers specify the position - # from the begin of the list, while negative integer specify the - # position from the end. - # - # {{{ {%argclindex LIST} }}} take the nth argument of the specified - # list as substitution value, where n is the number of arguments - # from the invocation. - # - # {{{%%}}} a single percent. - # - # {{{%Tcl-command}}} command to be executed; substituted by result. - # Additionally each argument can be prefixed by the positional prefix - # %@POS (note the delimiting space at the end) that can be used to - # specify an explicit position. POS can be a positive or negative - # integer or the word end. The positional arguments are evaluated from - # left to right and should be used in ascending order. - # - # @param name The name of the delegating or forward method - # @param -objscope:optional Causes the target to be evaluated in the scope of the object. - # @param -methodprefix Prepends the specified prefix to the second argument of the invocation. - # @param -default Is used for default method names (only in connection with %1) - # @param -earlybinding Look up the function pointer of the called Tcl command at definition time of the forwarder instead of invocation time. This option should only be used for calling C-implemented Tcl commands, no scripted procs - # @param -verbose Print the substituted command to stderr before executing - # @param callee - # @param args - ::nx::core::forward Class forward ::nx::core::forward %self - - # The method __unknown is called in cases, where we try to resolve - # an unkown class. one could define a custom resolver with this name - # to load the class on the fly. After the call to __unknown, XOTcl - # tries to resolve the class again. This meachnism is used e.g. by - # the ::ttrace mechanism for partial loading by Zoran. - # - Class protected object method __unknown {name} {} - - # Add alias methods. cmdName for XOTcl method can be added via - # [... info method name ] - # - # -nonleaf and -objscope make only sense for c-defined cmds, - # -objscope implies -nonleaf - # - Object public method alias {-nonleaf:switch -objscope:switch methodName cmd} { - ::nx::core::alias [::nx::core::current object] -per-object $methodName \ - {*}[expr {${objscope} ? "-objscope" : ""}] \ - {*}[expr {${nonleaf} ? "-nonleaf" : ""}] \ - $cmd - } - Class public method alias {-nonleaf:switch -objscope:switch methodName cmd} { - ::nx::core::alias [::nx::core::current object] $methodName \ - {*}[expr {${objscope} ? "-objscope" : ""}] \ - {*}[expr {${nonleaf} ? "-nonleaf" : ""}] \ - $cmd - } - - # Add setter methods. - # - Object public method setter {methodName} { - ::nx::core::setter [::nx::core::current object] -per-object $methodName - } - Class public method setter {methodName} { - ::nx::core::setter [::nx::core::current object] $methodName - } - - ######################## - # Info definition - ######################## - Object create ::nx::objectInfo - Object create ::nx::classInfo - - # - # It would be nice to do here "objectInfo configure {alias ..}", but - # we have no working objectparameter yet due to bootstrapping - # - objectInfo eval { - :alias is ::nx::core::objectproperty - - # info info - :public method info {obj} { - set methods [list] - foreach name [::nx::core::cmd::ObjectInfo::methods [::nx::core::current object]] { - if {$name eq "unknown"} continue - lappend methods $name - } - return "valid options are: [join [lsort $methods] {, }]" - } - - :method unknown {method obj args} { - error "[::nx::core::current object] unknown info option \"$method\"; [$obj info info]" - } - } - - classInfo eval { - :alias is ::nx::core::objectproperty - :alias classparent ::nx::core::cmd::ObjectInfo::parent - :alias classchildren ::nx::core::cmd::ObjectInfo::children - :alias info [::nx::core::cmd::ObjectInfo::method objectInfo name info] - :alias unknown [::nx::core::cmd::ObjectInfo::method objectInfo name info] - } - - foreach cmd [info command ::nx::core::cmd::ObjectInfo::*] { - ::nx::core::alias ::nx::objectInfo [namespace tail $cmd] $cmd - ::nx::core::alias ::nx::classInfo [namespace tail $cmd] $cmd - } - foreach cmd [info command ::nx::core::cmd::ClassInfo::*] { - set cmdName [namespace tail $cmd] - if {$cmdName in [list "object-mixin-of" "class-mixin-of"]} continue - ::nx::core::alias ::nx::classInfo $cmdName $cmd - } - unset cmd - - # register method "info" on Object and Class - Object forward info -onerror ::nx::core::infoError ::nx::objectInfo %1 {%@2 %self} - Class forward info -onerror ::nx::core::infoError ::nx::classInfo %1 {%@2 %self} - - proc ::nx::core::infoError msg { - #puts stderr "INFO ERROR: <$msg>\n$::errorInfo" - regsub -all " " $msg "" msg - regsub -all " " $msg "" msg - regsub {\"} $msg "\"info " msg - error $msg "" - } - - # - # definition of "abstract method foo ...." - # - Object method abstract {methtype -per-object:switch methname arglist} { - if {$methtype ne "method"} { - error "invalid method type '$methtype', must be 'method'" - } - set body " - if {!\[::nx::core::current isnextcall\]} { - error \"Abstract method $methname $arglist called\" - } else {::nx::core::next} - " - if {${per-object}} { - :method -per-object $methname $arglist $body - } else { - :method $methname $arglist $body - } - } - - # - # exit handlers - # - proc ::nx::core::unsetExitHandler {} { - proc ::nx::core::__exitHandler {} { - # clients should append exit handlers to this proc body - } - } - proc ::nx::core::setExitHandler {newbody} {::proc ::nx::core::__exitHandler {} $newbody} - proc ::nx::core::getExitHandler {} {::info body ::nx::core::__exitHandler} - # initialize exit handler - ::nx::core::unsetExitHandler - - namespace export Object Class next self -} - - -######################################## -# Slot definitions -######################################## -namespace eval ::nx { - # - # We are in bootstrap code; we cannot use slots/parameter to define - # slots, so the code is a little low level. After the defintion of - # the slots, we can use slot-based code such as "-parameter" or - # "objectparameter". - # - ::nx::Class create ::nx::MetaSlot - ::nx::core::relation ::nx::MetaSlot superclass ::nx::Class - - ::nx::MetaSlot public method slotName {name baseObject} { - # Create slot parent object if needed - set slotParent ${baseObject}::slot - if {![::nx::core::objectproperty ${slotParent} object]} { - ::nx::Object create ${slotParent} - } - return ${slotParent}::$name - } - - ::nx::MetaSlot method createFromParameterSyntax { - target -per-object:switch - {-initblock ""} - value default:optional - } { - set opts [list] - set colonPos [string first : $value] - if {$colonPos == -1} { - set name $value - } else { - set properties [string range $value [expr {$colonPos+1}] end] - set name [string range $value 0 [expr {$colonPos -1}]] - foreach property [split $properties ,] { - if {$property eq "required"} { - lappend opts -required 1 - } elseif {$property eq "multivalued"} { - lappend opts -multivalued 1 - } elseif {[string match type=* $property]} { - set type [string range $property 5 end] - if {![string match ::* $type]} {set type ::$type} - } elseif {[string match arg=* $property]} { - set argument [string range $property 4 end] - lappend opts -arg $argument - } else { - set type $property - } - } - } - if {[info exists type]} { - lappend opts -type $type - } - - if {[info exists default]} { - lappend opts -default $default - } - if {${per-object}} { - lappend opts -per-object true - set info ObjectInfo - } else { - set info ClassInfo - } - - :create [:slotName $name $target] {*}$opts $initblock - return [::nx::core::cmd::${info}::method $target name $name] - } - - # @object ::nx::Slot - # - # A slot is a meta-object that manages property changes of - # objects. A property is either an attribute or a role taken by an - # object in an inter-object relation (e.g., in system slots). The - # predefined system slots are {{{class}}}, {{{superclass}}}, - # {{{mixin}}}, and {{{filter}}}. These slots appear as methods of - # {{@object ::nx::Object}} or {{@object ::nx::Class}}. The slots - # provide a common getter and setter interface. Every multivalued - # slot provides e.g. a method {{{add}}} to append a value to the - # list of values, and a method {{{delete}}} which removes it. - # - # @superclass ::nx::doc::entities::object::nx::Object - ::nx::MetaSlot create ::nx::Slot - - # @object ::nx::ObjectParameterSlot - # - # @superclass ::nx::doc::entities::object::nx::Slot - ::nx::MetaSlot create ::nx::ObjectParameterSlot - ::nx::core::relation ::nx::ObjectParameterSlot superclass ::nx::Slot - - ::nx::MetaSlot create ::nx::MethodParameterSlot - ::nx::core::relation ::nx::MethodParameterSlot superclass ::nx::Slot - - # create an object for dispatching - ::nx::MethodParameterSlot create ::nx::methodParameterSlot - - # use low level interface for defining slot values. Normally, this is - # done via slot objects, which are defined later. - - proc createBootstrapAttributeSlots {class definitions} { - foreach att $definitions { - if {[llength $att]>1} {foreach {att default} $att break} - set slotObj [::nx::ObjectParameterSlot slotName $att $class] - ::nx::ObjectParameterSlot create $slotObj - if {[info exists default]} { - ::nx::core::setvar $slotObj default $default - unset default - } - ::nx::core::setter $class $att - } - - # - # Perform a second round to set default values for already defined - # objects. - # - foreach att $definitions { - if {[llength $att]>1} {foreach {att default} $att break} - if {[info exists default]} { - - # checking subclasses is not required during bootstrap - foreach i [::nx::core::cmd::ClassInfo::instances $class] { - if {![::nx::core::existsvar $i $att]} { - if {[string match {*\[*\]*} $default]} { - set value [::nx::core::dispatch $i -objscope ::eval subst $default] - } else { - set value $default - } - ::nx::core::setvar $i $att $value - } - } - unset default - } - } - - #puts stderr "Bootstrapslot for $class calls __invalidateobjectparameter" - $class __invalidateobjectparameter - } - - ############################################ - # Define slots for slots - ############################################ - - # @param ::nx::Slot#name - # - # Name of the slot which can be used to access the slot from an object - - # @param ::nx::Slot#multivalued - # - # Boolean value for specifying single or multiple values (lists) - - # @param ::nx::Slot#required - # - # Denotes whether a value must be provided - - # @param ::nx::Slot#default - # - # Allows you to define a default value (to be set upon object creation) - - # @param ::nx::Slot#type - # - # You may specify a type constraint on the value range to managed by the slot - - createBootstrapAttributeSlots ::nx::Slot { - {name} - {multivalued false} - {required false} - default - type - } - - # @param ::nx::ObjectParameterSlot#name - # - # Name of the slot which can be used to access the slot from an - # object. It defaults to unqualified name of an instance. - - # @param ::nx::ObjectParameterSlot#methodname - # - # The name of the accessor methods to be registed on behalf of the - # slot object with its domains can vary from the slot name. - - # @param ::nx::ObjectParameterSlot#domain - # - # The domain (object or class) of a slot on which it can be used - - # @param ::nx::ObjectParameterSlot#defaultmethods - # - # A list of two elements for specifying which methods are called per - # default, when no slot method is explicitly specified in a call. - - # @param ::nx::ObjectParameterSlot#manager - # - # The manager object of the slot (per default, the slot object takes - # this role, i.e. {{{[self]}}}) - - # @param ::nx::ObjectParameterSlot#per-object - # - # If set to {{{true}}}, the accessor methods are registered with the - # domain object scope only. It defaults to {{{false}}}. - - createBootstrapAttributeSlots ::nx::ObjectParameterSlot { - {name "[namespace tail [::nx::core::current object]]"} - {methodname} - {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::nx::core::current object]] 1]"} - {defaultmethods {get assign}} - {manager "[::nx::core::current object]"} - {per-object false} - } - # maybe add the following slots at some later time here - # initcmd - # valuecmd - # valuechangedcmd - - ::nx::core::alias ::nx::ObjectParameterSlot get ::nx::core::setvar - ::nx::core::alias ::nx::ObjectParameterSlot assign ::nx::core::setvar - - ::nx::ObjectParameterSlot public method add {obj prop value {pos 0}} { - if {![set :multivalued]} { - error "Property $prop of [set :domain]->$obj ist not multivalued" - } - if {[::nx::core::existsvar $obj $prop]} { - ::nx::core::setvar $obj $prop [linsert [::nx::core::setvar $obj $prop] $pos $value] - } else { - ::nx::core::setvar $obj $prop [list $value] - } - } - ::nx::ObjectParameterSlot public method delete {-nocomplain:switch obj prop value} { - set old [::nx::core::setvar $obj $prop] - set p [lsearch -glob $old $value] - if {$p>-1} {::nx::core::setvar $obj $prop [lreplace $old $p $p]} else { - error "$value is not a $prop of $obj (valid are: $old)" - } - } - - ::nx::ObjectParameterSlot method unknown {method args} { - set methods [list] - foreach m [:info callable] { - if {[::nx::Object info callable $m] ne ""} continue - if {[string match __* $m]} continue - lappend methods $m - } - error "Method '$method' unknown for slot [::nx::core::current object]; valid are: {[lsort $methods]}" - } - - ::nx::ObjectParameterSlot public method destroy {} { - if {${:domain} ne "" && [::nx::core::objectproperty ${:domain} class]} { - ${:domain} __invalidateobjectparameter - } - ::nx::core::next - } - - ::nx::ObjectParameterSlot protected method init {args} { - if {${:domain} eq ""} { - set :domain [::nx::core::current callingobject] - } - if {${:domain} ne ""} { - if {![info exists :methodname]} { - set :methodname ${:name} - } - if {[::nx::core::objectproperty ${:domain} class]} { - ${:domain} __invalidateobjectparameter - } - if {${:per-object} && [info exists :default] } { - ::nx::core::setvar ${:domain} ${:name} ${:default} - } - set cl [expr {${:per-object} ? "Object" : "Class"}] - #puts stderr "Slot [::nx::core::current object] init, forwarder on ${:domain}" - ::nx::core::forward ${:domain} ${:name} \ - ${:manager} \ - [list %1 [${:manager} defaultmethods]] %self \ - ${:methodname} - } - } - - ################################################################# - # We have no working objectparameter yet, since it requires a - # minimal slot infrastructure to build object parameters from - # slots. The above definitions should be sufficient. We provide the - # definition here before we refine the slot definitions. - # - # Invalidate previously defined object parameter. - ::nx::MetaSlot __invalidateobjectparameter - - # Provide the a slot based mechanism for building an object - # configuration interface from slot definitions - ::nx::ObjectParameterSlot method toParameterSyntax {{name:substdefault ${:name}}} { - set objparamdefinition $name - set methodparamdefinition "" - set objopts [list] - set methodopts [list] - set type "" - if {[info exists :required] && ${:required}} { - lappend objopts required - lappend methodopts required - } - if {[info exists :type]} { - if {[string match ::* ${:type}]} { - set type [expr {[::nx::core::objectproperty ${:type} metaclass] ? "class" : "object"}] - lappend objopts type=${:type} - lappend methodopts type=${:type} - } else { - set type ${:type} - } - } - # TODO: remove multivalued check on relations by handling multivalued - # not in relation, but in the converters - if {[info exists :multivalued] && ${:multivalued}} { - if {!([info exists :type] && ${:type} eq "relation")} { - lappend objopts multivalued - } else { - #puts stderr "ignore multivalued for $name in relation" - } - } - if {[info exists :arg]} { - set prefix [expr {$type eq "object" || $type eq "class" ? "type" : "arg"}] - lappend objopts $prefix=${:arg} - lappend methodopts $prefix=${:arg} - } - if {[info exists :default]} { - set arg ${:default} - # deactivated for now: || [string first {$} $arg] > -1 - if {[string match {*\[*\]*} $arg] - && $type ne "substdefault"} { - lappend objopts substdefault - } - } elseif {[info exists :initcmd]} { - set arg ${:initcmd} - lappend objopts initcmd - } - if {[info exists :methodname]} { - if {${:methodname} ne ${:name}} { - lappend objopts arg=${:methodname} - lappend methodopts arg=${:methodname} - #puts stderr "..... setting arg for methodname: [::nx::core::current object] has arg arg=${:methodname}" - } - } - if {$type ne ""} { - set objopts [linsert $objopts 0 $type] - # Never add "substdefault" to methodopts, since these are for - # provided values, not for defaults. - if {$type ne "substdefault"} {set methodopts [linsert $methodopts 0 $type]} - } - lappend objopts slot=[::nx::core::current object] - - if {[llength $objopts] > 0} { - append objparamdefinition :[join $objopts ,] - } - if {[llength $methodopts] > 0} { - set methodparamdefinition [join $methodopts ,] - } - if {[info exists arg]} { - lappend objparamdefinition $arg - } - #puts stderr "[::nx::core::current method] ${name} returns [list oparam $objparamdefinition mparam $methodparamdefinition]" - return [list oparam $objparamdefinition mparam $methodparamdefinition] - } - - - proc ::nx::core::parametersFromSlots {obj} { - set parameterdefinitions [list] - foreach slot [::nx::objectInfo slotobjects $obj] { - # Skip some slots for xotcl; - # TODO: maybe different parameterFromSlots for xotcl? - if {[::nx::core::objectproperty ::xotcl::Object class] - && [::nx::core::objectproperty $obj type ::xotcl::Object] && - ([$slot name] eq "mixin" || [$slot name] eq "filter") - } continue - array set "" [$slot toParameterSyntax] - lappend parameterdefinitions -$(oparam) - } - return $parameterdefinitions - } - - # @method ::nx::Object#objectparameter - ::nx::Object protected method objectparameter {{lastparameter __initcmd:initcmd,optional}} { - #puts stderr "... objectparameter [::nx::core::current object]" - set parameterdefinitions [::nx::core::parametersFromSlots [::nx::core::current object]] - if {[::nx::core::objectproperty [::nx::core::current object] class]} { - lappend parameterdefinitions -parameter:method,optional - } - lappend parameterdefinitions \ - -noinit:method,optional,noarg \ - -volatile:method,optional,noarg \ - {*}$lastparameter - #puts stderr "*** parameter definition for [::nx::core::current object]: $parameterdefinitions" - return $parameterdefinitions - } - - - ############################################ - # RelationSlot - ############################################ - ::nx::MetaSlot create ::nx::RelationSlot - createBootstrapAttributeSlots ::nx::RelationSlot { - {multivalued true} - {type relation} - {elementtype ::nx::Class} - } - ::nx::core::relation ::nx::RelationSlot superclass ::nx::ObjectParameterSlot - ::nx::core::alias ::nx::RelationSlot assign ::nx::core::relation - - ::nx::RelationSlot protected method init {} { - if {${:type} ne "relation"} { - error "RelationSlot requires type == \"relation\"" - } - ::nx::core::next - } - ::nx::RelationSlot protected method delete_value {obj prop old value} { - if {[string first * $value] > -1 || [string first \[ $value] > -1} { - # value contains globbing meta characters - if {${:elementtype} ne "" && ![string match ::* $value]} { - # prefix glob pattern with ::, since all object names have leading :: - set value ::$value - } - return [lsearch -all -not -glob -inline $old $value] - } elseif {${:elementtype} ne ""} { - # value contains no globbing meta characters, but elementtype is given - if {[string first :: $value] == -1} { - # get fully qualified name - if {![::nx::core::objectproperty $value object]} { - error "$value does not appear to be an object" - } - set value [::nx::core::dispatch $value -objscope ::nx::core::current object] - } - if {![::nx::core::objectproperty ${:elementtype} class]} { - error "$value does not appear to be of type ${:elementtype}" - } - } - set p [lsearch -exact $old $value] - if {$p > -1} { - return [lreplace $old $p $p] - } else { - error "$value is not a $prop of $obj (valid are: $old)" - } - } - - ::nx::RelationSlot public method delete {-nocomplain:switch obj prop value} { - #puts stderr RelationSlot-delete-[::nx::core::current args] - $obj $prop [:delete_value $obj $prop [$obj info $prop] $value] - } - - ::nx::RelationSlot public method get {obj prop} { - ::nx::core::relation $obj $prop - } - - ::nx::RelationSlot public method add {obj prop value {pos 0}} { - if {![set :multivalued]} { - error "Property $prop of ${:domain}->$obj ist not multivalued" - } - set oldSetting [::nx::core::relation $obj $prop] - # use uplevel to avoid namespace surprises - uplevel [list ::nx::core::relation $obj $prop [linsert $oldSetting $pos $value]] - } - ::nx::RelationSlot public method delete {-nocomplain:switch obj prop value} { - uplevel [list ::nx::core::relation $obj $prop [:delete_value $obj $prop [::nx::core::relation $obj $prop] $value]] - } - - - ############################################ - # system slots - ############################################ - proc ::nx::core::register_system_slots {os} { - ${os}::Object alloc ${os}::Class::slot - ${os}::Object alloc ${os}::Object::slot - - # @param ::nx::Class#superclass - # - # Specifies superclasses for a given class. As a setter, - # {{{superclass}}} changes the list of superclasses. When used as - # a getter, the method returns the current superclasses. - # - # @return :list If called as a getter (without arguments), - # {{{superclass}}} returns the current superclasses of the object - ::nx::RelationSlot create ${os}::Class::slot::superclass - ::nx::core::alias ${os}::Class::slot::superclass assign ::nx::core::relation - - # @param ::nx::Object#class - # - # Sets or retrieves the class of an object. When {{{class}}} is - # called without arguments, it returns the current class of the - # object. - # - # @return If called as a getter (without arguments), {{{class}}} returns the current class of the object - ::nx::RelationSlot create ${os}::Object::slot::class -multivalued false - ::nx::core::alias ${os}::Object::slot::class assign ::nx::core::relation - - # @param ::nx::Object#mixin - # - # As a setter, {{{mixin}}} specifies a list of mixins to - # set. Every mixin must be an existing class. In getter mode, you - # can retrieve the list of mixins active for the given object. - # - # @return :list If called as a getter (without arguments), {{{mixin}}} returns the list of current mixin classes registered with the object - ::nx::RelationSlot create ${os}::Object::slot::mixin -methodname object-mixin - - # @param ::nx::Object#filter - # - # In its setter mode, {{{filter}}} allows you to register methods - # as per-object filters. Every filter must be an existing method - # in the scope of the object. When acting as a getter, you can - # retrieve the list of filter methods active for the given object. - # - # @return :list If called as a getter (without arguments), - # {{{filter}}} returns the list of current filters - # registered with the object - ::nx::RelationSlot create ${os}::Object::slot::filter -elementtype "" - - # @param ::nx::Class#mixin - # - # As a setter, {{{mixin}}} specifies a list of mixins to set for - # the class. Every mixin must be an existing class. In getter - # mode, you can retrieve the list of mixins active for the given - # class. - # - # @return :list If called as a getter (without arguments), {{{mixin}}} returns the list of current mixin classes registered with the class - ::nx::RelationSlot create ${os}::Class::slot::mixin -methodname class-mixin - - # @param ::nx::Class#filter - # - # In its setter mode, {{{filter}}} allows you to register methods - # as per-class filters. Every filter must be an existing method - # in the scope of the class. When acting as a getter, you can - # retrieve the list of filter methods active for the given class. - # - # @return :list If called as a getter (without arguments), - # {{{filter}}} returns the list of current filters - # registered with the class - ::nx::RelationSlot create ${os}::Class::slot::filter -elementtype "" \ - -methodname class-filter - - # Create two conveniance slots to allow configuration of - # object-slots for classes via object-mixin - ::nx::RelationSlot create ${os}::Class::slot::object-mixin - ::nx::RelationSlot create ${os}::Class::slot::object-filter -elementtype "" - } - - ::nx::core::register_system_slots ::nx - proc ::nx::core::register_system_slots {} {} - - - ############################################ - # Attribute slots - ############################################ - ::nx::MetaSlot __invalidateobjectparameter - - # @object ::nx::Attribute - # - # Attribute slots are used to manage the access, mutation, and - # querying of instance variables. There is a helper method {{@method - # ::nx::Object class attribute}} to define the attributes of classes - # (and objects). Consider the example of a class definition with - # three attribute slots: - # {{{ - # Class create Person { - # :attribute name - # :attribute {salary 0} - # :attribute {projects ""} { - # set :multivalued true - # } - # } - # }}} - # - # @param incremental Allows for using the fine-grained modification (i.e., setting) of the managed variable {e.g., through an incremental {{{add}}}) - # @param valuecmd A Tcl command to be executed whenever the managed object variable is read - # @param valuechangedcmd A Tcl command to be executed whenever the value of the managed object variable changes - # @param arg - # @superclass ::nx::doc::entities::object::nx::ObjectParameterSlot - ::nx::MetaSlot create ::nx::Attribute -superclass ::nx::ObjectParameterSlot - - createBootstrapAttributeSlots ::nx::Attribute { - {value_check once} - incremental - initcmd - valuecmd - valuechangedcmd - arg - } - - ::nx::Attribute method __default_from_cmd {obj cmd var sub op} { - #puts "GETVAR [::nx::core::current method] obj=$obj cmd=$cmd, var=$var, op=$op" - $obj trace remove variable $var $op [list [::nx::core::current object] [::nx::core::current method] $obj $cmd] - ::nx::core::setvar $obj $var [$obj eval $cmd] - } - ::nx::Attribute method __value_from_cmd {obj cmd var sub op} { - #puts "GETVAR [::nx::core::current method] obj=$obj cmd=$cmd, var=$var, op=$op" - ::nx::core::setvar $obj $var [$obj eval $cmd] - } - ::nx::Attribute method __value_changed_cmd {obj cmd var sub op} { - # puts stderr "**************************" - # puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op, ...\n$obj exists $var -> [::nx::core::setvar $obj $var]" - eval $cmd - } - ::nx::Attribute protected method init {} { - ::nx::core::next ;# do first ordinary slot initialization - # there might be already default values registered on the class - set __initcmd "" - if {[info exists :default]} { - } elseif [info exists :initcmd] { - append __initcmd ":trace add variable [list ${:name}] read \ - \[list [::nx::core::current object] __default_from_cmd \[::nx::core::current object\] [list [set :initcmd]]\]\n" - } elseif [info exists :valuecmd] { - append __initcmd ":trace add variable [list ${:name}] read \ - \[list [::nx::core::current object] __value_from_cmd \[::nx::core::current object\] [list [set :valuecmd]]\]" - } - array set "" [:toParameterSyntax ${:name}] - - #puts stderr "Attribute.init valueParam for [::nx::core::current object] is $(mparam)" - if {$(mparam) ne ""} { - if {[info exists :multivalued] && ${:multivalued}} { - #puts stderr "adding assign [list obj var value:$(mparam),multivalued] // for [::nx::core::current object] with $(mparam)" - :method assign [list obj var value:$(mparam),multivalued,slot=[::nx::core::current object]] { - ::nx::core::setvar $obj $var $value - } - #puts stderr "adding add method for [::nx::core::current object] with value:$(mparam)" - :method add [list obj prop value:$(mparam),slot=[::nx::core::current object] {pos 0}] { - ::nx::core::next - } - } else { - #puts stderr "SV adding assign [list obj var value:$(mparam)] // for [::nx::core::current object] with $(mparam)" - :method assign [list obj var value:$(mparam),slot=[::nx::core::current object]] { - ::nx::core::setvar $obj $var $value - } - - } - } - if {[info exists :valuechangedcmd]} { - append __initcmd ":trace add variable [list ${:name}] write \ - \[list [::nx::core::current object] __value_changed_cmd \[::nx::core::current object\] [list [set :valuechangedcmd]]\]" - } - if {$__initcmd ne ""} { - set :initcmd $__initcmd - } - } - - # mixin class for optimizing slots - ::nx::Class create ::nx::Attribute::Optimizer { - - :method method args {::nx::core::next; :optimize} - :method forward args {::nx::core::next; :optimize} - :protected method init args {::nx::core::next; :optimize} - - :public method optimize {} { - #puts stderr OPTIMIZER-[info exists :incremental] - if {![info exists :methodname]} {return} - set object [expr {${:per-object} ? {object} : {}}] - if {${:per-object}} { - set perObject -per-object - set infokind Object - } else { - set perObject "" - set infokind Class - } - if {[::nx::core::cmd::${infokind}Info::method ${:domain} name ${:name}] ne ""} { - #puts stderr "OPTIMIZER RESETTING ${:domain} slot ${:name}" - ::nx::core::forward ${:domain} {*}$perObject ${:name} \ - ${:manager} \ - [list %1 [${:manager} defaultmethods]] %self \ - ${:methodname} - } - #puts stderr "OPTIMIZER incremental [info exists :incremental] def '[set :defaultmethods]'" - if {[info exists :incremental] && ${:incremental}} return - if {[set :defaultmethods] ne {get assign}} return - set assignInfo [:info callable -which assign] - #puts stderr "OPTIMIZER assign=$assignInfo//[lindex $assignInfo {end 0}]//[:info precedence]" - - if {$assignInfo ne "::nx::ObjectParameterSlot alias assign ::nx::core::setvar" && - [lindex $assignInfo {end 0}] ne "::nx::core::setvar" } return - if {[:info callable -which get] ne "::nx::ObjectParameterSlot alias get ::nx::core::setvar"} return - - array set "" [:toParameterSyntax ${:name}] - if {$(mparam) ne ""} { - set setterParam [lindex $(oparam) 0] - #puts stderr "setterParam=$setterParam, op=$(oparam)" - } else { - set setterParam ${:name} - } - ::nx::core::setter ${:domain} {*}$perObject $setterParam - #puts stderr "::nx::core::setter ${:domain} {*}$perObject $setterParam" - } - } - # register the optimizer per default - ::nx::Attribute mixin add ::nx::Attribute::Optimizer - - ############################################ - # Define method "attribute" for convenience - ############################################ - ::nx::Class method attribute {spec {-slotclass ::nx::Attribute} {initblock ""}} { - $slotclass createFromParameterSyntax [::nx::core::current object] -initblock $initblock {*}$spec - } - ::nx::Object method attribute {spec {-slotclass ::nx::Attribute} {initblock ""}} { - $slotclass createFromParameterSyntax [::nx::core::current object] -per-object -initblock $initblock {*}$spec - } - ############################################ - # Define method "parameter" for backward - # compatibility and convenience - ############################################ - ::nx::Class public method parameter arglist { - - foreach arg $arglist { - ::nx::Attribute createFromParameterSyntax [::nx::core::current object] {*}$arg - } - # todo needed? - set slot [::nx::core::current object]::slot - if {![::nx::core::objectproperty $slot object]} {::nx::Object create $slot} - ::nx::core::setvar $slot __parameter $arglist - } - ::nx::core::method ::nx::classInfo parameter {class} { - set slot ${class}::slot - if {![::nx::core::objectproperty $slot object]} {::nx::Object create $slot} - if {[::nx::core::existsvar $slot __parameter]} { - return [::nx::core::setvar $slot __parameter] - } - return "" - } - - ################################################################## - # now the slots are defined; now we can defines the Objects or - # classes with parameters more easily than above. - ################################################################## - - # remove helper proc - proc createBootstrapAttributeSlots {} {} - - ################################################################## - # create user-level converter/checker based on ::nx::core primitves - ################################################################## - - ::nx::Slot method type=hasmixin {name value arg} { - if {![::nx::core::objectproperty $value hasmixin $arg]} { - error "expected object with mixin $arg but got \"$value\" for parameter $name" - } - return $value - } - - ::nx::Slot method type=baseclass {name value} { - if {![::nx::core::objectproperty $value baseclass]} { - error "expected baseclass but got \"$value\" for parameter $name" - } - return $value - } - - ::nx::Slot method type=metaclass {name value} { - if {![::nx::core::objectproperty $value metaclass]} { - error "expected metaclass but got \"$value\" for parameter $name" - } - return $value - } - -} - -################################################################## -# Create a mixin class to overload method "new" such it does not -# allocate new objects in ::nx::*, but in the specified object -# (without syntactic overhead). -################################################################## - -::nx::Class create ::nx::ScopedNew -superclass ::nx::Class { - - :attribute {withclass ::nx::Object} - :attribute container - - :protected method init {} { - :public method new {-childof args} { - ::nx::core::importvar [::nx::core::current class] {container object} withclass - if {![::nx::core::objectproperty $object object]} { - $withclass create $object - } - eval ::nx::core::next -childof $object $args - } - } -} - -################################################################## -# The method 'contains' changes the namespace in which objects with -# realtive names are created. Therefore, 'contains' provides a -# friendly notation for creating nested object structures. Optionally, -# creating new objects in the specified scope can be turned off. -################################################################## - -::nx::Object public method contains { - {-withnew:boolean true} - -object - {-class ::nx::Object} - cmds - } { - if {![info exists object]} {set object [::nx::core::current object]} - if {![::nx::core::objectproperty $object object]} {$class create $object} - $object requireNamespace - if {$withnew} { - set m [::nx::ScopedNew new -volatile \ - -container $object -withclass $class] - ::nx::Class mixin add $m end - # TODO: the following is not pretty; however, contains might build xotcl1 and next objects. - if {[::nx::core::objectproperty ::xotcl::Class class]} {::xotcl::Class instmixin add $m end} - namespace eval $object $cmds - ::nx::Class mixin delete $m - if {[::nx::core::objectproperty ::xotcl::Class class]} {::xotcl::Class instmixin delete $m} - } else { - namespace eval $object $cmds - } -} -::nx::Class forward slots %self contains \ - -object {%::nx::core::dispatch [::nx::core::current object] -objscope ::subst [::nx::core::current object]::slot} - -################################################################## -# copy/move implementation -################################################################## - -::nx::Class create ::nx::CopyHandler { - - :attribute {targetList ""} - :attribute {dest ""} - :attribute objLength - - :method makeTargetList {t} { - lappend :targetList $t - #puts stderr "COPY makeTargetList $t target= ${:targetList}" - # if it is an object without namespace, it is a leaf - if {[::nx::core::objectproperty $t object]} { - if {[$t info hasnamespace]} { - # make target list from all children - set children [$t info children] - } else { - # ok, no namespace -> no more children - return - } - } - # now append all namespaces that are in the obj, but that - # are not objects - foreach c [namespace children $t] { - if {![::nx::core::objectproperty $c object]} { - lappend children [namespace children $t] - } - } - - # a namespace or an obj with namespace may have children - # itself - foreach c $children { - :makeTargetList $c - } - } - - - :method copyNSVarsAndCmds {orig dest} { - ::nx::core::namespace_copyvars $orig $dest - ::nx::core::namespace_copycmds $orig $dest - } - - # construct destination obj name from old qualified ns name - :method getDest origin { - set tail [string range $origin [set :objLength] end] - return ::[string trimleft [set :dest]$tail :] - } - - :method copyTargets {} { - #puts stderr "COPY will copy targetList = [set :targetList]" - foreach origin [set :targetList] { - set dest [:getDest $origin] - if {[::nx::core::objectproperty $origin object]} { - # copy class information - if {[::nx::core::objectproperty $origin class]} { - set cl [[$origin info class] create $dest -noinit] - # class object - set obj $cl - $cl superclass [$origin info superclass] - ::nx::core::assertion $cl class-invar [::nx::core::assertion $origin class-invar] - ::nx::core::relation $cl class-filter [::nx::core::relation $origin class-filter] - ::nx::core::relation $cl class-mixin [::nx::core::relation $origin class-mixin] - :copyNSVarsAndCmds ::nx::core::classes$origin ::nx::core::classes$dest - } else { - # create obj - set obj [[$origin info class] create $dest -noinit] - } - # copy object -> may be a class obj - ::nx::core::assertion $obj check [::nx::core::assertion $origin check] - ::nx::core::assertion $obj object-invar [::nx::core::assertion $origin object-invar] - ::nx::core::relation $obj object-filter [::nx::core::relation $origin object-filter] - ::nx::core::relation $obj object-mixin [::nx::core::relation $origin object-mixin] - if {[$origin info hasnamespace]} { - $obj requireNamespace - } - } else { - namespace eval $dest {} - } - :copyNSVarsAndCmds $origin $dest - foreach i [::nx::core::cmd::ObjectInfo::forward $origin] { - eval [concat ::nx::core::forward $dest -per-object $i [::nx::core::cmd::ObjectInfo::forward $origin -definition $i]] - } - if {[::nx::core::objectproperty $origin class]} { - foreach i [::nx::core::cmd::ClassInfo::forward $origin] { - eval [concat ::nx::core::forward $dest $i [::nx::core::cmd::ClassInfo::forward $origin -definition $i]] - } - } - set traces [list] - foreach var [$origin info vars] { - set cmds [::nx::core::dispatch $origin -objscope ::trace info variable $var] - if {$cmds ne ""} { - foreach cmd $cmds { - foreach {op def} $cmd break - #$origin trace remove variable $var $op $def - if {[lindex $def 0] eq $origin} { - set def [concat $dest [lrange $def 1 end]] - } - $dest trace add variable $var $op $def - } - } - } - #puts stderr "=====" - } - # alter 'domain' and 'manager' in slot objects for classes - foreach origin [set :targetList] { - if {[::nx::core::objectproperty $origin class]} { - set dest [:getDest $origin] - foreach oldslot [$origin info slots] { - set newslot [::nx::Slot slotName [namespace tail $oldslot] $dest] - if {[$oldslot domain] eq $origin} {$newslot domain $cl} - if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot} - } - } - } - } - - :public method copy {obj dest} { - #puts stderr "[::nx::core::current object] copy <$obj> <$dest>" - set :objLength [string length $obj] - set :dest $dest - :makeTargetList $obj - :copyTargets - } -} - - -::nx::Object public method copy newName { - if {[string compare [string trimleft $newName :] [string trimleft [::nx::core::current object] :]]} { - [::nx::CopyHandler new -volatile] copy [::nx::core::current object] $newName - } -} - -::nx::Object public method move newName { - if {[string trimleft $newName :] ne [string trimleft [::nx::core::current object] :]} { - if {$newName ne ""} { - :copy $newName - } - ### let all subclasses get the copied class as superclass - if {[::nx::core::objectproperty [::nx::core::current object] class] && $newName ne ""} { - foreach subclass [:info subclass] { - set scl [$subclass info superclass] - if {[set index [lsearch -exact $scl [::nx::core::current object]]] != -1} { - set scl [lreplace $scl $index $index $newName] - $subclass superclass $scl - } - } - } - :destroy - } -} - -####################################################### -# some utilities -####################################################### - -namespace eval ::nx { - # - # Provide an ensemble-like interface to the nx::core primitiva to - # access variables. Note that aliasing in the next scripting - # framework is faster than namespace-ensembles. - # - Object create ::nx::var { - :alias exists ::nx::core::existsvar - :alias import ::nx::core::importvar - :alias set ::nx::core::setvar - } -} - - -namespace eval ::nx::core { - # - # determine platform aware temp directory - # - proc tmpdir {} { - foreach e [list TMPDIR TEMP TMP] { - if {[info exists ::env($e)] \ - && [file isdirectory $::env($e)] \ - && [file writable $::env($e)]} { - return $::env($e) - } - } - if {$::tcl_platform(platform) eq "windows"} { - foreach d [list "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"] { - if {[file isdirectory $d] && [file writable $d]} { - return $d - } - } - } - return /tmp - } - - namespace export tmpdir -} - -####################################################################### -# common code for all xotcl versions -namespace eval ::nx { - - # export the contents for all xotcl versions - namespace export Attribute current - - # if HOME is not set, and ~ is resolved, Tcl chokes on that - if {![info exists ::env(HOME)]} {set ::env(HOME) /root} - - set ::nx::confdir ~/.xotcl - set ::nx::logdir $::nx::confdir/log - - unset bootstrap -} - -# -# The following will go away -# -#namespace eval ::xotcl { -# namespace import ::nx::core::use -#} - -#foreach ns {::next ::nx::core} { -# puts stderr "$ns exports [namespace eval $ns {lsort [namespace export]}]" -#} Index: generic/tclAPI.h =================================================================== diff -u -N -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- generic/tclAPI.h (.../tclAPI.h) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ generic/tclAPI.h (.../tclAPI.h) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -2,13 +2,13 @@ static int convertToInfomethodsubcmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"args", "body", "definition", "name", "parameter", "type", "precondition", "postcondition", NULL}; + static CONST char *opts[] = {"args", "body", "definition", "name", "parameter", "parametersyntax", "type", "precondition", "postcondition", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "infomethodsubcmd", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); *outObjPtr = objPtr; return result; } -enum InfomethodsubcmdIdx {InfomethodsubcmdNULL, InfomethodsubcmdArgsIdx, InfomethodsubcmdBodyIdx, InfomethodsubcmdDefinitionIdx, InfomethodsubcmdNameIdx, InfomethodsubcmdParameterIdx, InfomethodsubcmdTypeIdx, InfomethodsubcmdPreconditionIdx, InfomethodsubcmdPostconditionIdx}; +enum InfomethodsubcmdIdx {InfomethodsubcmdNULL, InfomethodsubcmdArgsIdx, InfomethodsubcmdBodyIdx, InfomethodsubcmdDefinitionIdx, InfomethodsubcmdNameIdx, InfomethodsubcmdParameterIdx, InfomethodsubcmdParametersyntaxIdx, InfomethodsubcmdTypeIdx, InfomethodsubcmdPreconditionIdx, InfomethodsubcmdPostconditionIdx}; static int convertToMethodtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { Index: generic/xotcl.c =================================================================== diff -u -N -raf4326a00a0f2d0b2f1e0369af71637f48c2d56a -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- generic/xotcl.c (.../xotcl.c) (revision af4326a00a0f2d0b2f1e0369af71637f48c2d56a) +++ generic/xotcl.c (.../xotcl.c) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -5320,12 +5320,12 @@ static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr); static Tcl_Obj * -ParamDefsFormat(Tcl_Interp *interp, XOTclParamDefs *paramDefs) { +ParamDefsFormat(Tcl_Interp *interp, XOTclParam CONST *paramsPtr) { int first, colonWritten; Tcl_Obj *listObj = Tcl_NewListObj(0, NULL), *innerListObj, *nameStringObj; XOTclParam CONST *pPtr; - for (pPtr = paramDefs->paramsPtr; pPtr->name; pPtr++) { + for (pPtr = paramsPtr; pPtr->name; pPtr++) { if (pPtr -> paramObj) { innerListObj = pPtr->paramObj; } else { @@ -5380,16 +5380,40 @@ } static Tcl_Obj * -ParamDefsList(Tcl_Interp *interp, XOTclParamDefs *paramDefs) { +ParamDefsList(Tcl_Interp *interp, XOTclParam CONST *paramsPtr) { Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); XOTclParam CONST *pPtr; - for (pPtr = paramDefs->paramsPtr; pPtr->name; pPtr++) { + for (pPtr = paramsPtr; pPtr->name; pPtr++) { Tcl_ListObjAppendElement(interp, listObj, pPtr->nameObj); } return listObj; } +static Tcl_Obj* +ParamDefsSyntax(Tcl_Interp *interp, XOTclParam CONST *paramPtr) { + Tcl_Obj *argStringObj = Tcl_NewStringObj("", 0); + XOTclParam CONST *pPtr; + + for (pPtr = paramPtr; pPtr->name; pPtr++) { + if (pPtr != paramPtr) { + Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL); + } + if (pPtr->flags & XOTCL_ARG_REQUIRED) { + Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); + } else { + Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); + Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); + if (pPtr->nrArgs >0) { + Tcl_AppendLimitedToObj(argStringObj, " arg", 4, INT_MAX, NULL); + } + Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); + } + } + /* caller has to decr */ + return argStringObj; +} + static void ParsedParamFree(XOTclParsedParam *parsedParamPtr) { /*fprintf(stderr, "ParsedParamFree %p, npargs %p\n", parsedParamPtr, parsedParamPtr->paramDefs);*/ if (parsedParamPtr->paramDefs) { @@ -9369,26 +9393,11 @@ static int ArgumentError(Tcl_Interp *interp, CONST char *errorMsg, XOTclParam CONST *paramPtr, Tcl_Obj *cmdNameObj, Tcl_Obj *methodObj) { - Tcl_Obj *argStringObj = Tcl_NewStringObj("", 0); - XOTclParam CONST *pPtr; + Tcl_Obj *argStringObj = ParamDefsSyntax(interp, paramPtr); - for (pPtr = paramPtr; pPtr->name; pPtr++) { - if (pPtr != paramPtr) { - Tcl_AppendLimitedToObj(argStringObj, " ", 1, INT_MAX, NULL); - } - if (pPtr->flags & XOTCL_ARG_REQUIRED) { - Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); - } else { - Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); - Tcl_AppendLimitedToObj(argStringObj, pPtr->name, -1, INT_MAX, NULL); - if (pPtr->nrArgs >0) { - Tcl_AppendLimitedToObj(argStringObj, " arg", 4, INT_MAX, NULL); - } - Tcl_AppendLimitedToObj(argStringObj, "?", 1, INT_MAX, NULL); - } - } XOTclObjWrongArgs(interp, errorMsg, cmdNameObj, methodObj, ObjStr(argStringObj)); DECR_REF_COUNT(argStringObj); + return TCL_ERROR; } @@ -9805,6 +9814,19 @@ return XOTclErrBadVal(interp, "info body", "a tcl method name", methodName); } +static Tcl_Obj* +ListParamDefs(Tcl_Interp *interp, XOTclParam CONST *paramsPtr, int style) { + Tcl_Obj *listObj; + + switch (style) { + case 0: listObj = ParamDefsFormat(interp, paramsPtr); break; + case 1: listObj = ParamDefsList(interp, paramsPtr); break; + case 2: listObj = ParamDefsSyntax(interp, paramsPtr); break; + } + + return listObj; +} + static int ListCmdParams(Tcl_Interp *interp, Tcl_Command cmd, CONST char *methodName, int withVarnames) { Proc *procPtr = GetTclProcFromCommand(cmd); @@ -9816,8 +9838,8 @@ /* * Obtain parameter info from paramDefs */ - list = withVarnames ? ParamDefsList(interp, paramDefs) : ParamDefsFormat(interp, paramDefs); - + list = ListParamDefs(interp, paramDefs->paramsPtr, withVarnames); + } else { /* * Obtain parameter info from compiled locals @@ -9858,7 +9880,8 @@ if (((Command *)cmd)->objProc == mdPtr->proc) { XOTclParamDefs paramDefs = {mdPtr->paramDefs, mdPtr->nrParameters}; - Tcl_Obj *list = withVarnames ? ParamDefsList(interp, ¶mDefs) : ParamDefsFormat(interp, ¶mDefs); + Tcl_Obj *list = ListParamDefs(interp, paramDefs.paramsPtr, withVarnames); + Tcl_SetObjResult(interp, list); return TCL_OK; } @@ -9872,7 +9895,7 @@ paramDefs.paramsPtr = cd->paramsPtr; paramDefs.nrParams = 1; paramDefs.slotObj = NULL; - list = withVarnames ? ParamDefsList(interp, ¶mDefs) : ParamDefsFormat(interp, ¶mDefs); + list = ListParamDefs(interp, paramDefs.paramsPtr, withVarnames); Tcl_SetObjResult(interp, list); return TCL_OK; } else { @@ -9979,6 +10002,11 @@ Tcl_Command importedCmd = GetOriginalCommand(cmd); return ListCmdParams(interp, importedCmd, methodName, 0); } + case InfomethodsubcmdParametersyntaxIdx: + { + Tcl_Command importedCmd = GetOriginalCommand(cmd); + return ListCmdParams(interp, importedCmd, methodName, 2); + } case InfomethodsubcmdPreconditionIdx: { XOTclProcAssertion *procs; @@ -13659,7 +13687,7 @@ /* infoObjectMethod method XOTclObjInfoMethodMethod { {-argName "object" -type object} - {-argName "infomethodsubcmd" -type "args|definition|name|parameter|type|precondition|postcondition"} + {-argName "infomethodsubcmd" -type "args|definition|name|parameter|parametersyntax|type|precondition|postcondition"} {-argName "name"} } */ Index: library/lib/doc-assets/command.html.tmpl =================================================================== diff -u -N -rbb58b68431fe35dd6ff16e69044705e1246d0dda -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- library/lib/doc-assets/command.html.tmpl (.../command.html.tmpl) (revision bb58b68431fe35dd6ff16e69044705e1246d0dda) +++ library/lib/doc-assets/command.html.tmpl (.../command.html.tmpl) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -19,27 +19,27 @@

[$sub name]

- [:? {[$sub exists @return] && [[$sub @return] spec] ne ""} {<[[$sub @return] spec]>} ] + [:? {[$sub eval {info exists :@return}] && [[$sub @return] spec] ne ""} {<[[$sub @return] spec]>} ] ${:name} [$sub name] [$sub parameters]
[$sub text] - [:? {[$sub exists :@param]} { + [:? {[$sub eval {info exists :@param}]} {
Subcommand parameters:
[:for param [$sub @param] {
[$param name] - [:? {[$param exists spec] && [$param spec] ne ""} {<[$param spec]>}] + [:? {[$param eval {info exists :spec}] && [$param spec] ne ""} {<[$param spec]>}] [$param text]
}]
}] - [:? {[$sub exists :@return]} { + [:? {[$sub eval {info exists :@return}]} {
Returns: @@ -62,7 +62,7 @@ [:for param ${:@param} {
[$param name] - <[:? {[$param exists spec]} {[$param spec]}]> + <[:? {[$param eval {info exists :spec}]} {[$param spec]}]> [$param text]
Index: library/lib/doc-assets/object.html.tmpl =================================================================== diff -u -N -rbb58b68431fe35dd6ff16e69044705e1246d0dda -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- library/lib/doc-assets/object.html.tmpl (.../object.html.tmpl) (revision bb58b68431fe35dd6ff16e69044705e1246d0dda) +++ library/lib/doc-assets/object.html.tmpl (.../object.html.tmpl) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -5,8 +5,8 @@

- [:? {[${:name} info is class]} { Class } - { Object - }] ${:name} + [:? {[${:name} info is class]} { Class } - { Object }] + ${:name} [:?var :@superclass { - subclass of @@ -41,13 +41,13 @@

- [:? {[$attr exists default]} { + [:? {[$attr eval {info exists :default}]} {
Default Value: [$attr default]
}] - [:? {[$attr exists deprecated]} { + [:? {[$attr eval {info exists :deprecated}]} {
Deprecated: [$attr default]
@@ -99,7 +99,7 @@

[$method name]

- [:? {[$method exists @return] && [[$method @return] spec] ne ""} {<[[$method @return] spec]>} ] + [:? {[$method eval {info exists :@return}] && [[$method @return] spec] ne ""} {<[[$method @return] spec]>} ] [$method name] [$method parameters] @@ -109,16 +109,16 @@
- [:? {[$method exists @param]} { + [:? {[$method eval {info exists :@param}]} {
Method parameters:
[:for param [$method @param] {
[$param name] - [:? {[$param exists spec] && [$param spec] ne ""} {<[$param spec]>}] + [:? {[$param eval {info exists :spec}] && [$param spec] ne ""} {<[$param spec]>}] [$param text] - [:? {[$param exists default]} { + [:? {[$param eval {info exists :default}]} {
Default Value: [$param default]
@@ -128,7 +128,7 @@
}] - [:? {[$method exists :@return]} { + [:? {[$method eval {info exists :@return}]} { [:let rparam [$method @return]]
Returns: @@ -139,7 +139,7 @@ }] - [:? {[$method exists :@deprecated]} { + [:? {[$method eval {info exists :@deprecated}]} {
Deprecated [$method @deprecated]
@@ -157,7 +157,7 @@ }] [:let imethods [:inherited @method]] [:? {$imethods ne ""} { -
+
[:for superclass [dict keys $imethods] { [:let ms [dict get $imethods $superclass]]
}] + +[:?var :@method { + Undocumented: [:undocumented] +}]
@@ -195,7 +199,7 @@

[$omethod name]

- [:? {[$omethod exists @return]} {<[[$omethod @return] spec]>} ] + [:? {[$omethod eval {info exists :@return}]} {<[[$omethod @return] spec]>} ] [$omethod name] [$omethod parameters] @@ -205,21 +209,21 @@
- [:? {[$omethod exists @param]} { + [:? {[$omethod eval {info exists :@param}]} {
Method parameters:
[:for param [$omethod @param] {
[$param name] - [:? {[$param exists spec] && [$param spec] ne ""} {<[$param spec]>}] + [:? {[$param eval {info exists :spec}] && [$param spec] ne ""} {<[$param spec]>}] [$param text]
}]
}] - [:? {[$omethod exists :@return]} { + [:? {[$omethod eval {info exists :@return}]} { [:let rparam [$omethod @return]]
Returns: @@ -230,7 +234,7 @@ }] - [:? {[$omethod exists :@deprecated]} { + [:? {[$omethod eval {info exists :@deprecated}]} {
Deprecated [$method @deprecated]
Index: library/lib/doc-tools.tcl =================================================================== diff -u -N --- library/lib/doc-tools.tcl (revision 0) +++ library/lib/doc-tools.tcl (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -0,0 +1,1817 @@ +# @package nx::doc +# +# Study for documentation classes for Next Scriptint +# +# Compared to the "old" @ docmentation effort, this is a rather +# light-weight structure based on xotcl 2 (next) language +# features. The documentation classes build an (extensible) object +# structure which is used as a basis for some renderers. In general, +# the classes are defined in a way they can be used for +# +# a) building documentation outside the source code artefacts, or +# +# b) inside code artefacts (value added method definition commands +# providing extra arguments for the documentation). The +# documentation commands could reuse there names/arguments +# etc. directly from the method definition by issuing these +# commands inside the method definition methods. +# +# One could provide lint-like features to signal, whether the +# documentation is in sync with actually defined methods (when these +# are available). +# +# @require nx +# @version 0.1 + +package provide nx::doc 0.1 +package require nx + +namespace eval ::nx::doc { + namespace import -force ::nx::* + + # @command ::nx::doc::@ + # + # The helper proc "@" is a conveniant way for creating new + # documentation objects with less syntactic overhead. + # + # @param class Request an instance of a particular entity class (e.g., ...) + # @param name What is the entity name (e.g., nx::doc for a package) + # @param args A vector of arbitrary arguments, provided to the entity when being constructed + # @return The identifier of the newly created entity object + + # @subcommand ::nx::doc::@#foo + # + # This is the first subcommand foo of "@" + # {{{ + # set do 1; + # }}} + # + # @param -param1 do it + # @param param2 do it a second time + # @return Gives you a "foo" object + + # @subcommand ::nx::doc::@#bar + # + # This is the second subcommand bar of "@" + # + # @param -param1 do it + # @param param2 do it a second time + # @return Gives you a "bar" object + + proc @ {class name args} {$class new -name $name {*}$args} + + + # @command ::nx::doc::sorted + # + # This proc is used to sort instances by values of a specified + # attribute. {{{ set + # code 1; puts stderr $code; puts stderr [info script]; set l \{x\} + # }}} Und nun gehen wir in eine zweite Zeile ... und fügen einen Link ein (e.g., {{@object ::nx::doc::@object}}) + # + # ... um nach einem Zeilenbruch weiterzumachen + # {{{ + # \# Some comment + # set instances [list [Object new] [Object new]] + # ::nx::doc::sorted $instances; set l {{{x}}}; # Some comment + # {{{ }}} + # set instances [list [Object new] [Object new]] + # ::nx::doc::sorted $instances + # }}} + # Here it goes wider ... + # {{{ + # set instances [list [Object new] [Object new]] + # ::nx::doc::sorted $instances + # }}} + # + # @param instances Points to a list of entity instances to sort e.g. {{@object ::nx::doc::@object}} + # @param sortedBy Indicates the attribte name whose values the sorting will be based on + # @return A list of sorted documentation entity instances {{{instances of @object}}} + proc sorted {instances sortedBy} { + set order [list] + foreach v $instances {lappend order [list $v [$v eval [list set :$sortedBy]]]} + set result [list] + foreach pair [lsort -index 1 $order] {lappend result [lindex $pair 0]} + return $result + } + + # @method ::nx::doc::ExceptionClass#behind? + # + # This helper method can be used to decide whether a message + # caught in error propagation qualifies as a valid exception + # object. + # + # @param error_msg Stands for the intercepted string which assumingly represents an exception object identifier + # @return 0 or 1 + Class create ExceptionClass -superclass Class { + # A meta-class which defines common behaviour for exceptions + # types, used to indicate particular events when processing + # comment blocks. + + :method behind? {error_msg} { + return [expr {[::nx::core::is $error_msg object] && \ + [::nx::core::is $error_msg type [self]]}] + } + + # @method thrown_by? + # + # This helper method realises a special-purpose catch variant to + # safely evaluate scripts which are expected to produce exception + # objects + # + # @return 1 iff an exception object is caught, 0 if the script did + # not blow or it returned an error message not pointing to an + # exception object + :method thrown_by? {script} { + if {[uplevel 1 [list ::catch $script msg]]} { + return [:behind? [uplevel 1 [list set msg]]] + } + return 0 + } + + } + + ExceptionClass create Exception { + # The base class for exception objects + # + # @param message An explanatory message meant for the developer + :attribute message:required + # @param stack_trace Contains the stack trace as saved at the time of throwing the exception object + :attribute stack_trace + + # @method throw + # + # The method makes sure that an Exception object is propagated + # through the Tcl ::error mechanism, starting from the call site's + # scope + :method throw {} { + if {![info exists :stack_trace] && [info exists ::errorInfo]} { + :stack_trace $::errorInfo + } + # + # uplevel: throw at the call site + # + uplevel 1 [list ::error [self]] + } + } + + ExceptionClass create StyleViolation -superclass Exception { + # This exception indicates from within the parsing machinery that + # a comment block was malformed (according to the rules layed out + # by the statechart-like parsing specification. + } + ExceptionClass create InvalidTag -superclass Exception { + # This exception is thrown upon situations that invalid tags are + # used at various levels of entity/part nesting. This usually + # hints at typos in tag labels or the misuse of tags in certain + # contexts. + } + ExceptionClass create MissingPartofEntity -superclass Exception { + # This exception occurs when parts are defined without providing + # an owning (i.e., partof) entity. This might be caused by + # failures in resolving this context. + } + + + Class create EntityClass -superclass Class { + # A meta-class for named documenation entities. It sets some + # shared properties (e.g., generation rules for tag names based on + # entity class names, ...). Most importantly, it provides the + # basic name-generating mechanisms for documentation entities + # based on properties such as entity name, root namespace, etc. + # + # @param tag Defaults to the tag label to be used in comment tags. It may vary from the auto-generated default! + # @param root_namespace You may choose your own root-level namespace hosting the namespace hierarchy of entity objects + + :attribute {tag {[string trimleft [string tolower [namespace tail [self]]] @]}} + :attribute {root_namespace "::nx::doc::entities"} + + namespace eval ::nx::doc::entities {} + + # @method id + # + # A basic generator for the characteristic ideas, based on the + # root_namespace, the tag label, and the fully qualified name of + # the documented entity + # + # @param name The name of the documented entity + # @return An identifier string, e.g., {{{ ::nx::doc::entities::object::ns1::Foo }}} + # @see tag + # @see root_namespace + :method id {name} { + set subns [string trimleft [namespace tail [self]] @] + return [:root_namespace]::${subns}::[string trimleft $name :] + } + + :method new {-name:required args} { + # A refined frontend for object construction/resolution which + # provides for generating an explicit name, according to the + # rules specific to the entity type. + # + # @param name The of the documented entity + # @return The identifier of the newly generated or resolved entity object + :createOrConfigure [:id $name] -name $name {*}$args + } + + :method createOrConfigure {id args} { + # This method handles verifies whether an entity object based on + # the given id exists. If so, it returns the resolved name. If + # not, it provides for generating an object with the precomputed + # id for the first time! + # + # @param id The identifier string generated beforehand + # @return The identifier of the newly generated or resolved entity object + # @see {{@method id}} + namespace eval $id {} + if {[::nx::core::objectproperty $id object]} { + $id configure {*}$args + } else { + :create $id {*}$args + } + return $id + } + + # @method get_unqualified_name + # + # @param qualified_name The fully qualified name (i.e., including the root namespace) + :method get_unqualified_name {qualified_name} { + return [string trim [string map [list [:root_namespace] ""] $qualified_name] ":"] + } + } + + Class create PartClass -superclass EntityClass { + :method id {partof_object scope name} { + # ::Foo class foo + set subns [string trimleft [namespace tail [self]] @] + set partof_name [string trimleft $partof_object :] + return [join [list [:root_namespace] $subns $partof_name $scope $name] ::] + } + :method new { + -part_attribute + {-partof:substdefault {[[MissingPartofEntity new \ + -message [subst { + Parts of type '[namespace tail [self]]' + require a partof entity to be set + }]] throw]}} + -name + args + } { + + :createOrConfigure [:id [$partof name] [$part_attribute scope] $name] {*}[self args] + } + } + + # @object ::nx::doc::PartAttribute + # + # This special-purpose Attribute variant realises (1) a cumulative + # value management and (2) support for distinguishing between + # literal parts (e.g., @author, @see) and object parts (e.g., + # \@param). + # + # The cumulative value management adds the append() operation which + # translates into an add(...,end) operation. PartAttribute slots + # default to append() as their default setter operation. To draw a + # line between object and literal parts, PartAttribute slots either + # refer to a part_class (a subclass of Part) or they do not. If a + # part_class is given, the values will be transformed accordingly + # before being pushed into the internal storage. + + ::nx::MetaSlot create PartAttribute -superclass ::nx::Attribute { + + # @param part_class + # + # The attribute slot refers to a concrete subclass of Part which + # describes the parts being managed by the attribute slot. + :attribute part_class:optional,class + :attribute scope + + :method init args { + :defaultmethods [list get append] + :multivalued true + set :incremental true + # TODO: setting a default value leads to erratic behaviour; + # needs to be verified -> @author returns "" + # :default "" + if {![info exists :scope]} { + set :scope class + regexp -- {@(.*)-.*} [namespace tail [self]] _ :scope + } + next + } + + :method require_part {domain prop value} { + if {[info exists :part_class]} { + if {[::nx::core::is $value object] && \ + [::nx::core::is $value type ${:part_class}]} { + return $value + } + return [${:part_class} new \ + -name [lindex $value 0] \ + -partof $domain \ + -part_attribute [self] \ + -@doc [lrange $value 1 end]] + } + return $value + } + :method append {domain prop value} { + :add $domain $prop $value end + } + :method assign {domain prop value} { + set parts [list] + foreach v $value { + lappend parts [:require_part $domain $prop $v] + } + next $domain $prop $parts + } + :method add {domain prop value {pos 0}} { + set p [:require_part $domain $prop $value] + if {![$domain eval [list info exists :$prop]] || $p ni [$domain $prop]} { + next $domain $prop $p $pos + } + return $p + } + :method delete {domain prop value} { + next $domain $prop [:require_part $prop $value] + } + } + + + + Class create Entity { + # + # Entity is the base class for the documentation classes + # + + # @param name + # + # gives you the name (i.e., the Nx object identifier) of the documented entity + :attribute name:required + # every Entity must be created with a "@doc" value and can have + # an optional initcmd + :method objectparameter args {next {@doc:optional __initcmd:initcmd,optional}} + + :attribute @doc:multivalued {set :incremental 1} + :attribute @see -slotclass ::nx::doc::PartAttribute + + # @method _doc + # + # The method _doc can be use to obtain the value of the documentation + # from another doc entity. This should avoid redundant documentation pieces. + :method _doc {doc use what value} { + if {$@doc ne ""} {return $doc} + if {$use ne ""} { + foreach thing {@command @object} { + set docobj [$thing id $use] + if {[::nx::core::objectproperty $docobj object]} break + } + if {[::nx::core::objectproperty $docobj object]} { + if {![$docobj eval [list info exists :$what]]} {error "no attribute $what in $docobj"} + set names [list] + foreach v [$docobj $what] { + if {[$v name] eq $value} {return [$v @doc]} + lappend names [$v name] + } + error "can't use $use, no $what with name $value in $docobj (available: $names)" + } else { + error "can't use $use, no documentation object $docobj" + } + } + } + + # @method process + # + # This is an abstract hook method to be refined by the subclasses + # of Entity + # + # @param {-initial_section:optional "context"} Describes the section to parse first + # @return :integer Indicates the success of process the comment block + :method process { + {-initial_section:optional "context"} + -entity:optional + comment_block + } { + EntityClass process \ + -partof_entity [self] \ + -initial_section $initial_section \ + {*}[expr {[info exists entity]?"-entity $entity":""}] \ + $comment_block + } + + # @method text + # + # text is used to access the content of doc of an Entity, and + # performs substitution on it. The substitution is not essential, + # but looks for now convenient. + # + :method text {-as_list:switch} { + if {[info exists :@doc] && ${:@doc} ne ""} { + set doc ${:@doc} + set non_empty_elements [lsearch -all -not -exact $doc ""] + set doc [lrange $doc [lindex $non_empty_elements 0] [lindex $non_empty_elements end]] + if {$as_list} { + return $doc + } else { + return [subst [join $doc " "]] + } + } + } + + :method filename {} { + return [[:info class] tag]_[string trimleft [string map {:: __} ${:name}] "_"] + } + } + + + EntityClass create @project -superclass Entity { + :attribute url + :attribute license + :attribute creationdate + :attribute {version ""} + } + + # + # Now, define some kinds of documentation entities. The toplevel + # docEntities are named objects in the ::nx::doc::entities namespace + # to ease access to it. + # + # For now, we define here the following toplevel docEntities: + # + # - @package + # - @command + # - @object + # - ... + # + # These can contain multiple parts. + # - @method + # - @param + # - ... + # + + EntityClass create @package -superclass Entity { + :attribute @require -slotclass ::nx::doc::PartAttribute + :attribute @version -slotclass ::nx::doc::PartAttribute + } + + EntityClass create @command -superclass Entity { + :attribute @param -slotclass ::nx::doc::PartAttribute { + set :part_class @param + } + :attribute @return -slotclass ::nx::doc::PartAttribute { + :method require_part {domain prop value} { + set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}] + next $domain $prop $value + #next $domain $prop "__out__ $value" + } + set :part_class @param + } + :attribute @subcommand -slotclass ::nx::doc::PartAttribute { + set :part_class @subcommand + } + :method parameters {} { + set params [list] + if {[info exists :@param]} { + foreach p [:@param] { + set value [$p name] + if {[$p eval {info exists :default}] || [$p name] eq "args" } { + set value "?[$p name]?" + } + lappend params $value + } + } + return $params + } + } + + EntityClass create @object \ + -superclass Entity { + :attribute @superclass -slotclass ::nx::doc::PartAttribute + :attribute @author -slotclass ::nx::doc::PartAttribute + :attribute @method -slotclass ::nx::doc::PartAttribute { + set :part_class @method + :method require_part {domain prop value} { + # TODO: verify whether these scoping checks are sufficient + # and/or generalisable: For instance, is the scope + # requested (from the part_attribute) applicable to the + # partof object, which is the object behind [$domain name]? + if {[info exists :scope] && + ![::nx::core::objectproperty [$domain name] ${:scope}]} { + error "The object '[$domain name]' does not qualify as '[$part_attribute scope]'" + } + next + } + } + :attribute @object-method -slotclass ::nx::doc::PartAttribute { + set :part_class @method + } + :attribute @param -slotclass ::nx::doc::PartAttribute { + set :part_class @param + } + + :method inherited {member} { + if {[${:name} info is class]} { + set inherited [dict create] + foreach c [lreverse [${:name} info heritage]] { + set entity [[::nx::core::current class] id $c] + if {![::nx::core::is $entity object]} continue + if {[$entity eval [list info exists :${member}]]} { + dict set inherited $entity [$entity $member] + } + } + return $inherited + } + } + + :method undocumented {} { + # TODO: for object methods and class methods + if {![::nx::core::objectproperty ${:name} object]} {return ""} + foreach m [${:name} info methods] {set available_method($m) 1} + set methods ${:@method} + if {[info exists :@param]} {set methods [concat ${:@method} ${:@param}]} + foreach m $methods { + set mn [namespace tail $m] + if {[info exists available_method($mn)]} {unset available_method($mn)} + } + return [lsort [array names available_method]] + } + + :method process { + {-initial_section:optional "context"} + -entity:optional + comment_block + } { + next + + foreach methodName [${:name} info methods -methodtype scripted] { + set blocks [doc comment_blocks [${:name} info method \ + body $methodName]] + foreach {line_offset block} $blocks { + if {$line_offset > 1} break; + set id [:@method $methodName] + $id process -initial_section description $block + } + } + + foreach methodName [${:name} object info methods\ + -methodtype scripted] { + + set blocks [doc comment_blocks [${:name} object info method \ + body $methodName]] + foreach {line_offset block} $blocks { + if {$line_offset > 1} break; + set id [:@object-method $methodName] + $id process -initial_section description $block + } + } + + } + } + + + # @object ::nx::doc::Part + # + # A Part is a part of a documentation entity, defined by a + # separate object. Every Part is associated to another + # documentation entity and is identified by a name. + # + Class create Part -superclass Entity { + + #:method objectparameter args {next {doc -use}} + :attribute partof:required + :attribute use + :attribute part_attribute + } + + # @object ::nx::doc::@method + # + # "@method" is a named entity, which is part of some other + # docEntity (a class or an object). We might be able to use the + # "use" parameter for registered aliases to be able to refer to the + # documentation of the original method. + # + PartClass create @method \ + -superclass Part { + :attribute {@modifier public} -slotclass ::nx::doc::PartAttribute + :attribute @param -slotclass ::nx::doc::PartAttribute { + set :part_class @param + } + :attribute @return -slotclass ::nx::doc::PartAttribute { + + # + # TODO: @return spec fragments should be nameless, + # conceptually. They represent "out" parameters with each + # @method being allowed to have one only. For now, we fix + # this by injecting a dummy name "__out__" which should not + # be displayed. I shall fix this later and refactor it to a + # shared place between @method and @command. + # + :method require_part {domain prop value} { + set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}] + next $domain $prop $value + } + set :part_class @param + } + :method parameters {} { + set params [list] + if {[info exists :@param]} { + foreach p [:@param] { + set value [$p name] + if {[$p eval {info exists :default}] || [$p name] eq "args" } { + set value "?[$p name]?" + } + lappend params $value + } + } + if {1} { + # TODO: make me conditional + set object [${:partof} name] + if {[::nx::core::objectproperty $object object]} { + if {[$object info methods ${:name}] ne ""} { + if {[$object info method type ${:name}] eq "forward"} { + set comment "Defined as a forwarder, can't check" + set handle ::nx::core::signature($object-class-${:name}) + if {[info exists $handle]} {append comment
[set $handle]} + } else { + set actualParams [$object info method parameter ${:name}] + if {$actualParams eq $params} { + set comment "Perfect match" + } else { + set comment "actual parameter: $actualParams" + } + append comment "
Syntax: [$object info method parametersyntax ${:name}]" + } + } else { + set comment "Method '${:name}' not defined on $object" + } + } else { + set comment "cannot check object, probably not instantiated" + } + #puts stderr "XXXX [self] ${:name} is part of ${:partof} // [${:partof} name]" + return [concat $params
$comment] + } + return $params + } + :method process { + {-initial_section:optional "context"} + comment_block + } { + next \ + -initial_section $initial_section \ + -entity [self] $comment_block + } + + }; # @method + + PartClass create @subcommand -superclass {Part @command} + + # @object ::nx::doc::@param + # + # The entity type "@param" represents the documentation unit + # for several parameter types, e.g., object, method, and + # command parameters. + # + # @superclass ::nx::doc::entities::object::nx::doc::Part + # @superclass ::nx::doc::entities::object::nx::doc::Part + PartClass create @param \ + -superclass Part { + :attribute spec + :attribute default + + :object method id {partof name} { + # The method contains the parameter-specific name production rules. + # + # @param partof Refers to the entity object which contains this part + # @param name Stores the name of the documented parameter + # @modifier protected + + set partof_fragment [:get_unqualified_name ${partof}] + return [:root_namespace]::${:tag}::${partof_fragment}::${name} + } + + # @object-method new + # + # The per-object method refinement indirects entity creation + # to feed the necessary ingredients to the name generator + # + # @param -part_attribute + # @param -partof + # @param -name + # @param args + :object method new { + -part_attribute + {-partof:substdefault {[[MissingPartofEntity new \ + -message [subst { + Parts of type '[namespace tail [self]]' + require a partof entity to be set + }]] throw]}} + -name + args + } { + + lassign $name name def + set spec "" + regexp {^(.*):(.*)$} $name _ name spec + :createOrConfigure [:id $partof $name] \ + -spec $spec \ + -name $name \ + -partof $partof \ + {*}[expr {$def ne "" ? "-default $def" : ""}] \ + -part_attribute $part_attribute {*}$args + + } + } + + namespace export EntityClass @command @object @method @param \ + @param @package @ Exception StyleViolation InvalidTag \ + MissingPartofEntity ExceptionClass +} + + + +namespace eval ::nx::doc { + + Class create TemplateData { + # This mixin class realises a rudimentary templating language to + # be used in nx::doc templates. It realises language expressions + # to verify the existence of variables and simple loop constructs + :method render { + {-initscript ""} + template + {entity:substdefault "[self]"} + } { + # Here, we assume the -nonleaf mode being active for {{{[eval]}}}. + set tmplscript [list subst [[::nx::core::current class] read_tmpl $template]] + $entity eval [subst -nocommands { + $initscript + $tmplscript + }] + # $entity eval [list subst $template] + } + + + # + # some instructions for a dwarfish, embedded templating language + # + :method let {var value} { + uplevel 1 [list ::set $var [expr {[info exists value]?$value:""}]] + return + } + :method for {var list body} { + set rendered "" + ::foreach $var $list { + uplevel 1 [list ::set $var [set $var]] + append rendered [uplevel 1 [list subst $body]] + } + return $rendered + } + :method ?var {varname args} { + uplevel 1 [list :? -ops [list [::nx::core::current proc] -] \ + "\[info exists $varname\]" {*}$args] + } + :method ? { + {-ops {? -}} + expr + then + next:optional + args + } { + if {[info exists next] && $next ni $ops} { + return -code error "Invalid control operator '$next', we expect one of $ops" + } + set condition [list expr $expr] + if {[uplevel 1 $condition]} { + return [uplevel 1 [list subst $then]] + } elseif {[info exists next]} { + if {$next eq "-"} { + set args [lassign $args next_then] + if {$next_then eq ""} { + return -code error "A then script is missing for '-'" + } + if {$args ne ""} { + return -code error "Too many arguments: $args" + } + return [uplevel 1 [list subst $next_then]] + } + return [:$next {*}$args] + } + } + + :method include {template} { + uplevel 1 [list subst [[::nx::core::current class] read_tmpl $template]] + } + + # + # TODO: This should make turn into a hook, the output + # specificities should move in a refinement of TemplateData, e.g., + # DefaultHtmlTemplateData or the like. + # + :method fit {str max {placeholder "..."}} { + if {[llength [split $str ""]] < $max} { + return $str; + } + set redux [llength [split $placeholder ""]] + set margin [expr {($max-$redux)/2}] + return "[string range $str 0 [expr {$margin-1}]]$placeholder[string range $str end-[expr {$margin+1}] end]" + } + + :method list_structural_features {} { + set entry {{"access": "$access", "host": "$host", "name": "$name", "url": "$url", "type": "$type"}} + set entries [list] + if {[:info is type ::nx::doc::@package]} { + set features [list @object @command] + foreach feature $features { + set instances [sorted [$feature info instances] name] + foreach inst $instances { + set access "" + set host [:name] + set name [$inst name] + set url "[$inst filename].html" + set type [$feature tag] + lappend entries [subst $entry] + } + } + } elseif {[:info is type ::nx::doc::@object]} { + # TODO: fix support for @object-method! + set features [list @method @param] + foreach feature $features { + if {[info exists :$feature]} { + set instances [sorted [:$feature] name] + foreach inst $instances { + set access [expr {[info exists :@modifier]?[:@modifier]:""}] + set host [:name] + set name [$inst name] + set url "[:filename].html#[$feature tag]_[$inst name]" + set type [$feature tag] + lappend entries [subst $entry] + } + } + } + } + return "\[[join $entries ,\n]\]" + } + + :method code {{-inline true} script} { + return [expr {$inline?"$script":"
$script
"}] + } + + :method link {entity_type args} { + set id [$entity_type id {*}$args] + if {![::nx::core::is $id object]} return; + set pof "" + if {[$id info is type ::nx::doc::Part]} { + set pof "[[$id partof] name]#" + set filename [[$id partof] filename] + } else { + set filename [$id filename] + } + return "$pof[$id name]" + } + + :method text {} { + # Provide \n replacements for empty lines according to the + # rendering frontend (e.g., in HTML ->
) ... + if {[info exists :@doc]} { + set doc [next -as_list] + foreach idx [lsearch -all -exact $doc ""] { + lset doc $idx "

" + } + return [subst [join $doc " "]] + } + } + + + + # + # + # + + :object method find_asset_path {{-subdir library/lib/doc-assets}} { + # This helper tries to identify the file system path of the + # asset ressources. + # + # @param -subdir Denotes the name of the sub-directory to look for + foreach dir $::auto_path { + set assets [file normalize [file join $dir $subdir]] + if {[file exists $assets]} { + return $assets + } + } + } + + :object method read_tmpl {path} { + if {[file pathtype $path] ne "absolute"} { + set assetdir [:find_asset_path] + set tmpl [file join $assetdir $path] + } else { + set tmpl [file normalize $path] + } + if {![file exists $tmpl] || ![file isfile $tmpl]} { + error "The template file '$path' was not found." + } + set fh [open $tmpl r] + set content [read $fh] + catch {close $fh} + return $content + } + + } + + # + # Provide a simple HTML renderer. For now, we make our life simple + # by defining for the different supported docEntities different methods. + # + # We could think about a java-doc style renderer... + # + + Class create Renderer { + :method render {} { + :render=[namespace tail [:info class]] + } + } + + Class create HtmlRenderer -superclass Renderer { + # render command pieces in the text + :method tt {text} {return <@TT>$text} + + + :method render=@package {} { + puts "
  • [:tt ${:name}]
    \n[:text]" + set req [:@require] + if {$req ne ""} { + puts "
      " + foreach r $req {puts "
    • $r
      • "} + puts "
    " + } + puts "
    • \n" + + } + + # + # render xotcl commands + # + :method render=@command {} { + puts "
  • [:tt ${:name}]
    \n[:text]" + # set variants [sorted [:variants] name] + # if {$variants ne ""} { + # puts "
      " + # foreach v $variants {puts "
    • [$v text]"} + # puts "
    " + # } + set params [:@param] + if {$params ne ""} { + puts "
      " + foreach v $params {puts "
    • [$v tt [$v name]] [$v text]"} + puts "
    " + } + puts "
    • \n" + } + + # + # render next classes + # + :method render=@object {} { + puts "
  • [:tt ${:name}]
    \n[:text]" + if {[info exists :@method]} { + set methods [sorted [:@method] name] + if {$methods ne ""} { + puts "
    Methods of ${:name}:\n
      " + foreach m $methods {$v render} + puts "
    " + } + } + if {[info exists :@object-method]} { + set methods [sorted [:@object-method] name] + if {$methods ne ""} { + puts "
    Object methods of ${:name}:\n
      " + foreach m $methods {$v render} + puts "
    " + } + } + puts "
    • \n" + } + + # + # render next methods + # + :method render=@method {} { + puts "
  • [:tt [:signature]]
    \n[:text]" + set params [:@param] + if {$params ne ""} { + puts "
      " + foreach v $params {puts "
    • [$v tt [$v name]] [$v text]"} + puts "
    " + } + if {${:returns} ne ""} { + puts " Returns: ${:@return}" + } + puts "\n" + } + + } + +} + +# +# post processor for initcmds and method bodies +# +namespace eval ::nx { + namespace import -force ::nx::doc::* + ::nx::Object create doc { + + :method log {msg} { + puts stderr "[self]->[uplevel 1 [list ::nx::core::current proc]]: $msg" + } + + # @method process + # + # There is a major distinction: Is the entity the comment block is + # referring to given *extrinsically* (to the comment block) or + # *intrinsically* (as a starting tag). + # + # a. extrinsic: 'thing' is a valid class or object name + # b. intrinsic: 'thing' is a arbitrary string block describing + # a script. + # + :method process {{-noeval false} thing args} { + # 1) in-situ processing: a class object + if {[::nx::core::objectproperty $thing object]} { + if {[$thing eval {info exists :__initcmd}]} { + :analyze_initcmd @object $thing [$thing eval {set :__initcmd}] + } + } elseif {![catch {package present $thing} msg]} { + # For tcl packages, we assume that the package is sourceable + # in the current interpreter. + set i [interp create] + set cmd [subst -nocommands { + package req nx::doc + namespace import -force ::nx::*; + ::nx::Class create SourcingTracker { + :method create args { + set obj [next]; + #[::nx::core::current class] eval { + # if {![info exists :scripts([info script])]} { + #dict create :scripts + #dict set :scripts [info script] objects + # } + #} + #puts stderr "dict lappend :scripts([info script]) objects [self]" + [::nx::core::current class] eval [list dict set :scripts [info script] objects \$obj _] + return \$obj + } + } + ::nx::Object mixin add SourcingTracker + package forget $thing + package req $thing + ::nx::Object mixin delete SourcingTracker + puts stderr sourced_scripts=[SourcingTracker eval {dict keys \${:scripts}}] + dict for {script entities} [SourcingTracker eval {set :scripts}] { + doc process \$script \$entities + } + + }] + interp eval $i $cmd + return $i + } elseif {[file isfile $thing]} { + # 3) alien script file + if {[file readable $thing]} { + set fh [open $thing r] + if {[catch {set script [read $fh]} msg]} { + catch {close $fh} + :log "error reading the file '$thing', i.e.: '$msg'" + } + close $fh + doc analyze -noeval $noeval $script {*}$args + puts stderr SCRIPT=$thing--[file readable $thing]-ANALYZED-[string length $script]bytes + #doc process -noeval $noeval $script {*}$args + } else { + :log "file '$thing' not readable" + } + } else { + # 4) we assume a string block, e.g., to be fed into eval + set i [interp create] + set cmd [subst { + package req nx::doc + namespace import -force ::nx::doc::* + doc analyze -noeval $noeval [list $thing] + }] + interp eval $i $cmd + #interp delete $i + return $i + } + } + + :method analyze {{-noeval false} script {additions ""}} { + # NOTE: This method is to be executed in a child/ slave + # interpreter. + if {!$noeval} { + uplevel #0 [list namespace import -force ::nx::doc::*] + set pre_commands [:list_commands] + uplevel #0 [list eval $script] + set post_commands [:list_commands] + if {$additions eq ""} { + set additions [dict keys [dict remove [dict create {*}"[join $post_commands " _ "] _"] {*}$pre_commands]] + } else { + set additions [dict keys [dict get $additions objects]] + } + # puts stderr ADDITIONS=$additions + } + set blocks [:comment_blocks $script] + # :log "blocks: '$blocks'" + # 1) eval the script in a dedicated interp; provide for + # recording script-specific object additions. + # set failed_blocks [list] + foreach {line_offset block} $blocks { + # 2) process the comment blocks, however, fail gracefully here + # (most blocks, especially in initcmd and method blocks, are + # not qualified, so they are set to fail. however, record the + # failing ones for the time being + if {[catch {::nx::doc::EntityClass process $block} msg]} { + if {![InvalidTag behind? $msg] && ![StyleViolation behind? $msg] && ![MissingPartofEntity behind? $msg]} { + if {[Exception behind? $msg]} { + error [$msg info class]->[$msg message] + } + error $msg + } + } + } + # 3) process the recorded object additions, i.e., the stored + # initcmds and method bodies. + foreach addition $additions { + # TODO: for now, we skip over pure Tcl commands and procs + if {![::nx::core::is $addition object]} continue; + :process [namespace origin $addition] + } + } + + :method list_commands {{parent ""}} { + set cmds [info commands ${parent}::*] + foreach nsp [namespace children $parent] { + lappend cmds {*}[:list_commands ${nsp}] + } + return $cmds + } + + :method analyze_line {line} { + set regex {^[\s#]*#+(.*)$} + if {[regexp -- $regex $line --> comment]} { + return [list 1 [string trimright $comment]] + } else { + return [list 0 $line] + } + } + + :method comment_blocks {script} { + set lines [split $script \n] + set comment_blocks [list] + set was_comment 0 + + set spec { + 0,1 { + set line_offset $line_counter; + set comment_block [list]; + # Note, we use [split] here to avoid stumbling over + # uncommented script blocks which contain pairs of curly + # braces which appear scattered over several physical lines + # of code. This avoids "unmatched open brace" failures when + # feeding each physical line to a list command (later, in + # the parsing machinery) + lappend comment_block $text} + 1,0 {lappend comment_blocks $line_offset $comment_block} + 1,1 {lappend comment_block $text} + 0,0 {} + } + array set do $spec + set line_counter -1 + foreach line $lines { + incr line_counter + # foreach {is_comment text} [:analyze_line $line] break; + lassign [:analyze_line $line] is_comment text; + eval $do($was_comment,$is_comment) + set was_comment $is_comment + } + return $comment_blocks + } + + :method analyze_initcmd {docKind name initcmd} { + set first_block 1 + set failed_blocks [list] + foreach {line_offset block} [:comment_blocks $initcmd] { + set arguments [list] + if {$first_block} { + set id [@ $docKind $name] + # + # Note: To distinguish between intial comments blocks + # in initcmds and method bodies which refer to the + # surrounding entity (e.g., the object or the method) + # we use the line_offset recorded by the + # comment_blocks() scanner. Later, we plan to use the + # line_offset to compute line pointers for error + # messages. Also, we can use the line offsets of each + # comment block to identify faulty comment blocks. + # + # A acceptance level of <= 1 means that a script + # block must contain the first line of this + # special-purpose comment block either in the very + # first or second script line. + # + if {$line_offset <= 1} { + lappend arguments -initial_section description + lappend arguments -entity $id + } + set first_block 0 + } else { + set initial_section context + } + lappend arguments $block + # TODO: Filter for StyleViolations as >the only< valid case + # for a continuation. Report other issues immediately. What + # about InvalidTag?! + if {[catch {$id process {*}$arguments} msg]} { + lappend failed_blocks $line_offset + } + } + + }; # analyze_initcmd method + + + # activate the recoding of initcmds + ::nx::core::configure keepinitcmd true + + } +} + + +# +# toplevel interface +# ::nx::doc::make all +# ::nx::doc::make doc +# +namespace eval ::nx::doc { + + Object create make { + + :method all {{-verbose:switch} {-class ::nx::Class}} { + foreach c [$class info instances -closure] { + if {$verbose} {puts "postprocess $c"} + ::nx::doc::postprocessor process $c + } + } + + :method doc { + {-renderer ::nx::doc::HtmlRenderer} + {-outdir /tmp/} + } { + + # register the HTML renderer for all docEntities. + + Entity mixin add $renderer + + puts "

    Tcl packages

    \n
      " + foreach pkg [sorted [@package info instances] name] { + $pkg render + } + + + puts "

      Primitive Next framework commands

      \n
        " + foreach cmd [sorted [@command info instances] name] { + $cmd render + } + puts "
      \n\n" + + puts "

      Next objects

      \n
        " + foreach cmd [sorted [@object info instances] name] { + $cmd render + } + puts "
      \n\n" + + Entity mixin delete $renderer + } + + :method write {content path} { + set fh [open $path w] + puts $fh $content + catch {close $fh} + } + + :method doc { + {-renderer ::nx::doc::HtmlRenderer} + {-outdir /tmp/} + {-tmpl entity.html.tmpl} + {-project {url http://www.next-scripting.org/ name Next}} + } { + array set prj $project + set project [@project new -name $prj(name) -url $prj(url) -version $prj(version)] + Entity mixin add $renderer + # TODO: why the manual hack instead of "file extension"? + set ext [lindex [split [file tail $tmpl] .] end-1] + set entities [concat [sorted [@package info instances] name] \ + [sorted [@command info instances] name] \ + [sorted [@object info instances] name]] + set init [subst -nocommands { + set project $project + }] + + if {![catch {file mkdir [file join $outdir [$project name]]} msg]} { + puts stderr [list file copy -force -- [$renderer find_asset_path] [file join $outdir [$project name]]/assets] + file copy -force -- [$renderer find_asset_path] [file join $outdir [$project name]]/assets + set index [$project render -initscript $init $tmpl] + puts stderr "we have [llength $entities] documentation entities ($entities)" + :write $index [file join $outdir [$project name] "index.$ext"] + foreach e $entities { + set content [$e render -initscript $init $tmpl] + :write $content [file join $outdir [$project name] "[$e filename].$ext"] + puts stderr "$e written to [file join $outdir [$project name] [$e filename].$ext]" + } + } + + Entity mixin delete $renderer + } + } + + + # + # modal comment block parsing + # + + # + # contexts are entities + # + EntityClass eval { + :object forward has_next expr {${:idx} < [llength ${:comment_block}]} + :object method dequeue {} { + set r [lindex ${:comment_block} ${:idx}] + incr :idx + return $r + } + :object forward rewind incr :idx -1 + :object forward fastforward set :idx {% expr {[llength ${:comment_block}] - 1} } + :object method process { + {-partof_entity:optional ""} + {-initial_section:optional context} + -entity:optional + block + } { + set :comment_block $block + + # initialise the context object + #puts stderr "--- [self callingproc] -> :partof_entity $partof_entity :processed_section $initial_section block $block" + set :processed_section $initial_section + set :partof_entity $partof_entity + + if {[info exists :current_entity]} { + unset :current_entity + } + + if {[info exists entity]} { + set :current_entity $entity + } + + set :is_not_completed 1 + + ${:processed_section} eval [list set :context [self]] + set is_first_iteration 1 + set :idx 0 + set failure "" + while {${:is_not_completed}} { + set line [:dequeue] + if {$is_first_iteration} { + ${:processed_section} on_enter $line + set is_first_iteration 0 + } + + if {[catch {${:processed_section} transition $line} failure]} { + set :is_not_completed 0 + # + # TODO: For now, the fast-forward mechanism jumps to the end + # of the comment block; this avoids redundant on_exit + # calls. is there a better way of achieving this? + # + :fastforward + } else { + set :is_not_completed [:has_next] + } + } + if {!$is_first_iteration} { + ${:processed_section} on_exit $line + } + + if {$failure ne ""} { + #puts stderr ERRORINFO=$::errorInfo + error $failure + } + + return ${:current_entity} + } + + :object method resolve_partof_entity {tag name} { + # a) unqualified: attr1 + # b) qualified: Bar#attr1 + if {[regexp -- {([^\s#]*)#([^\s#]*)} $name _ qualifier nq_name]} { + # TODO: Currently, I only foresee @object and @command as + # possible qualifiers; however, this should be fixed asap, as + # soon as the variety of entities has been decided upon! + foreach entity_type {@object @command} { + set partof_entity [$entity_type id $qualifier] + # TODO: Also, we expect the qualifier to resolve against an + # already existing entity object? Is this intended? + if {[::nx::core::is $partof_entity object]} { + return [list $nq_name $partof_entity] + } + } + return [list $nq_name ${:partof_entity}] + } else { + return [list $name ${:partof_entity}] + } + } + :object method dispatch {tag args} { + + if {![info exists :current_entity]} { + # 1) the current (or context) entity has NOT been resolved + # + # for named entities, the provided identifier can be either + # qualified or unqualified: + # + # a) unqualified: @param attr1 + # b) qualified: @param Bar#attr1 + # + # For qualified ones, we must resolve the qualifier to serve + # as the partof_entity; see resolve_partof_entity() + + set name [lindex $args 0] + set args [lrange $args 1 end] + lassign [:resolve_partof_entity $tag $name] nq_name partof_entity; + + if {$partof_entity ne ""} { + if {[$partof_entity info callable -application $tag] eq ""} { + [InvalidTag new -message [subst { + The tag '$tag' is not supported for the entity type + '[namespace tail [$partof_entity info class]]' + }]] throw + } + # puts stderr "1. $partof_entity $tag $nq_name {*}$args" + set :current_entity [$partof_entity $tag $nq_name {*}$args] + + } else { + # + # TODO: @object-method raises some issues (at least when + # processed without a resolved context = its partof entity). + # It is not an entity type, because it merely is a "scoped" + # @method. It won't resolve then as a proper instance of + # EntityClass, hence we observe an InvalidTag exception. For + # now, we just ignore and bypass this issue by allowing + # InvalidTag exceptions in analyze() + # + set qualified_tag [namespace qualifiers [self]]::$tag + if {[EntityClass info instances -closure $qualified_tag] eq ""} { + [InvalidTag new -message [subst { + The entity type '$tag' is not available + }]] throw + } + set :current_entity [$tag new -name $nq_name {*}$args] + } + } else { + # 2) current (or context) entity has been resolved + # TODO: Should we explicitly disallow qualified names in parts? + if {[${:current_entity} info callable -application $tag] eq ""} { + [InvalidTag new -message [subst { + The tag '$tag' is not supported for the entity type + '[namespace tail [${:current_entity} info class]]' + }]] throw + } + # puts stderr "${:current_entity} $tag {*}$args" + ${:current_entity} $tag {*}$args + } + } + } + + + + # + # Infrastructure for state objects: + # + # 1. CommentState: a base class for sharing behaviour between atomic + # and non-orthogonal super-states; it is widely an intermediate, + # abstracted class, providing a refinement protocol for concrete + # state subclasses + # + + Class create CommentState { + :attribute context; # points to the context object, i.e., an entity + :method on_enter {line} {;} + + :method signal {event line} {;} + + # + # activity/event interface + # + + :method event=process {line} {;} + :method event=close {line} {;} + :method event=next {line} {;} + :method event=exit {msg} { + error $msg + } + :method event=rewind {line} {;} + } + + # 2. CommentLines represent atomic states in the parsing state + # machinery: tag, text, space + + Class create CommentLine -superclass CommentState { + :attribute comment_section; # points to the super-state objects + :attribute processed_line; # stores the processed text line + :forward signal {% ${:comment_section} } %proc + :forward context {% ${:comment_section} } %proc + :forward current_entity {% :context } eval set :current_entity + + :method on_enter {line} {;} + :method on_exit {line} {;} + + :method match {line} {;} + :method is? {line} { + foreach cline [lsort [[:info class] info instances]] { + if {[$cline match $line]} { + return [namespace tail $cline] + } + } + } + + set :markup_map(sub) { + "{{{" "\[:code \{" + "}}}" "\}\]" + "{{" "\[:link " + "}}" "\]" + + } + set :markup_map(unescape) { + "\\{" "{" + "\\}" "}" + "\\#" "#" + } + + :method map {line set} { + set line [string map [[::nx::core::current class] eval [list set :markup_map($set)]] $line] + } + + } + + + CommentLine create tag { + :method match {line} { + return [regexp -- {^\s*@[^[:space:]@]+} $line] + } + :method event=process {line} { + set line [:map $line sub] + set line [:map $line unescape] + set line [split [string trimleft $line]] + set tag [lindex $line 0] + #puts stderr "---line->$line" + [:context] dispatch $tag [lrange $line 1 end] + } + + } + + CommentLine create text { + set :is_code_block 0 + array set :parse { + 0,1 { + # BEGIN of a code block. Insert the code start marker, a newline and the current line. + set l "\[:code \{\n" + append l $line \n + set line $l + set :is_code_block 1 + } + 1,0 { + # END of a code block. Insert the code stop marker. + set l "\}\]\n" + append l $line + set line $l + set :is_code_block 0 + } + 1,1 { + # WITHIN a code block. Add the line + a newline + append line \n + } + 0,0 { + # NOP + set line [string trimleft $line] + } + } + + :method match {line} { + return [regexp -- {^\s*([^[:space:]@]+|@[[:space:]@]+)} $line] + } + + :method event=process {line} { + set is_intended [expr {[string first "\t" $line] != -1}] + eval [set :parse(${:is_code_block},$is_intended)] + [:context] dispatch @doc add $line end + } + + :method event=process {line} { + if {[regsub -- {^\s*(\{\{\{)\s*$} $line "\[:code -inline false \{" line] || \ + (${:is_code_block} && [regsub -- {^\s*(\}\}\})\s*$} $line "\}\]" line])} { + set :is_code_block [expr {!${:is_code_block}}] + append line \n + } elseif {${:is_code_block}} { + set line [:map $line unescape] + append line \n + } else { + set line [:map $line sub] + set line [:map $line unescape] + set line [string trimleft $line] + } + [:context] dispatch @doc add $line end + } + + :method toggle_code_block {is_indented} { + set :is_code_block [expr {}] + } + + } + + CommentLine create space { + :method match {line} { + return [expr {$line eq {}}] + } + :method event=process {line} { + if {[:comment_section] eq "::nx::doc::description"} { + [:context] dispatch @doc add "" end + } + next + } + } + + + # + # 3. CommentSections represent orthogonal super-states over + # CommentLines: context, description, part + # + + Class create CommentSection -superclass CommentState { + :attribute entry_comment_line:required + :attribute current_comment_line + :attribute comment_line_transitions + :attribute next_comment_section; # implements a STATE-OWNED TRANSITION scheme + + :method init {} { + ${:entry_comment_line} comment_section [self] + } + + :method transition {line} { + array set transitions ${:comment_line_transitions} + + if {![info exists :current_comment_line]} { + set src "" + set tgt [${:entry_comment_line} is? $line] + } else { + set src ${:current_comment_line} + set tgt [$src is? $line] + } + #puts stderr "---- line $line src $src tgt $tgt" + # + # TODO: realise the initial state nodes as NULL OBJECTs, this + # helps avoid conditional branching all over the place! + # + if {$src ne ""} { + $src on_exit $line; + } + if {![info exists transitions(${src}->${tgt})]} { + set msg "Style violation in a [namespace tail [self]] section:\n" + if {$src eq ""} { + append msg "Invalid first line ('${tgt}')" + } else { + append msg "A ${src} line is followed by a ${tgt} line" + } + [StyleViolation new -message $msg] throw + } + + set :current_comment_line $tgt + $tgt comment_section [self] + ${:current_comment_line} processed_line $line + ${:current_comment_line} on_enter $line + + #foreach {event activities} $transitions(${src}->${tgt}) break; + lassign $transitions(${src}->${tgt}) event activities; + :signal $event $line + foreach activity $activities { + :signal $activity $line + } + } + + :method on_enter {line} {;} + + :method on_exit {line} { + # TODO: move this behaviour into a more decent place + if {![${:context} has_next]} { + ${:current_comment_line} on_exit $line + } + # Note: Act passive here, because e.g. upon invalid entry + # state transition requests, there is no current_comment_line + # set here. Yet, we want to exit from the comment section! + if {[info exists :current_comment_line]} { + unset :current_comment_line + } + next + } + + :method signal {event line} { + ${:current_comment_line} event=$event $line + :event=$event $line + } + + # + # handled events + # + :method event=next {line} { + set next_section [:next_comment_section] + ${:current_comment_line} on_exit $line + :on_exit $line + $next_section eval [list set :context ${:context}] + $next_section on_enter $line + ${:context} eval [list set :processed_section [:next_comment_section]] + + } + + :method event=rewind {line} { + ${:context} rewind + next + } + + }; # CommentSection + + + # + # the OWNER-DRIVEN TRANSITIONS read as follows: + # (current_state)->(next_state) {event {activity1 activty2 ...}} + # + + # + # TODO: refactor {close {rewind next}} into a single activity + # + + # + # context + # + CommentSection create context \ + -next_comment_section description \ + -comment_line_transitions { + ->tag {process ""} + tag->space {process ""} + space->space {process ""} + space->text {close {rewind next}} + space->tag {close {rewind next}} + } -entry_comment_line tag + + # NOTE: add these transitions for supporting multiple text lines for + # the context element + # tag->text {process ""} + # text->text {process ""} + # text->space {process ""} + + # + # description + # + CommentSection create description \ + -next_comment_section part \ + -comment_line_transitions { + ->text {process ""} + ->tag {close {rewind next}} + text->text {process ""} + text->space {process ""} + space->text {process ""} + space->space {process ""} + space->tag {close {rewind next}} + } -entry_comment_line text { + :method on_enter {line} { + # + # TODO: fix the re-set of the @doc attribute + # + if {[${:context} eval {info exists :current_entity}]} { + ${:context} eval { + ${:current_entity} eval { + unset -nocomplain :@doc + } + } + } + next; + } + } + + # + # part + # + CommentSection create part \ + -next_comment_section part \ + -comment_line_transitions { + ->tag {process ""} + tag->text {process ""} + text->text {process ""} + text->tag {close {rewind next}} + text->space {process ""} + space->space {process ""} + tag->space {process ""} + space->tag {close {rewind next}} + tag->tag {close {rewind next}} + } -entry_comment_line tag +} + +puts stderr "Doc Tools loaded: [info command ::nx::doc::*]" \ No newline at end of file Index: library/lib/doc-tools.xotcl =================================================================== diff -u -N --- library/lib/doc-tools.xotcl (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ library/lib/doc-tools.xotcl (revision 0) @@ -1,1772 +0,0 @@ -# @package nx::doc -# -# Study for documentation classes for Next Scriptint -# -# Compared to the "old" @ docmentation effort, this is a rather -# light-weight structure based on xotcl 2 (next) language -# features. The documentation classes build an (extensible) object -# structure which is used as a basis for some renderers. In general, -# the classes are defined in a way they can be used for -# -# a) building documentation outside the source code artefacts, or -# -# b) inside code artefacts (value added method definition commands -# providing extra arguments for the documentation). The -# documentation commands could reuse there names/arguments -# etc. directly from the method definition by issuing these -# commands inside the method definition methods. -# -# One could provide lint-like features to signal, whether the -# documentation is in sync with actually defined methods (when these -# are available). -# -# @require nx -# @version 0.1 - -package provide nx::doc 0.1 -package require nx - -namespace eval ::nx::doc { - namespace import -force ::nx::* - - # @command ::nx::doc::@ - # - # The helper proc "@" is a conveniant way for creating new - # documentation objects with less syntactic overhead. - # - # @param class Request an instance of a particular entity class (e.g., ...) - # @param name What is the entity name (e.g., nx::doc for a package) - # @param args A vector of arbitrary arguments, provided to the entity when being constructed - # @return The identifier of the newly created entity object - - # @subcommand ::nx::doc::@#foo - # - # This is the first subcommand foo of "@" - # {{{ - # set do 1; - # }}} - # - # @param -param1 do it - # @param param2 do it a second time - # @return Gives you a "foo" object - - # @subcommand ::nx::doc::@#bar - # - # This is the second subcommand bar of "@" - # - # @param -param1 do it - # @param param2 do it a second time - # @return Gives you a "bar" object - - proc @ {class name args} {$class new -name $name {*}$args} - - - # @command ::nx::doc::sorted - # - # This proc is used to sort instances by values of a specified - # attribute. {{{ set - # code 1; puts stderr $code; puts stderr [info script]; set l \{x\} - # }}} Und nun gehen wir in eine zweite Zeile ... und fügen einen Link ein (e.g., {{@object ::nx::doc::@object}}) - # - # ... um nach einem Zeilenbruch weiterzumachen - # {{{ - # \# Some comment - # set instances [list [Object new] [Object new]] - # ::nx::doc::sorted $instances; set l {{{x}}}; # Some comment - # {{{ }}} - # set instances [list [Object new] [Object new]] - # ::nx::doc::sorted $instances - # }}} - # Here it goes wider ... - # {{{ - # set instances [list [Object new] [Object new]] - # ::nx::doc::sorted $instances - # }}} - # - # @param instances Points to a list of entity instances to sort e.g. {{@object ::nx::doc::@object}} - # @param sortedBy Indicates the attribte name whose values the sorting will be based on - # @return A list of sorted documentation entity instances {{{instances of @object}}} - proc sorted {instances sortedBy} { - set order [list] - foreach v $instances {lappend order [list $v [$v eval [list set :$sortedBy]]]} - set result [list] - foreach pair [lsort -index 1 $order] {lappend result [lindex $pair 0]} - return $result - } - - # @method ::nx::doc::ExceptionClass#behind? - # - # This helper method can be used to decide whether a message - # caught in error propagation qualifies as a valid exception - # object. - # - # @param error_msg Stands for the intercepted string which assumingly represents an exception object identifier - # @return 0 or 1 - Class create ExceptionClass -superclass Class { - # A meta-class which defines common behaviour for exceptions - # types, used to indicate particular events when processing - # comment blocks. - - :method behind? {error_msg} { - return [expr {[::nx::core::is $error_msg object] && \ - [::nx::core::is $error_msg type [self]]}] - } - - # @method thrown_by? - # - # This helper method realises a special-purpose catch variant to - # safely evaluate scripts which are expected to produce exception - # objects - # - # @return 1 iff an exception object is caught, 0 if the script did - # not blow or it returned an error message not pointing to an - # exception object - :method thrown_by? {script} { - if {[uplevel 1 [list ::catch $script msg]]} { - return [:behind? [uplevel 1 [list set msg]]] - } - return 0 - } - - } - - ExceptionClass create Exception { - # The base class for exception objects - # - # @param message An explanatory message meant for the developer - :attribute message:required - # @param stack_trace Contains the stack trace as saved at the time of throwing the exception object - :attribute stack_trace - - # @method throw - # - # The method makes sure that an Exception object is propagated - # through the Tcl ::error mechanism, starting from the call site's - # scope - :method throw {} { - if {![info exists :stack_trace] && [info exists ::errorInfo]} { - :stack_trace $::errorInfo - } - # - # uplevel: throw at the call site - # - uplevel 1 [list ::error [self]] - } - } - - ExceptionClass create StyleViolation -superclass Exception { - # This exception indicates from within the parsing machinery that - # a comment block was malformed (according to the rules layed out - # by the statechart-like parsing specification. - } - ExceptionClass create InvalidTag -superclass Exception { - # This exception is thrown upon situations that invalid tags are - # used at various levels of entity/part nesting. This usually - # hints at typos in tag labels or the misuse of tags in certain - # contexts. - } - ExceptionClass create MissingPartofEntity -superclass Exception { - # This exception occurs when parts are defined without providing - # an owning (i.e., partof) entity. This might be caused by - # failures in resolving this context. - } - - - Class create EntityClass -superclass Class { - # A meta-class for named documenation entities. It sets some - # shared properties (e.g., generation rules for tag names based on - # entity class names, ...). Most importantly, it provides the - # basic name-generating mechanisms for documentation entities - # based on properties such as entity name, root namespace, etc. - # - # @param tag Defaults to the tag label to be used in comment tags. It may vary from the auto-generated default! - # @param root_namespace You may choose your own root-level namespace hosting the namespace hierarchy of entity objects - - :attribute {tag {[string trimleft [string tolower [namespace tail [self]]] @]}} - :attribute {root_namespace "::nx::doc::entities"} - - namespace eval ::nx::doc::entities {} - - # @method id - # - # A basic generator for the characteristic ideas, based on the - # root_namespace, the tag label, and the fully qualified name of - # the documented entity - # - # @param name The name of the documented entity - # @return An identifier string, e.g., {{{ ::nx::doc::entities::object::ns1::Foo }}} - # @see tag - # @see root_namespace - :method id {name} { - set subns [string trimleft [namespace tail [self]] @] - return [:root_namespace]::${subns}::[string trimleft $name :] - } - - :method new {-name:required args} { - # A refined frontend for object construction/resolution which - # provides for generating an explicit name, according to the - # rules specific to the entity type. - # - # @param name The of the documented entity - # @return The identifier of the newly generated or resolved entity object - :createOrConfigure [:id $name] -name $name {*}$args - } - - :method createOrConfigure {id args} { - # This method handles verifies whether an entity object based on - # the given id exists. If so, it returns the resolved name. If - # not, it provides for generating an object with the precomputed - # id for the first time! - # - # @param id The identifier string generated beforehand - # @return The identifier of the newly generated or resolved entity object - # @see {{@method id}} - namespace eval $id {} - if {[::nx::core::objectproperty $id object]} { - $id configure {*}$args - } else { - :create $id {*}$args - } - return $id - } - - # @method get_unqualified_name - # - # @param qualified_name The fully qualified name (i.e., including the root namespace) - :method get_unqualified_name {qualified_name} { - return [string trim [string map [list [:root_namespace] ""] $qualified_name] ":"] - } - } - - Class create PartClass -superclass EntityClass { - :method id {partof_object scope name} { - # ::Foo class foo - set subns [string trimleft [namespace tail [self]] @] - set partof_name [string trimleft $partof_object :] - return [join [list [:root_namespace] $subns $partof_name $scope $name] ::] - } - :method new { - -part_attribute - {-partof:substdefault {[[MissingPartofEntity new \ - -message [subst { - Parts of type '[namespace tail [self]]' - require a partof entity to be set - }]] throw]}} - -name - args - } { - - :createOrConfigure [:id [$partof name] [$part_attribute scope] $name] {*}[self args] - } - } - - # @object ::nx::doc::PartAttribute - # - # This special-purpose Attribute variant realises (1) a cumulative - # value management and (2) support for distinguishing between - # literal parts (e.g., @author, @see) and object parts (e.g., - # \@param). - # - # The cumulative value management adds the append() operation which - # translates into an add(...,end) operation. PartAttribute slots - # default to append() as their default setter operation. To draw a - # line between object and literal parts, PartAttribute slots either - # refer to a part_class (a subclass of Part) or they do not. If a - # part_class is given, the values will be transformed accordingly - # before being pushed into the internal storage. - - ::nx::MetaSlot create PartAttribute -superclass ::nx::Attribute { - - # @param part_class - # - # The attribute slot refers to a concrete subclass of Part which - # describes the parts being managed by the attribute slot. - :attribute part_class:optional,class - :attribute scope - - :method init args { - :defaultmethods [list get append] - :multivalued true - set :incremental true - # TODO: setting a default value leads to erratic behaviour; - # needs to be verified -> @author returns "" - # :default "" - if {![info exists :scope]} { - set :scope class - regexp -- {@(.*)-.*} [namespace tail [self]] _ :scope - } - next - } - - :method require_part {domain prop value} { - if {[info exists :part_class]} { - if {[::nx::core::is $value object] && \ - [::nx::core::is $value type ${:part_class}]} { - return $value - } - return [${:part_class} new \ - -name [lindex $value 0] \ - -partof $domain \ - -part_attribute [self] \ - -@doc [lrange $value 1 end]] - } - return $value - } - :method append {domain prop value} { - :add $domain $prop $value end - } - :method assign {domain prop value} { - set parts [list] - foreach v $value { - lappend parts [:require_part $domain $prop $v] - } - next $domain $prop $parts - } - :method add {domain prop value {pos 0}} { - set p [:require_part $domain $prop $value] - if {![$domain exists $prop] || $p ni [$domain $prop]} { - next $domain $prop $p $pos - } - return $p - } - :method delete {domain prop value} { - next $domain $prop [:require_part $prop $value] - } - } - - - - Class create Entity { - # - # Entity is the base class for the documentation classes - # - - # @param name - # - # gives you the name (i.e., the Nx object identifier) of the documented entity - :attribute name:required - # every Entity must be created with a "@doc" value and can have - # an optional initcmd - :method objectparameter args {next {@doc:optional __initcmd:initcmd,optional}} - - :attribute @doc:multivalued {set :incremental 1} - :attribute @see -slotclass ::nx::doc::PartAttribute - - # @method _doc - # - # The method _doc can be use to obtain the value of the documentation - # from another doc entity. This should avoid redundant documentation pieces. - :method _doc {doc use what value} { - if {$@doc ne ""} {return $doc} - if {$use ne ""} { - foreach thing {@command @object} { - set docobj [$thing id $use] - if {[::nx::core::objectproperty $docobj object]} break - } - if {[::nx::core::objectproperty $docobj object]} { - if {![$docobj exists $what]} {error "no attribute $what in $docobj"} - set names [list] - foreach v [$docobj $what] { - if {[$v name] eq $value} {return [$v @doc]} - lappend names [$v name] - } - error "can't use $use, no $what with name $value in $docobj (available: $names)" - } else { - error "can't use $use, no documentation object $docobj" - } - } - } - - # @method process - # - # This is an abstract hook method to be refined by the subclasses - # of Entity - # - # @param {-initial_section:optional "context"} Describes the section to parse first - # @return :integer Indicates the success of process the comment block - :method process { - {-initial_section:optional "context"} - -entity:optional - comment_block - } { - EntityClass process \ - -partof_entity [self] \ - -initial_section $initial_section \ - {*}[expr {[info exists entity]?"-entity $entity":""}] \ - $comment_block - } - - # @method text - # - # text is used to access the content of doc of an Entity, and - # performs substitution on it. The substitution is not essential, - # but looks for now convenient. - # - :method text {-as_list:switch} { - if {[info exists :@doc] && ${:@doc} ne ""} { - set doc ${:@doc} - set non_empty_elements [lsearch -all -not -exact $doc ""] - set doc [lrange $doc [lindex $non_empty_elements 0] [lindex $non_empty_elements end]] - if {$as_list} { - return $doc - } else { - return [subst [join $doc " "]] - } - } - } - - :method filename {} { - return [[:info class] tag]_[string trimleft [string map {:: __} ${:name}] "_"] - } - } - - - EntityClass create @project -superclass Entity { - :attribute url - :attribute license - :attribute creationdate - :attribute {version ""} - } - - # - # Now, define some kinds of documentation entities. The toplevel - # docEntities are named objects in the ::nx::doc::entities namespace - # to ease access to it. - # - # For now, we define here the following toplevel docEntities: - # - # - @package - # - @command - # - @object - # - ... - # - # These can contain multiple parts. - # - @method - # - @param - # - ... - # - - EntityClass create @package -superclass Entity { - :attribute @require -slotclass ::nx::doc::PartAttribute - :attribute @version -slotclass ::nx::doc::PartAttribute - } - - EntityClass create @command -superclass Entity { - :attribute @param -slotclass ::nx::doc::PartAttribute { - set :part_class @param - } - :attribute @return -slotclass ::nx::doc::PartAttribute { - :method require_part {domain prop value} { - set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}] - next $domain $prop $value - #next $domain $prop "__out__ $value" - } - set :part_class @param - } - :attribute @subcommand -slotclass ::nx::doc::PartAttribute { - set :part_class @subcommand - } - :method parameters {} { - set params [list] - if {[info exists :@param]} { - foreach p [:@param] { - set value [$p name] - if {[$p exists default] || [$p name] eq "args" } { - set value "?[$p name]?" - } - lappend params $value - } - } - return $params - } - } - - EntityClass create @object \ - -superclass Entity { - :attribute @superclass -slotclass ::nx::doc::PartAttribute - :attribute @author -slotclass ::nx::doc::PartAttribute - :attribute @method -slotclass ::nx::doc::PartAttribute { - set :part_class @method - :method require_part {domain prop value} { - # TODO: verify whether these scoping checks are sufficient - # and/or generalisable: For instance, is the scope - # requested (from the part_attribute) applicable to the - # partof object, which is the object behind [$domain name]? - if {[info exists :scope] && \ - ![::nx::core::objectproperty [$domain name] ${:scope}]} { - error "The object '[$domain name]' does not qualify as '[$part_attribute scope]'" - } - next - } - } - :attribute @object-method -slotclass ::nx::doc::PartAttribute { - set :part_class @method - } - :attribute @param -slotclass ::nx::doc::PartAttribute { - set :part_class @param - } - - :method inherited {member} { - if {[${:name} info is class]} { - set inherited [dict create] - foreach c [lreverse [${:name} info heritage]] { - set entity [[::nx::core::current class] id $c] - if {![::nx::core::is $entity object]} continue; - if {[$entity exists :${member}]} { - dict set inherited $entity [$entity $member] - } - } - return $inherited - } - } - - :method process { - {-initial_section:optional "context"} - -entity:optional - comment_block - } { - next - - foreach methodName [${:name} info methods -methodtype scripted] { - set blocks [doc comment_blocks [${:name} info method \ - body $methodName]] - foreach {line_offset block} $blocks { - if {$line_offset > 1} break; - set id [:@method $methodName] - $id process -initial_section description $block - } - } - - foreach methodName [${:name} object info methods\ - -methodtype scripted] { - - set blocks [doc comment_blocks [${:name} object info method \ - body $methodName]] - foreach {line_offset block} $blocks { - if {$line_offset > 1} break; - set id [:@object-method $methodName] - $id process -initial_section description $block - } - } - - } - } - - - # @object ::nx::doc::Part - # - # A Part is a part of a documentation entity, defined by a - # separate object. Every Part is associated to another - # documentation entity and is identified by a name. - # - Class create Part -superclass Entity { - - #:method objectparameter args {next {doc -use}} - :attribute partof:required - :attribute use - :attribute part_attribute - } - - # @object ::nx::doc::@method - # - # "@method" is a named entity, which is part of some other - # docEntity (a class or an object). We might be able to use the - # "use" parameter for registered aliases to be able to refer to the - # documentation of the original method. - # - PartClass create @method \ - -superclass Part { - :attribute {@modifier public} -slotclass ::nx::doc::PartAttribute - :attribute @param -slotclass ::nx::doc::PartAttribute { - set :part_class @param - } - :attribute @return -slotclass ::nx::doc::PartAttribute { - - # - # TODO: @return spec fragments should be nameless, - # conceptually. They represent "out" parameters with each - # @method being allowed to have one only. For now, we fix - # this by injecting a dummy name "__out__" which should not - # be displayed. I shall fix this later and refactor it to a - # shared place between @method and @command. - # - :method require_part {domain prop value} { - set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}] - next $domain $prop $value - } - set :part_class @param - } - :method parameters {} { - set params [list] - if {[info exists :@param]} { - foreach p [:@param] { - set value [$p name] - if {[$p exists default] || [$p name] eq "args" } { - set value "?[$p name]?" - } - lappend params $value - } - } - return $params - } - :method process { - {-initial_section:optional "context"} - comment_block - } { - next \ - -initial_section $initial_section \ - -entity [self] $comment_block - } - - }; # @method - - PartClass create @subcommand -superclass {Part @command} - - # @object ::nx::doc::@param - # - # The entity type "@param" represents the documentation unit - # for several parameter types, e.g., object, method, and - # command parameters. - # - # @superclass ::nx::doc::entities::object::nx::doc::Part - # @superclass ::nx::doc::entities::object::nx::doc::Part - PartClass create @param \ - -superclass Part { - :attribute spec - :attribute default - - :object method id {partof name} { - # The method contains the parameter-specific name production rules. - # - # @param partof Refers to the entity object which contains this part - # @param name Stores the name of the documented parameter - # @modifier protected - - set partof_fragment [:get_unqualified_name ${partof}] - return [:root_namespace]::${:tag}::${partof_fragment}::${name} - } - - # @object-method new - # - # The per-object method refinement indirects entity creation - # to feed the necessary ingredients to the name generator - # - # @param -part_attribute - # @param -partof - # @param -name - # @param args - :object method new { - -part_attribute - {-partof:substdefault {[[MissingPartofEntity new \ - -message [subst { - Parts of type '[namespace tail [self]]' - require a partof entity to be set - }]] throw]}} - -name - args - } { - - lassign $name name def - set spec "" - regexp {^(.*):(.*)$} $name _ name spec - :createOrConfigure [:id $partof $name] \ - -spec $spec \ - -name $name \ - -partof $partof \ - {*}[expr {$def ne "" ? "-default $def" : ""}] \ - -part_attribute $part_attribute {*}$args - - } - } - - namespace export EntityClass @command @object @method @param \ - @param @package @ Exception StyleViolation InvalidTag \ - MissingPartofEntity ExceptionClass -} - - - -namespace eval ::nx::doc { - - Class create TemplateData { - # This mixin class realises a rudimentary templating language to - # be used in nx::doc templates. It realises language expressions - # to verify the existence of variables and simple loop constructs - :method render { - {-initscript ""} - template - {entity:substdefault "[self]"} - } { - # Here, we assume the -nonleaf mode being active for {{{[eval]}}}. - set tmplscript [list subst [[::nx::core::current class] read_tmpl $template]] - $entity eval [subst -nocommands { - $initscript - $tmplscript - }] - # $entity eval [list subst $template] - } - - - # - # some instructions for a dwarfish, embedded templating language - # - :method let {var value} { - uplevel 1 [list ::set $var [expr {[info exists value]?$value:""}]] - return - } - :method for {var list body} { - set rendered "" - ::foreach $var $list { - uplevel 1 [list ::set $var [set $var]] - append rendered [uplevel 1 [list subst $body]] - } - return $rendered - } - :method ?var {varname args} { - uplevel 1 [list :? -ops [list [::nx::core::current proc] -] \ - "\[info exists $varname\]" {*}$args] - } - :method ? { - {-ops {? -}} - expr - then - next:optional - args - } { - if {[info exists next] && $next ni $ops} { - return -code error "Invalid control operator '$next', we expect one of $ops" - } - set condition [list expr $expr] - if {[uplevel 1 $condition]} { - return [uplevel 1 [list subst $then]] - } elseif {[info exists next]} { - if {$next eq "-"} { - set args [lassign $args next_then] - if {$next_then eq ""} { - return -code error "A then script is missing for '-'" - } - if {$args ne ""} { - return -code error "Too many arguments: $args" - } - return [uplevel 1 [list subst $next_then]] - } - return [:$next {*}$args] - } - } - - :method include {template} { - uplevel 1 [list subst [[::nx::core::current class] read_tmpl $template]] - } - - # - # TODO: This should make turn into a hook, the output - # specificities should move in a refinement of TemplateData, e.g., - # DefaultHtmlTemplateData or the like. - # - :method fit {str max {placeholder "..."}} { - if {[llength [split $str ""]] < $max} { - return $str; - } - set redux [llength [split $placeholder ""]] - set margin [expr {($max-$redux)/2}] - return "[string range $str 0 [expr {$margin-1}]]$placeholder[string range $str end-[expr {$margin+1}] end]" - } - - :method list_structural_features {} { - set entry {{"access": "$access", "host": "$host", "name": "$name", "url": "$url", "type": "$type"}} - set entries [list] - if {[:info is type ::nx::doc::@package]} { - set features [list @object @command] - foreach feature $features { - set instances [sorted [$feature info instances] name] - foreach inst $instances { - set access "" - set host [:name] - set name [$inst name] - set url "[$inst filename].html" - set type [$feature tag] - lappend entries [subst $entry] - } - } - } elseif {[:info is type ::nx::doc::@object]} { - # TODO: fix support for @object-method! - set features [list @method @param] - foreach feature $features { - if {[:exists $feature]} { - set instances [sorted [:$feature] name] - foreach inst $instances { - set access [expr {[:exists @modifier]?[:@modifier]:""}] - set host [:name] - set name [$inst name] - set url "[:filename].html#[$feature tag]_[$inst name]" - set type [$feature tag] - lappend entries [subst $entry] - } - } - } - } - return "\[[join $entries ,\n]\]" - } - - :method code {{-inline true} script} { - return [expr {$inline?"$script":"
      $script
      "}] - } - - :method link {entity_type args} { - set id [$entity_type id {*}$args] - if {![::nx::core::is $id object]} return; - set pof "" - if {[$id info is type ::nx::doc::Part]} { - set pof "[[$id partof] name]#" - set filename [[$id partof] filename] - } else { - set filename [$id filename] - } - return "$pof[$id name]" - } - - :method text {} { - # Provide \n replacements for empty lines according to the - # rendering frontend (e.g., in HTML ->
      ) ... - if {[info exists :@doc]} { - set doc [next -as_list] - foreach idx [lsearch -all -exact $doc ""] { - lset doc $idx "

      " - } - return [subst [join $doc " "]] - } - } - - - - # - # - # - - :object method find_asset_path {{-subdir lib/doc-assets}} { - # This helper tries to identify the file system path of the - # asset ressources. - # - # @param -subdir Denotes the name of the sub-directory to look for - foreach dir $::auto_path { - set assets [file normalize [file join $dir $subdir]] - if {[file exists $assets]} { - return $assets - } - } - } - - :object method read_tmpl {path} { - if {[file pathtype $path] ne "absolute"} { - set assetdir [:find_asset_path] - set tmpl [file join $assetdir $path] - } else { - set tmpl [file normalize $path] - } - if {![file exists $tmpl] || ![file isfile $tmpl]} { - error "The template file '$path' was not found." - } - set fh [open $tmpl r] - set content [read $fh] - catch {close $fh} - return $content - } - - } - - # - # Provide a simple HTML renderer. For now, we make our life simple - # by defining for the different supported docEntities different methods. - # - # We could think about a java-doc style renderer... - # - - Class create Renderer { - :method render {} { - :render=[namespace tail [:info class]] - } - } - - Class create HtmlRenderer -superclass Renderer { - # render command pieces in the text - :method tt {text} {return <@TT>$text} - - - :method render=@package {} { - puts "
    • [:tt ${:name}]
      \n[:text]" - set req [:@require] - if {$req ne ""} { - puts "
        " - foreach r $req {puts "
      • $r
        • "} - puts "
      " - } - puts "
      • \n" - - } - - # - # render xotcl commands - # - :method render=@command {} { - puts "
    • [:tt ${:name}]
      \n[:text]" - # set variants [sorted [:variants] name] - # if {$variants ne ""} { - # puts "
        " - # foreach v $variants {puts "
      • [$v text]"} - # puts "
      " - # } - set params [:@param] - if {$params ne ""} { - puts "
        " - foreach v $params {puts "
      • [$v tt [$v name]] [$v text]"} - puts "
      " - } - puts "
      • \n" - } - - # - # render next classes - # - :method render=@object {} { - puts "
    • [:tt ${:name}]
      \n[:text]" - if {[info exists :@method]} { - set methods [sorted [:@method] name] - if {$methods ne ""} { - puts "
      Methods of ${:name}:\n
        " - foreach m $methods {$v render} - puts "
      " - } - } - if {[info exists :@object-method]} { - set methods [sorted [:@object-method] name] - if {$methods ne ""} { - puts "
      Object methods of ${:name}:\n
        " - foreach m $methods {$v render} - puts "
      " - } - } - puts "
      • \n" - } - - # - # render next methods - # - :method render=@method {} { - puts "
    • [:tt [:signature]]
      \n[:text]" - set params [:@param] - if {$params ne ""} { - puts "
        " - foreach v $params {puts "
      • [$v tt [$v name]] [$v text]"} - puts "
      " - } - if {${:returns} ne ""} { - puts " Returns: ${:@return}" - } - puts "\n" - } - - } - -} - -# -# post processor for initcmds and method bodies -# -namespace eval ::nx { - namespace import -force ::nx::doc::* - ::nx::Object create doc { - - :method log {msg} { - puts stderr "[self]->[uplevel 1 [list ::nx::core::current proc]]: $msg" - } - - # @method process - # - # There is a major distinction: Is the entity the comment block is - # referring to given *extrinsically* (to the comment block) or - # *intrinsically* (as a starting tag). - # - # a. extrinsic: 'thing' is a valid class or object name - # b. intrinsic: 'thing' is a arbitrary string block describing - # a script. - # - :method process {{-noeval false} thing args} { - # 1) in-situ processing: a class object - if {[::nx::core::objectproperty $thing object]} { - if {[$thing exists __initcmd]} { - :analyze_initcmd @object $thing [$thing eval {set :__initcmd}] - } - } elseif {![catch {package present $thing} msg]} { - # For tcl packages, we assume that the package is sourceable - # in the current interpreter. - set i [interp create] - set cmd [subst -nocommands { - package req nx::doc - namespace import -force ::nx::*; - ::nx::Class create SourcingTracker { - :method create args { - set obj [next]; - #[::nx::core::current class] eval { - # if {![info exists :scripts([info script])]} { - #dict create :scripts - #dict set :scripts [info script] objects - # } - #} - #puts stderr "dict lappend :scripts([info script]) objects [self]" - [::nx::core::current class] eval [list dict set :scripts [info script] objects \$obj _] - return \$obj - } - } - ::nx::Object mixin add SourcingTracker - package forget $thing; - package req $thing - ::nx::Object mixin delete SourcingTracker - puts stderr sourced_scripts=[SourcingTracker eval {dict keys \${:scripts}}] - dict for {script entities} [SourcingTracker eval {set :scripts}] { - doc process \$script \$entities - } - - }] - interp eval $i $cmd - return $i - } elseif {[file isfile $thing]} { - # 3) alien script file - if {[file readable $thing]} { - set fh [open $thing r] - if {[catch {set script [read $fh]} msg]} { - catch {close $fh} - :log "error reading the file '$thing', i.e.: '$msg'" - } - close $fh - doc analyze -noeval $noeval $script {*}$args - #doc process -noeval $noeval $script {*}$args - } else { - :log "file '$thing' not readable" - } - } else { - # 4) we assume a string block, e.g., to be fed into eval - set i [interp create] - set cmd [subst { - package req nx::doc - namespace import -force ::nx::doc::* - doc analyze -noeval $noeval [list $thing] - }] - interp eval $i $cmd - #interp delete $i - return $i - } - } - - :method analyze {{-noeval false} script {additions ""}} { - # NOTE: This method is to be executed in a child/ slave - # interpreter. - if {!$noeval} { - uplevel #0 [list namespace import -force ::nx::doc::*] - set pre_commands [:list_commands] - uplevel #0 [list eval $script] - set post_commands [:list_commands] - if {$additions eq ""} { - set additions [dict keys [dict remove [dict create {*}"[join $post_commands " _ "] _"] {*}$pre_commands]] - } else { - set additions [dict keys [dict get $additions objects]] - } - # puts stderr ADDITIONS=$additions - } - set blocks [:comment_blocks $script] - # :log "blocks: '$blocks'" - # 1) eval the script in a dedicated interp; provide for - # recording script-specific object additions. - # set failed_blocks [list] - foreach {line_offset block} $blocks { - # 2) process the comment blocks, however, fail gracefully here - # (most blocks, especially in initcmd and method blocks, are - # not qualified, so they are set to fail. however, record the - # failing ones for the time being - if {[catch {::nx::doc::EntityClass process $block} msg]} { - if {![InvalidTag behind? $msg] && ![StyleViolation behind? $msg] && ![MissingPartofEntity behind? $msg]} { - if {[Exception behind? $msg]} { - error [$msg info class]->[$msg message] - } - error $msg - } - } - } - # 3) process the recorded object additions, i.e., the stored - # initcmds and method bodies. - foreach addition $additions { - # TODO: for now, we skip over pure Tcl commands and procs - if {![::nx::core::is $addition object]} continue; - :process [namespace origin $addition] - } - } - - :method list_commands {{parent ""}} { - set cmds [info commands ${parent}::*] - foreach nsp [namespace children $parent] { - lappend cmds {*}[:list_commands ${nsp}] - } - return $cmds - } - - :method analyze_line {line} { - set regex {^[\s#]*#+(.*)$} - if {[regexp -- $regex $line --> comment]} { - return [list 1 [string trimright $comment]] - } else { - return [list 0 $line] - } - } - - :method comment_blocks {script} { - set lines [split $script \n] - set comment_blocks [list] - set was_comment 0 - - set spec { - 0,1 { - set line_offset $line_counter; - set comment_block [list]; - # Note, we use [split] here to avoid stumbling over - # uncommented script blocks which contain pairs of curly - # braces which appear scattered over several physical lines - # of code. This avoids "unmatched open brace" failures when - # feeding each physical line to a list command (later, in - # the parsing machinery) - lappend comment_block $text} - 1,0 {lappend comment_blocks $line_offset $comment_block} - 1,1 {lappend comment_block $text} - 0,0 {} - } - array set do $spec - set line_counter -1 - foreach line $lines { - incr line_counter - # foreach {is_comment text} [:analyze_line $line] break; - lassign [:analyze_line $line] is_comment text; - eval $do($was_comment,$is_comment) - set was_comment $is_comment - } - return $comment_blocks - } - - :method analyze_initcmd {docKind name initcmd} { - set first_block 1 - set failed_blocks [list] - foreach {line_offset block} [:comment_blocks $initcmd] { - set arguments [list] - if {$first_block} { - set id [@ $docKind $name] - # - # Note: To distinguish between intial comments blocks - # in initcmds and method bodies which refer to the - # surrounding entity (e.g., the object or the method) - # we use the line_offset recorded by the - # comment_blocks() scanner. Later, we plan to use the - # line_offset to compute line pointers for error - # messages. Also, we can use the line offsets of each - # comment block to identify faulty comment blocks. - # - # A acceptance level of <= 1 means that a script - # block must contain the first line of this - # special-purpose comment block either in the very - # first or second script line. - # - if {$line_offset <= 1} { - lappend arguments -initial_section description - lappend arguments -entity $id - } - set first_block 0 - } else { - set initial_section context - } - lappend arguments $block - # TODO: Filter for StyleViolations as >the only< valid case - # for a continuation. Report other issues immediately. What - # about InvalidTag?! - if {[catch {$id process {*}$arguments} msg]} { - lappend failed_blocks $line_offset - } - } - - }; # analyze_initcmd method - - - # activate the recoding of initcmds - ::nx::core::configure keepinitcmd true - - } -} - - -# -# toplevel interface -# ::nx::doc::make all -# ::nx::doc::make doc -# -namespace eval ::nx::doc { - - Object create make { - - :method all {{-verbose:switch} {-class ::nx::Class}} { - foreach c [$class info instances -closure] { - if {$verbose} {puts "postprocess $c"} - ::nx::doc::postprocessor process $c - } - } - - :method doc { - {-renderer ::nx::doc::HtmlRenderer} - {-outdir /tmp/} - } { - - # register the HTML renderer for all docEntities. - - Entity mixin add $renderer - - puts "

      Tcl packages

      \n
        " - foreach pkg [sorted [@package info instances] name] { - $pkg render - } - - - puts "

        Primitive Next framework commands

        \n
          " - foreach cmd [sorted [@command info instances] name] { - $cmd render - } - puts "
        \n\n" - - puts "

        Next objects

        \n
          " - foreach cmd [sorted [@object info instances] name] { - $cmd render - } - puts "
        \n\n" - - Entity mixin delete $renderer - } - - :method write {content path} { - set fh [open $path w] - puts $fh $content - catch {close $fh} - } - - :method doc { - {-renderer ::nx::doc::HtmlRenderer} - {-outdir /tmp/} - {-tmpl entity.html.tmpl} - {-project {url http://www.next-scripting.org/ name Next}} - } { - array set prj $project - set project [@project new -name $prj(name) -url $prj(url) -version $prj(version)] - Entity mixin add $renderer - set ext [lindex [split [file tail $tmpl] .] end-1] - set entities [concat [sorted [@package info instances] name] \ - [sorted [@command info instances] name] \ - [sorted [@object info instances] name]] - set init [subst -nocommands { - set project $project - }] - - if {![catch {file mkdir [file join $outdir [$project name]]} msg]} { - file copy -force -- [$renderer find_asset_path] [file join $outdir [$project name]]/assets - set index [$project render -initscript $init $tmpl] - :write $index [file join $outdir [$project name] "index.$ext"] - foreach e $entities { - set content [$e render -initscript $init $tmpl] - :write $content [file join $outdir [$project name] "[$e filename].$ext"] - } - } - - Entity mixin delete $renderer - } - } - - - # - # modal comment block parsing - # - - # - # contexts are entities - # - EntityClass eval { - :object forward has_next expr {${:idx} < [llength ${:comment_block}]} - :object method dequeue {} { - set r [lindex ${:comment_block} ${:idx}] - incr :idx - return $r - } - :object forward rewind incr :idx -1 - :object forward fastforward set :idx {% expr {[llength ${:comment_block}] - 1} } - :object method process { - {-partof_entity:optional ""} - {-initial_section:optional context} - -entity:optional - block - } { - set :comment_block $block - - # initialise the context object - #puts stderr "--- [self callingproc] -> :partof_entity $partof_entity :processed_section $initial_section block $block" - set :processed_section $initial_section - set :partof_entity $partof_entity - - if {[info exists :current_entity]} { - unset :current_entity - } - - if {[info exists entity]} { - set :current_entity $entity - } - - set :is_not_completed 1 - - ${:processed_section} eval [list set :context [self]] - set is_first_iteration 1 - set :idx 0 - set failure "" - while {${:is_not_completed}} { - set line [:dequeue] - if {$is_first_iteration} { - ${:processed_section} on_enter $line - set is_first_iteration 0 - } - - if {[catch {${:processed_section} transition $line} failure]} { - set :is_not_completed 0 - # - # TODO: For now, the fast-forward mechanism jumps to the end - # of the comment block; this avoids redundant on_exit - # calls. is there a better way of achieving this? - # - :fastforward - } else { - set :is_not_completed [:has_next] - } - } - if {!$is_first_iteration} { - ${:processed_section} on_exit $line - } - - if {$failure ne ""} { - #puts stderr ERRORINFO=$::errorInfo - error $failure - } - - return ${:current_entity} - } - - :object method resolve_partof_entity {tag name} { - # a) unqualified: attr1 - # b) qualified: Bar#attr1 - if {[regexp -- {([^\s#]*)#([^\s#]*)} $name _ qualifier nq_name]} { - # TODO: Currently, I only foresee @object and @command as - # possible qualifiers; however, this should be fixed asap, as - # soon as the variety of entities has been decided upon! - foreach entity_type {@object @command} { - set partof_entity [$entity_type id $qualifier] - # TODO: Also, we expect the qualifier to resolve against an - # already existing entity object? Is this intended? - if {[::nx::core::is $partof_entity object]} { - return [list $nq_name $partof_entity] - } - } - return [list $nq_name ${:partof_entity}] - } else { - return [list $name ${:partof_entity}] - } - } - :object method dispatch {tag args} { - - if {![info exists :current_entity]} { - # 1) the current (or context) entity has NOT been resolved - # - # for named entities, the provided identifier can be either - # qualified or unqualified: - # - # a) unqualified: @param attr1 - # b) qualified: @param Bar#attr1 - # - # For qualified ones, we must resolve the qualifier to serve - # as the partof_entity; see resolve_partof_entity() - - set name [lindex $args 0] - set args [lrange $args 1 end] - lassign [:resolve_partof_entity $tag $name] nq_name partof_entity; - - if {$partof_entity ne ""} { - if {[$partof_entity info callable -application $tag] eq ""} { - [InvalidTag new -message [subst { - The tag '$tag' is not supported for the entity type - '[namespace tail [$partof_entity info class]]' - }]] throw - } - # puts stderr "1. $partof_entity $tag $nq_name {*}$args" - set :current_entity [$partof_entity $tag $nq_name {*}$args] - - } else { - # - # TODO: @object-method raises some issues (at least when - # processed without a resolved context = its partof entity). - # It is not an entity type, because it merely is a "scoped" - # @method. It won't resolve then as a proper instance of - # EntityClass, hence we observe an InvalidTag exception. For - # now, we just ignore and bypass this issue by allowing - # InvalidTag exceptions in analyze() - # - set qualified_tag [namespace qualifiers [self]]::$tag - if {[EntityClass info instances -closure $qualified_tag] eq ""} { - [InvalidTag new -message [subst { - The entity type '$tag' is not available - }]] throw - } - set :current_entity [$tag new -name $nq_name {*}$args] - } - } else { - # 2) current (or context) entity has been resolved - # TODO: Should we explicitly disallow qualified names in parts? - if {[${:current_entity} info callable -application $tag] eq ""} { - [InvalidTag new -message [subst { - The tag '$tag' is not supported for the entity type - '[namespace tail [${:current_entity} info class]]' - }]] throw - } - # puts stderr "${:current_entity} $tag {*}$args" - ${:current_entity} $tag {*}$args - } - } - } - - - - # - # Infrastructure for state objects: - # - # 1. CommentState: a base class for sharing behaviour between atomic - # and non-orthogonal super-states; it is widely an intermediate, - # abstracted class, providing a refinement protocol for concrete - # state subclasses - # - - Class create CommentState { - :attribute context; # points to the context object, i.e., an entity - :method on_enter {line} {;} - - :method signal {event line} {;} - - # - # activity/event interface - # - - :method event=process {line} {;} - :method event=close {line} {;} - :method event=next {line} {;} - :method event=exit {msg} { - error $msg - } - :method event=rewind {line} {;} - } - - # 2. CommentLines represent atomic states in the parsing state - # machinery: tag, text, space - - Class create CommentLine -superclass CommentState { - :attribute comment_section; # points to the super-state objects - :attribute processed_line; # stores the processed text line - :forward signal {% ${:comment_section} } %proc - :forward context {% ${:comment_section} } %proc - :forward current_entity {% :context } eval set :current_entity - - :method on_enter {line} {;} - :method on_exit {line} {;} - - :method match {line} {;} - :method is? {line} { - foreach cline [lsort [[:info class] info instances]] { - if {[$cline match $line]} { - return [namespace tail $cline] - } - } - } - - set :markup_map(sub) { - "{{{" "\[:code \{" - "}}}" "\}\]" - "{{" "\[:link " - "}}" "\]" - - } - set :markup_map(unescape) { - "\\{" "{" - "\\}" "}" - "\\#" "#" - } - - :method map {line set} { - set line [string map [[::nx::core::current class] eval [list set :markup_map($set)]] $line] - } - - } - - - CommentLine create tag { - :method match {line} { - return [regexp -- {^\s*@[^[:space:]@]+} $line] - } - :method event=process {line} { - set line [:map $line sub] - set line [:map $line unescape] - set line [split [string trimleft $line]] - set tag [lindex $line 0] - #puts stderr "---line->$line" - [:context] dispatch $tag [lrange $line 1 end] - } - - } - - CommentLine create text { - set :is_code_block 0 - array set :parse { - 0,1 { - # BEGIN of a code block. Insert the code start marker, a newline and the current line. - set l "\[:code \{\n" - append l $line \n - set line $l - set :is_code_block 1 - } - 1,0 { - # END of a code block. Insert the code stop marker. - set l "\}\]\n" - append l $line - set line $l - set :is_code_block 0 - } - 1,1 { - # WITHIN a code block. Add the line + a newline - append line \n - } - 0,0 { - # NOP - set line [string trimleft $line] - } - } - - :method match {line} { - return [regexp -- {^\s*([^[:space:]@]+|@[[:space:]@]+)} $line] - } - - :method event=process {line} { - set is_intended [expr {[string first "\t" $line] != -1}] - eval [set :parse(${:is_code_block},$is_intended)] - [:context] dispatch @doc add $line end - } - - :method event=process {line} { - if {[regsub -- {^\s*(\{\{\{)\s*$} $line "\[:code -inline false \{" line] || \ - (${:is_code_block} && [regsub -- {^\s*(\}\}\})\s*$} $line "\}\]" line])} { - set :is_code_block [expr {!${:is_code_block}}] - append line \n - } elseif {${:is_code_block}} { - set line [:map $line unescape] - append line \n - } else { - set line [:map $line sub] - set line [:map $line unescape] - set line [string trimleft $line] - } - [:context] dispatch @doc add $line end - } - - :method toggle_code_block {is_indented} { - set :is_code_block [expr {}] - } - - } - - CommentLine create space { - :method match {line} { - return [expr {$line eq {}}] - } - :method event=process {line} { - if {[:comment_section] eq "::nx::doc::description"} { - [:context] dispatch @doc add "" end - } - next - } - } - - - # - # 3. CommentSections represent orthogonal super-states over - # CommentLines: context, description, part - # - - Class create CommentSection -superclass CommentState { - :attribute entry_comment_line:required - :attribute current_comment_line - :attribute comment_line_transitions - :attribute next_comment_section; # implements a STATE-OWNED TRANSITION scheme - - :method init {} { - ${:entry_comment_line} comment_section [self] - } - - :method transition {line} { - array set transitions ${:comment_line_transitions} - - if {![info exists :current_comment_line]} { - set src "" - set tgt [${:entry_comment_line} is? $line] - } else { - set src ${:current_comment_line} - set tgt [$src is? $line] - } - #puts stderr "---- line $line src $src tgt $tgt" - # - # TODO: realise the initial state nodes as NULL OBJECTs, this - # helps avoid conditional branching all over the place! - # - if {$src ne ""} { - $src on_exit $line; - } - if {![info exists transitions(${src}->${tgt})]} { - set msg "Style violation in a [namespace tail [self]] section:\n" - if {$src eq ""} { - append msg "Invalid first line ('${tgt}')" - } else { - append msg "A ${src} line is followed by a ${tgt} line" - } - [StyleViolation new -message $msg] throw - } - - set :current_comment_line $tgt - $tgt comment_section [self] - ${:current_comment_line} processed_line $line - ${:current_comment_line} on_enter $line - - #foreach {event activities} $transitions(${src}->${tgt}) break; - lassign $transitions(${src}->${tgt}) event activities; - :signal $event $line - foreach activity $activities { - :signal $activity $line - } - } - - :method on_enter {line} {;} - - :method on_exit {line} { - # TODO: move this behaviour into a more decent place - if {![${:context} has_next]} { - ${:current_comment_line} on_exit $line - } - # Note: Act passive here, because e.g. upon invalid entry - # state transition requests, there is no current_comment_line - # set here. Yet, we want to exit from the comment section! - if {[info exists :current_comment_line]} { - unset :current_comment_line - } - next - } - - :method signal {event line} { - ${:current_comment_line} event=$event $line - :event=$event $line - } - - # - # handled events - # - :method event=next {line} { - set next_section [:next_comment_section] - ${:current_comment_line} on_exit $line - :on_exit $line - $next_section eval [list set :context ${:context}] - $next_section on_enter $line - ${:context} eval [list set :processed_section [:next_comment_section]] - - } - - :method event=rewind {line} { - ${:context} rewind - next - } - - }; # CommentSection - - - # - # the OWNER-DRIVEN TRANSITIONS read as follows: - # (current_state)->(next_state) {event {activity1 activty2 ...}} - # - - # - # TODO: refactor {close {rewind next}} into a single activity - # - - # - # context - # - CommentSection create context \ - -next_comment_section description \ - -comment_line_transitions { - ->tag {process ""} - tag->space {process ""} - space->space {process ""} - space->text {close {rewind next}} - space->tag {close {rewind next}} - } -entry_comment_line tag - - # NOTE: add these transitions for supporting multiple text lines for - # the context element - # tag->text {process ""} - # text->text {process ""} - # text->space {process ""} - - # - # description - # - CommentSection create description \ - -next_comment_section part \ - -comment_line_transitions { - ->text {process ""} - ->tag {close {rewind next}} - text->text {process ""} - text->space {process ""} - space->text {process ""} - space->space {process ""} - space->tag {close {rewind next}} - } -entry_comment_line text { - :method on_enter {line} { - # - # TODO: fix the re-set of the @doc attribute - # - if {[${:context} exists :current_entity]} { - ${:context} eval { - ${:current_entity} eval { - unset -nocomplain :@doc - } - } - } - next; - } - } - - # - # part - # - CommentSection create part \ - -next_comment_section part \ - -comment_line_transitions { - ->tag {process ""} - tag->text {process ""} - text->text {process ""} - text->tag {close {rewind next}} - text->space {process ""} - space->space {process ""} - tag->space {process ""} - space->tag {close {rewind next}} - tag->tag {close {rewind next}} - } -entry_comment_line tag -} - -puts stderr "Doc Tools loaded: [info command ::nx::doc::*]" \ No newline at end of file Index: library/lib/pkgIndex.tcl =================================================================== diff -u -N -r183ec0e7c071586238bf5ed90a05dbbda91d4582 -r8aaec98df564488dc8540cd078d6a32dd55a08f7 --- library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) +++ library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -9,7 +9,7 @@ # full path name of this file's directory. package ifneeded XOTcl 2.0 [list source [file join $dir xotcl2.tcl]] -package ifneeded nx::doc 0.1 [list source [file join $dir doc-tools.xotcl]] +package ifneeded nx::doc 0.1 [list source [file join $dir doc-tools.tcl]] package ifneeded nx::test 1.0 [list source [file join $dir test.tcl]] package ifneeded xotcl::htmllib 0.1 [list source [file join $dir htmllib.xotcl]] package ifneeded xotcl::metadataAnalyzer 0.84 [list source [file join $dir metadataAnalyzer.xotcl]] Index: tests/doc.tcl =================================================================== diff -u -N --- tests/doc.tcl (revision 0) +++ tests/doc.tcl (revision 8aaec98df564488dc8540cd078d6a32dd55a08f7) @@ -0,0 +1,626 @@ +package require nx +package require nx::test +package require nx::doc + +namespace import -force ::nx::* +namespace import -force ::nx::doc::* + + +Test parameter count 1 + +# +# some helper +# + +proc lcompare {a b} { + foreach x $a y $b { + if {$a ne $b} { + return -1; break; + } + } + return 1 +} + +Class create ::nx::doc::CommentState::Log { + :method on_enter {line} { + puts -nonewline stderr "ENTER -> [namespace tail [:info class]]#[namespace tail [self]]" + next + } + :method on_exit {line} { + next + puts -nonewline stderr "EXIT -> [namespace tail [:info class]]#[namespace tail [self]]" + } +} + +Class create ::nx::doc::CommentLine::Log { + :method on_enter {line} { + puts -nonewline stderr "\t"; next; puts stderr " -> LINE = ${:processed_line}" + } + :method on_exit {line} { + puts -nonewline stderr "\t"; next; puts stderr " -> LINE = ${:processed_line}" + } +} + +Class create ::nx::doc::CommentSection::Log { + :method on_enter {line} { + next; puts -nonewline stderr "\n" + } + :method on_exit {line} { + next; puts -nonewline stderr "\n"; + } +} + +set log false + +if {$log} { + ::nx::doc::CommentState mixin add ::nx::doc::CommentState::Log + ::nx::doc::CommentLine mixin add ::nx::doc::CommentLine::Log + ::nx::doc::CommentSection mixin add ::nx::doc::CommentSection::Log +} + +# -- + + +Test case scanning { + + set lines { + "# @package o" 1 + "#@package o" 1 + "bla" 0 + "# @object o" 1 + "# 1 2 3" 1 + "#" 1 + "# " 1 + " # " 1 + "\t#\t \t" 1 + "# 345" 1 + "# @tag1 part1" 1 + "bla; # no comment" 0 + "" 0 + "\t\t" 0 + "### # # # # @object o # ####" 1 + "# # # # # 345" 1 + "# # # @tag1 part1" 1 + "bla; # # # # # no comment" 0 + " " 0 + + } + + foreach {::line ::result} $lines { + ? {foreach {is_comment text} [doc analyze_line $::line] break; set is_comment} $::result "doc analyze_line '$::line'" + } + + set script { + # @package o + # 1 2 3 + bla + bla + # @object o + # 1 2 3 + # + # 345 + # @tag1 part1 + # @tag2 part2 + bla; # no comment + bla + bla + bla + + + ### # # # # @object o # #### + # 1 2 3 + # + # # # # # 345 + # # # @tag1 part1 + # @tag2 part2 + bla; # # # # # no comment + } + + set blocks {1 {{ @package o} { 1 2 3}} 5 {{ @object o} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}} 17 {{ @object o # ####} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}}} + + ? [list ::lcompare [doc comment_blocks $script] $blocks] 1 +} + +Test case parsing { + # + # TODO: Add tests for doc-parsing state machine. + # + set block { + {@command cc} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 + + set block { + {} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + # + # For now, a valid comment block must start with a non-space line + # (i.e., a tag or text line, depending on the section: context + # vs. description) + # + + set block { + {} + {@command cc} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + set block { + {command cc} + {} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + set block { + {@command cc} + {some description} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + set block { + {@command cc} + {} + {} + {} + {@see ::o} + } + EntityClass process $block + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 + + set block { + {@command cc} + {} + {some description} + {some description2} + {} + {} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 + + # Note: We do allow description blocks with intermediate space + # lines, for now. + set block { + {@command cc} + {} + {some description} + {some description2} + {} + {an erroreneous description line, for now} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 + + # + # TODO: Do not enforce space line between the context and imediate + # part block (when description is skipped)? + # + # OR: For absolutely qualifying parts (e.g., outside of an initcmd block), + # do we need sequences of _two_ (or more) tag lines, e.g. + # + # -- + # @object Foo + # @param attr1 + # -- + # + # THEN, we can only discriminate between the context and an + # immediate part section by requiring a space line! + # + # Alternatively, we can use the @see like syntax for qualifying: + # @param ::Foo#attr1 (I have a preference for this option). + set block { + {@command cc} + {@see someOtherEntity} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + # + # TODO: Disallow space lines between parts? Check back with Javadoc spec. + # + set block { + {@command cc} + {} + {@see SomeOtherEntity} + {add a line of description} + {} + {} + {@see SomeOtherEntity2} + {} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 + + # + # TODO: Should we enforce a mandatory space line between description and part block? + # + set block { + {@command cc} + {} + {add a line of description} + {a second line of description} + {a third line of description} + {@see entity3} + {@see SomeOtherEntity2} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + set block { + {@command cc} + {} + {add a line of description} + {a second line of description} + {a third line of description} + {} + {@see SomeOtherEntity2} + {} + {} + {an erroreneous description line, for now} + } + + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 + + set block { + {@command cc} + {} + {add a line of description} + {a second line of description} + {} + {a third line of description} + {} + {@see SomeOtherEntity2} + } + ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 + + set block { + {@object cc} + {} + {add a line of description} + {a second line of description} + {} + {@see SomeOtherEntity2} + {@xyz SomeOtherEntity2} + } + ? [list InvalidTag thrown_by? [list EntityClass process $block]] 1 + + set block { + {@class cc} + {} + {add a line of description} + {a second line of description} + {} + {@see SomeOtherEntity2} + {@xyz SomeOtherEntity2} + } + ? [list InvalidTag thrown_by? [list EntityClass process $block]] 1 + + + + # + # testing the doc object construction + # + set block { + {@object o} + {} + {some more text} + {and another line for the description} + {} + {@author stefan.sobernig@wu.ac.at} + {@author gustaf.neumann@wu-wien.ac.at} + } + set entity [EntityClass process $block] + ? [list ::nx::core::is $entity object] 1 + ? [list $entity info is type ::nx::doc::@object] 1 + ? [list $entity @author] "stefan.sobernig@wu.ac.at gustaf.neumann@wu-wien.ac.at"; + ? [list $entity text] "some more text and another line for the description"; + + set block { + {@command c} + {} + {some text on the command} + {} + {@see ::o} + } + set entity [EntityClass process $block] + ? [list ::nx::core::is $entity object] 1 + ? [list $entity info is type ::nx::doc::@command] 1 + ? [list $entity text] "some text on the command"; + ? [list $entity @see] "::o"; + + # + # basic test for in-situ documentation (initcmd block) + # + # + + set script { + Class create Foo { + # The class Foo defines the behaviour for all Foo objects + # + # @author gustaf.neumann@wu-wien.ac.at + # @author ssoberni@wu.ac.at + + # @param attr1 + # + # This attribute 1 is wonderful + # + # @see ::nx::Attribute + # @see ::nx::MetaSlot + :attribute attr1 + :attribute attr2 + :attribute attr3 + + # @method foo + # + # This describes the foo method + # + # @param a Provides a first value + # @param b Provides a second value + :method foo {a b} {;} + } + } + + eval $script + doc process ::Foo + set entity [@object id ::Foo] + ? [list ::nx::core::is $entity object] 1 + ? [list $entity info is type ::nx::doc::@object] 1 + ? [list $entity text] "The class Foo defines the behaviour for all Foo objects"; + ? [list $entity @author] "gustaf.neumann@wu-wien.ac.at ssoberni@wu.ac.at" + # TODO: Fix the [@param id] programming scheme to allow (a) for + # entities to be passed and the (b) documented structures + #set entity [@param id ::Foo class attr1] + set entity [@param id $entity attr1] + ? [list ::nx::core::is $entity object] 1 + ? [list $entity info is type ::nx::doc::@param] 1 + ? [list $entity @see] "::nx::Attribute ::nx::MetaSlot"; + + set entity [@method id ::Foo class foo] + ? [list [@object id ::Foo] @method] $entity + ? [list ::nx::core::is $entity object] 1 + ? [list $entity info is type ::nx::doc::@method] 1 + ? [list $entity text] "This describes the foo method"; + + foreach p [$entity @param] expected { + "Provides a first value" + "Provides a second value" + } { + ? [list expr [list [$p text] eq $expected]] 1; + } + + + # TODO: how to realise scanning and parsing for mixed ex- and + # in-situ documentation? That is, how to differentiate between + # absolutely and relatively qualified comment blocks in line-based + # scanning phase (or later)? + + set script { + namespace import -force ::nx::* + # @object Bar + # + # The class Bar defines the behaviour for all Bar objects + # + # @author gustaf.neumann@wu-wien.ac.at + # @author ssoberni@wu.ac.at + + # @param Bar#attr1 + # + # This attribute 1 is wonderful + # + # @see ::nx::Attribute + # @see ::nx::MetaSlot + + # @method Bar#foo + # + # This describes the foo method + # + # @param a Provides a first value + # @param b Provides a second value + + # @object-method Bar#foo + # + # This describes the per-object foo method + # + # @param a Provides a first value + # @param b Provides a second value + + namespace eval ::ns1 { + ::nx::Object create ooo + } + Class create Bar { + + :attribute attr1 + :attribute attr2 + :attribute attr3 + + # @method foo + # + # This describes the foo method in the initcmd + # + # @param a Provides a first value + # @param b Provides a second value + + :method foo {a b} { + # This describes the foo method in the method body + # + # @param a Provides a first value (refined) + + } + + :object method foo {a b c} { + # This describes the per-object foo method in the method body + # + # @param b Provides a second value (refined) + # @param c Provides a third value (first time) + + } + + } + } + + set i [doc process $script] + + set entity [@object id ::Bar] + ? [list $i eval [list ::nx::core::is $entity object]] 1 + ? [list $i eval [list $entity info is type ::nx::doc::@object]] 1 + ? [list $i eval [list $entity text]] "The class Bar defines the behaviour for all Bar objects"; + ? [list $i eval [list $entity @author]] "gustaf.neumann@wu-wien.ac.at ssoberni@wu.ac.at" + + # TODO: Fix the [@param id] programming scheme to allow (a) for + # entities to be passed and the (b) documented structures + #set entity [@param id ::Bar class attr1] + set entity [@param id $entity attr1] + ? [list $i eval [list ::nx::core::is $entity object]] 1 + ? [list $i eval [list $entity info is type ::nx::doc::@param]] 1 + ? [list $i eval [list $entity @see]] "::nx::Attribute ::nx::MetaSlot"; + + set entity [@method id ::Bar class foo] + ? [list $i eval [list [@object id ::Bar] @method]] $entity + ? [list $i eval [list ::nx::core::is $entity object]] 1 + ? [list $i eval [list $entity info is type ::nx::doc::@method]] 1 + ? [list $i eval [list $entity text]] "This describes the foo method in the method body"; + + foreach p [$i eval [list $entity @param]] expected { + "Provides a first value (refined)" + "Provides a second value" + } { + ? [list expr [list [$i eval [list $p text]] eq $expected]] 1; + } + set entity [@method id ::Bar object foo] + ? [list $i eval [list [@object id ::Bar] @object-method]] $entity + ? [list $i eval [list ::nx::core::is $entity object]] 1 + ? [list $i eval [list $entity info is type ::nx::doc::@method]] 1 + ? [list $i eval [list $entity text]] "This describes the per-object foo method in the method body"; + + foreach p [$i eval [list $entity @param]] expected { + "Provides a first value" + "Provides a second value (refined)" + "Provides a third value (first time)" + } { + ? [list expr [list [$i eval [list $p text]] eq $expected]] 1; + } + + interp delete $i + puts stderr ================================================= + # + # self documentation + # + if {[catch {set i [doc process nx::doc]} msg]} { + if {[Exception behind? $msg]} { + puts stderr [$msg info class]->[$msg message] + } else { + error $msg + } + } + ? [list $i eval [list ::nx::core::is [@package id nx::doc] object]] 1 + puts stderr [$i eval [list [@package id nx::doc] text]] + puts stderr [$i eval [list [@package id nx::doc] @require]] + set path [file join /tmp nextdoc] + if {[file exists $path]} { + file delete -force $path + } + $i eval [list ::nx::doc::make doc \ + -renderer ::nx::doc::TemplateData \ + -outdir /tmp \ + -project {name nextdoc url http://www.next-scripting.org/ version 0.1d}] + interp delete $i + + # + # core documentation + # + set path [file join /tmp NextLanguageCore] + if {[file exists $path]} { + file delete -force $path + } + + set i [interp create] + $i eval { + package req nx::doc + namespace import ::nx::* + namespace import ::nx::doc::* + doc process -noeval true generic/gentclAPI.decls + doc process -noeval true generic/predefined.tcl + ::nx::doc::make doc \ + -renderer ::nx::doc::TemplateData \ + -outdir /tmp \ + -project {name NextLanguageCore url http://www.next-scripting.org/ version 1.0.0a} + } + interp delete $i +} + + + +# # # # # # # # # # # # # # # # # # # # +# # # # # # # # # # # # # # # # # # # # +# # # # # # # # # # # # # # # # # # # # + +# 1) Test case scoping rules -> in Object->eval() +# Why does [info] intropsection not work as expected in eval()? + +Test case issues? { + + # TODO: is [autoname -instance] really needed? + + # TODO: why is XOTclNextObjCmd/::nx::core::next not in gentclAPI.decls? + + # TODO: where to locate the @ comments (in predefined.xotcl, in + # gentclAPI.decls)? how to deal with ::nx::core::* vs. ::nx::* + + # TODO: which values are returned from Object->configure() and + # passed to init()? how to document residualargs()? + + # TODO: Object->cleanup() said: "Resets an object or class into an + # initial state, as after construction." If by construction it means + # after create(), then cleanup() is missing a configure() call to + # set defaults, etc! + + # TODO: exists and bestandteil von info() oder selbstständig? + # ausserdem: erlauben von :-präfix?! + + # TODO: should we keep a instvar variant (i support this!) + + # TODO: verify the use of filtersearch()? should it return a method + # handle and the filter name? how to deal with it when refactoring + # procsearch()? + + # TODO: mixinguard doc is missing in old doc + + # TODO: what is Object->__next() for? + + # TODO: what to do with hasNamespace()? [Object info is namespace]? + + # TODO: why is XOTclOUplevelMethodStub/XOTclOUplevelMethod defined + # with "args" while it logically uses the stipulated parameter + # signature (level ...). is this because of the first pos, optional + # parameter? ... same goes for upvar() ... + + # TODO: is Object->uplevel still needed with an integrated cs management? + + # TODO: how is upvar affected by the ":"-prefixing? -> AVOID_RESOLVERS ... + + # TODO: do all member-creating operations return valid, canonical handles! + + # TODO: the objectsystems subcommand of ::nx::core::configure does + # not really fit in there because it does not allow for configuring + # anything. it is a mere introspection-only command. relocate (can + # we extend standard [info] somehow, i.e., [info objectsystems] + + # TODO: extend [info level] & [info frame]! + + # TODO: there is still --noArgs on [next], which does not correspond + # to single-dashed flags used elsewhere. Why? + + # TODO: renaming of self to current? + + # TODO: is [self callingclass] == [[self callingobject] info class]? + + # TODO: "# @subcommand next Returns the name of the method next on + # the precedence path as a string" shouldn't these kinds of + # introspective commands return method handles (in the sense of + # alias)? Retrieving the name from a handle is the more specific + # operation (less generic). ... same for "filterreg" + +} + +if {$log} { + ::nx::doc::CommentState mixin delete ::nx::doc::CommentState::Log + ::nx::doc::CommentLine mixin delete ::nx::doc::CommentLine::Log + ::nx::doc::CommentSection mixin delete ::nx::doc::CommentSection::Log +} Index: tests/doc.xotcl =================================================================== diff -u -N --- tests/doc.xotcl (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/doc.xotcl (revision 0) @@ -1,644 +0,0 @@ -package require nx -package require nx::test -package require nx::doc - -namespace import -force ::nx::* -namespace import -force ::nx::doc::* - - -Test parameter count 1 - -# -# some helper -# - -proc lcompare {a b} { - foreach x $a y $b { - if {$a ne $b} { - return -1; break; - } - } - return 1 -} - -Class create ::nx::doc::CommentState::Log { - :method on_enter {line} { - puts -nonewline stderr "ENTER -> [namespace tail [:info class]]#[namespace tail [self]]" - next - } - :method on_exit {line} { - next - puts -nonewline stderr "EXIT -> [namespace tail [:info class]]#[namespace tail [self]]" - } -} - -Class create ::nx::doc::CommentLine::Log { - :method on_enter {line} { - puts -nonewline stderr "\t"; next; puts stderr " -> LINE = ${:processed_line}" - } - :method on_exit {line} { - puts -nonewline stderr "\t"; next; puts stderr " -> LINE = ${:processed_line}" - } -} - -Class create ::nx::doc::CommentSection::Log { - :method on_enter {line} { - next; puts -nonewline stderr "\n" - } - :method on_exit {line} { - next; puts -nonewline stderr "\n"; - } -} - -set log false - -if {$log} { - ::nx::doc::CommentState mixin add ::nx::doc::CommentState::Log - ::nx::doc::CommentLine mixin add ::nx::doc::CommentLine::Log - ::nx::doc::CommentSection mixin add ::nx::doc::CommentSection::Log -} - -# -- - - -Test case scanning { - - set lines { - "# @package o" 1 - "#@package o" 1 - "bla" 0 - "# @object o" 1 - "# 1 2 3" 1 - "#" 1 - "# " 1 - " # " 1 - "\t#\t \t" 1 - "# 345" 1 - "# @tag1 part1" 1 - "bla; # no comment" 0 - "" 0 - "\t\t" 0 - "### # # # # @object o # ####" 1 - "# # # # # 345" 1 - "# # # @tag1 part1" 1 - "bla; # # # # # no comment" 0 - " " 0 - - } - - foreach {::line ::result} $lines { - ? {foreach {is_comment text} [doc analyze_line $::line] break; set is_comment} $::result "doc analyze_line '$::line'" - } - - set script { - # @package o - # 1 2 3 - bla - bla - # @object o - # 1 2 3 - # - # 345 - # @tag1 part1 - # @tag2 part2 - bla; # no comment - bla - bla - bla - - - ### # # # # @object o # #### - # 1 2 3 - # - # # # # # 345 - # # # @tag1 part1 - # @tag2 part2 - bla; # # # # # no comment - } - - set blocks {1 {{ @package o} { 1 2 3}} 5 {{ @object o} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}} 17 {{ @object o # ####} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}}} - - ? [list ::lcompare [doc comment_blocks $script] $blocks] 1 -} - -Test case parsing { - # - # TODO: Add tests for doc-parsing state machine. - # - set block { - {@command cc} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 - - set block { - {} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - # - # For now, a valid comment block must start with a non-space line - # (i.e., a tag or text line, depending on the section: context - # vs. description) - # - - set block { - {} - {@command cc} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - set block { - {command cc} - {} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - set block { - {@command cc} - {some description} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - set block { - {@command cc} - {} - {} - {} - {@see ::o} - } - EntityClass process $block - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 - - set block { - {@command cc} - {} - {some description} - {some description2} - {} - {} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 - - # Note: We do allow description blocks with intermediate space - # lines, for now. - set block { - {@command cc} - {} - {some description} - {some description2} - {} - {an erroreneous description line, for now} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 - - # - # TODO: Do not enforce space line between the context and imediate - # part block (when description is skipped)? - # - # OR: For absolutely qualifying parts (e.g., outside of an initcmd block), - # do we need sequences of _two_ (or more) tag lines, e.g. - # - # -- - # @object Foo - # @param attr1 - # -- - # - # THEN, we can only discriminate between the context and an - # immediate part section by requiring a space line! - # - # Alternatively, we can use the @see like syntax for qualifying: - # @param ::Foo#attr1 (I have a preference for this option). - set block { - {@command cc} - {@see someOtherEntity} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - # - # TODO: Disallow space lines between parts? Check back with Javadoc spec. - # - set block { - {@command cc} - {} - {@see SomeOtherEntity} - {add a line of description} - {} - {} - {@see SomeOtherEntity2} - {} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 - - # - # TODO: Should we enforce a mandatory space line between description and part block? - # - set block { - {@command cc} - {} - {add a line of description} - {a second line of description} - {a third line of description} - {@see entity3} - {@see SomeOtherEntity2} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - set block { - {@command cc} - {} - {add a line of description} - {a second line of description} - {a third line of description} - {} - {@see SomeOtherEntity2} - {} - {} - {an erroreneous description line, for now} - } - - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 1 - - set block { - {@command cc} - {} - {add a line of description} - {a second line of description} - {} - {a third line of description} - {} - {@see SomeOtherEntity2} - } - ? [list StyleViolation thrown_by? [list EntityClass process $block]] 0 - - set block { - {@object cc} - {} - {add a line of description} - {a second line of description} - {} - {@see SomeOtherEntity2} - {@xyz SomeOtherEntity2} - } - ? [list InvalidTag thrown_by? [list EntityClass process $block]] 1 - - set block { - {@class cc} - {} - {add a line of description} - {a second line of description} - {} - {@see SomeOtherEntity2} - {@xyz SomeOtherEntity2} - } - ? [list InvalidTag thrown_by? [list EntityClass process $block]] 1 - - - - # - # testing the doc object construction - # - set block { - {@object o} - {} - {some more text} - {and another line for the description} - {} - {@author stefan.sobernig@wu.ac.at} - {@author gneumann@wu.ac.at} - } - set entity [EntityClass process $block] - ? [list ::nx::core::is $entity object] 1 - ? [list $entity info is type ::nx::doc::@object] 1 - ? [list $entity @author] "stefan.sobernig@wu.ac.at gneumann@wu.ac.at"; - ? [list $entity text] "some more text and another line for the description"; - - set block { - {@command c} - {} - {some text on the command} - {} - {@see ::o} - } - set entity [EntityClass process $block] - ? [list ::nx::core::is $entity object] 1 - ? [list $entity info is type ::nx::doc::@command] 1 - ? [list $entity text] "some text on the command"; - ? [list $entity @see] "::o"; - - # - # basic test for in-situ documentation (initcmd block) - # - # - - set script { - Class create Foo { - # The class Foo defines the behaviour for all Foo objects - # - # @author gneumann@wu.ac.at - # @author ssoberni@wu.ac.at - - # @param attr1 - # - # This attribute 1 is wonderful - # - # @see ::nx::Attribute - # @see ::nx::MetaSlot - :attribute attr1 - :attribute attr2 - :attribute attr3 - - # @method foo - # - # This describes the foo method - # - # @param a Provides a first value - # @param b Provides a second value - :method foo {a b} {;} - } - } - - eval $script - doc process ::Foo - set entity [@object id ::Foo] - ? [list ::nx::core::is $entity object] 1 - ? [list $entity info is type ::nx::doc::@object] 1 - ? [list $entity text] "The class Foo defines the behaviour for all Foo objects"; - ? [list $entity @author] "gneumann@wu.ac.at ssoberni@wu.ac.at" - # TODO: Fix the [@param id] programming scheme to allow (a) for - # entities to be passed and the (b) documented structures - #set entity [@param id ::Foo class attr1] - set entity [@param id $entity attr1] - ? [list ::nx::core::is $entity object] 1 - ? [list $entity info is type ::nx::doc::@param] 1 - ? [list $entity @see] "::nx::Attribute ::nx::MetaSlot"; - - set entity [@method id ::Foo class foo] - ? [list [@object id ::Foo] @method] $entity - ? [list ::nx::core::is $entity object] 1 - ? [list $entity info is type ::nx::doc::@method] 1 - ? [list $entity text] "This describes the foo method"; - - foreach p [$entity @param] expected { - "Provides a first value" - "Provides a second value" - } { - ? [list expr [list [$p text] eq $expected]] 1; - } - - - # TODO: how to realise scanning and parsing for mixed ex- and - # in-situ documentation? That is, how to differentiate between - # absolutely and relatively qualified comment blocks in line-based - # scanning phase (or later)? - - set script { - namespace import -force ::nx::* - # @object Bar - # - # The class Bar defines the behaviour for all Bar objects - # - # @author gneumann@wu.ac.at - # @author ssoberni@wu.ac.at - - # @param Bar#attr1 - # - # This attribute 1 is wonderful - # - # @see ::nx::Attribute - # @see ::nx::MetaSlot - - # @method Bar#foo - # - # This describes the foo method - # - # @param a Provides a first value - # @param b Provides a second value - - # @object-method Bar#foo - # - # This describes the per-object foo method - # - # @param a Provides a first value - # @param b Provides a second value - - namespace eval ::ns1 { - ::nx::Object create ooo - } - Class create Bar { - - :attribute attr1 - :attribute attr2 - :attribute attr3 - - # @method foo - # - # This describes the foo method in the initcmd - # - # @param a Provides a first value - # @param b Provides a second value - - :method foo {a b} { - # This describes the foo method in the method body - # - # @param a Provides a first value (refined) - - } - - :object method foo {a b c} { - # This describes the per-object foo method in the method body - # - # @param b Provides a second value (refined) - # @param c Provides a third value (first time) - - } - - } - } - - set i [doc process $script] - - set entity [@object id ::Bar] - ? [list $i eval [list ::nx::core::is $entity object]] 1 - ? [list $i eval [list $entity info is type ::nx::doc::@object]] 1 - ? [list $i eval [list $entity text]] "The class Bar defines the behaviour for all Bar objects"; - ? [list $i eval [list $entity @author]] "gneumann@wu.ac.at ssoberni@wu.ac.at" - - # TODO: Fix the [@param id] programming scheme to allow (a) for - # entities to be passed and the (b) documented structures - #set entity [@param id ::Bar class attr1] - set entity [@param id $entity attr1] - ? [list $i eval [list ::nx::core::is $entity object]] 1 - ? [list $i eval [list $entity info is type ::nx::doc::@param]] 1 - ? [list $i eval [list $entity @see]] "::nx::Attribute ::nx::MetaSlot"; - - set entity [@method id ::Bar class foo] - ? [list $i eval [list [@object id ::Bar] @method]] $entity - ? [list $i eval [list ::nx::core::is $entity object]] 1 - ? [list $i eval [list $entity info is type ::nx::doc::@method]] 1 - ? [list $i eval [list $entity text]] "This describes the foo method in the method body"; - - foreach p [$i eval [list $entity @param]] expected { - "Provides a first value (refined)" - "Provides a second value" - } { - ? [list expr [list [$i eval [list $p text]] eq $expected]] 1; - } - set entity [@method id ::Bar object foo] - ? [list $i eval [list [@object id ::Bar] @object-method]] $entity - ? [list $i eval [list ::nx::core::is $entity object]] 1 - ? [list $i eval [list $entity info is type ::nx::doc::@method]] 1 - ? [list $i eval [list $entity text]] "This describes the per-object foo method in the method body"; - - foreach p [$i eval [list $entity @param]] expected { - "Provides a first value" - "Provides a second value (refined)" - "Provides a third value (first time)" - } { - ? [list expr [list [$i eval [list $p text]] eq $expected]] 1; - } - - interp delete $i - puts stderr ================================================= - # - # self documentation - # - if {[catch {set i [doc process nx::doc]} msg]} { - if {[Exception behind? $msg]} { - puts stderr [$msg info class]->[$msg message] - } else { - error $msg - } - } - ? [list $i eval [list ::nx::core::is [@package id nx::doc] object]] 1 - puts stderr [$i eval [list [@package id nx::doc] text]] - puts stderr [$i eval [list [@package id nx::doc] @require]] - set path [file join /tmp nextdoc] - if {[file exists $path]} { - file delete -force $path - } - $i eval [list ::nx::doc::make doc \ - -renderer ::nx::doc::TemplateData \ - -outdir /tmp \ - -project {name nextdoc url http://www.next-scripting.org/ version 0.1d}] - interp delete $i - - # - # core documentation - # - set path [file join /tmp NextLanguageCore] - if {[file exists $path]} { - file delete -force $path - } - - set i [interp create] - $i eval { - package req nx::doc - namespace import ::nx::* - namespace import ::nx::doc::* - doc process -noeval true /Users/ssoberni/Documents/dev/xotcl/generic/gentclAPI.decls - doc process -noeval true /Users/ssoberni/Documents/dev/xotcl/generic/predefined.xotcl - ::nx::doc::make doc \ - -renderer ::nx::doc::TemplateData \ - -outdir /tmp \ - -project {name NextLanguageCore url http://www.next-scripting.org/ version 1.0.0a} - } - interp delete $i -} - - - -# # # # # # # # # # # # # # # # # # # # -# # # # # # # # # # # # # # # # # # # # -# # # # # # # # # # # # # # # # # # # # - -# 1) Test case scoping rules -> in Object->eval() -# Why does [info] intropsection not work as expected in eval()? - -Test case issues? { - Object create o - ? {o eval { - set x ns1 - set ns1 [namespace current] - # - # I would expect that there are x and ns1 as locally-scoped variables, but there aren't?! - # They can be referenced during evaluation, but are NOT resolved through introspection: - # Am I missing anything (probably I just forgot a nitty-gritty - # detail on the eval() implementation)? - expr {[info vars $x] eq $x}; - }} 0 - - o method bar {arg1:object,type=::some::unknown::Class} {;} - ? {o bar ::o} "expected object of type ::some::unknown::Class but got \"::o\" for parameter arg1"; # the error should rather reflect that ::some::unknown::Class is a non-existing class object! - - ? {o info is type ::xyz::Bar} 0; # similarly, [info is] 0 for non-existing class objects! It should rather report the non-existance of a valid class object, as otherwise, the introspective act is misleading - - ? {o autoname -reset a} ""; # why does autoname with -reset flag does not return anything, e.g., "a1" here; "name", though required, does not make any sense there. why not return a result after resetting? - - # TODO: is [autoname -instance] really needed? - - # TODO: why is XOTclNextObjCmd/::nx::core::next not in gentclAPI.decls? - - # TODO: where to locate the @ comments (in predefined.xotcl, in - # gentclAPI.decls)? how to deal with ::nx::core::* vs. ::nx::* - - # TODO: which values are returned from Object->configure() and - # passed to init()? how to document residualargs()? - - # TODO: Object->cleanup() said: "Resets an object or class into an - # initial state, as after construction." If by construction it means - # after create(), then cleanup() is missing a configure() call to - # set defaults, etc! - - # TODO: exists and bestandteil von info() oder selbstständig? - # ausserdem: erlauben von :-präfix?! - - # TODO: should we keep a instvar variant (i support this!) - - # TODO: verify the use of filtersearch()? should it return a method - # handle and the filter name? how to deal with it when refactoring - # procsearch()? - - # TODO: mixinguard doc is missing in old doc - - # TODO: what is Object->__next() for? - - # TODO: what to do with hasNamespace()? [Object info is namespace]? - - # TODO: why is XOTclOUplevelMethodStub/XOTclOUplevelMethod defined - # with "args" while it logically uses the stipulated parameter - # signature (level ...). is this because of the first pos, optional - # parameter? ... same goes for upvar() ... - - # TODO: is Object->uplevel still needed with an integrated cs management? - - # TODO: how is upvar affected by the ":"-prefixing? -> AVOID_RESOLVERS ... - - # TODO: do all member-creating operations return valid, canonical handles! - - # TODO: the objectsystems subcommand of ::nx::core::configure does - # not really fit in there because it does not allow for configuring - # anything. it is a mere introspection-only command. relocate (can - # we extend standard [info] somehow, i.e., [info objectsystems] - - # TODO: extend [info level] & [info frame]! - - # TODO: there is still --noArgs on [next], which does not correspond - # to single-dashed flags used elsewhere. Why? - - # TODO: renaming of self to current? - - # TODO: is [self callingclass] == [[self callingobject] info class]? - - # TODO: "# @subcommand next Returns the name of the method next on - # the precedence path as a string" shouldn't these kinds of - # introspective commands return method handles (in the sense of - # alias)? Retrieving the name from a handle is the more specific - # operation (less generic). ... same for "filterreg" - -} - -if {$log} { - ::nx::doc::CommentState mixin delete ::nx::doc::CommentState::Log - ::nx::doc::CommentLine mixin delete ::nx::doc::CommentLine::Log - ::nx::doc::CommentSection mixin delete ::nx::doc::CommentSection::Log -}