Index: Makefile.in =================================================================== diff -u -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 -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 -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 --- 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 "" + + Fisheye: Tag 8aaec98df564488dc8540cd078d6a32dd55a08f7 refers to a dead (removed) revision in file `generic/mk_predefined.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: generic/nxDecls.h =================================================================== diff -u -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 -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 --- 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]}]" +#} Fisheye: Tag 8aaec98df564488dc8540cd078d6a32dd55a08f7 refers to a dead (removed) revision in file `generic/predefined.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: generic/tclAPI.h =================================================================== diff -u -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 -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 -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 -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 --- 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 Fisheye: Tag 8aaec98df564488dc8540cd078d6a32dd55a08f7 refers to a dead (removed) revision in file `library/lib/doc-tools.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: library/lib/pkgIndex.tcl =================================================================== diff -u -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 --- 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 +} Fisheye: Tag 8aaec98df564488dc8540cd078d6a32dd55a08f7 refers to a dead (removed) revision in file `tests/doc.xotcl'. Fisheye: No comparison available. Pass `N' to diff?