Index: Makefile.in =================================================================== diff -u -r2fcc2f0db81ba75af31e0578ca240be8fbb0a801 -ra6087540279fa5a9110728605795620ecd43e10e --- Makefile.in (.../Makefile.in) (revision 2fcc2f0db81ba75af31e0578ca240be8fbb0a801) +++ Makefile.in (.../Makefile.in) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -346,6 +346,8 @@ -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/destroytest.xotcl \ -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/protected.xotcl \ + -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/testx.xotcl \ -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/testo.xotcl \ Index: doc/index.html =================================================================== diff -u -r0440393b42137e1b1cac3393d799b8f2fbad0004 -ra6087540279fa5a9110728605795620ecd43e10e --- doc/index.html (.../index.html) (revision 0440393b42137e1b1cac3393d799b8f2fbad0004) +++ doc/index.html (.../index.html) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -23,7 +23,7 @@

Index: generic/xotcl.h =================================================================== diff -u -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 -ra6087540279fa5a9110728605795620ecd43e10e --- generic/xotcl.h (.../xotcl.h) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) +++ generic/xotcl.h (.../xotcl.h) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -40,6 +40,7 @@ # endif #endif + /* activate bytecode support #define XOTCL_BYTECODE */ @@ -50,7 +51,6 @@ */ /* activate/deacticate assert - #define NDEBUG 1 */ #define NDEBUG 1 Index: library/lib/htmllib.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -ra6087540279fa5a9110728605795620ecd43e10e --- library/lib/htmllib.xotcl (.../htmllib.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ library/lib/htmllib.xotcl (.../htmllib.xotcl) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -58,7 +58,7 @@ # the compressed parameter means that minimal HTML page are created # i.e. that space indentation is turned off # - Class HtmlBuilder -parameter { + Class create HtmlBuilder -parameter { {compressed 0} } Index: library/lib/metadataAnalyzer.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -ra6087540279fa5a9110728605795620ecd43e10e --- library/lib/metadataAnalyzer.xotcl (.../metadataAnalyzer.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ library/lib/metadataAnalyzer.xotcl (.../metadataAnalyzer.xotcl) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -60,7 +60,7 @@ } } - Class MetadataToken -parameter { + Class create MetadataToken -parameter { {name ""} {properties ""} } @@ -126,7 +126,7 @@ Token for @File Metadata. } } - Class FileToken -superclass MetadataToken + Class create FileToken -superclass MetadataToken FileToken instproc print {} { set c "FILE=[my set name]\n" append c [my printProperties] @@ -138,7 +138,7 @@ Token for @Constraint Metadata. } } - Class ConstraintToken -superclass MetadataToken + Class create ConstraintToken -superclass MetadataToken ConstraintToken instproc print {} { set c "CONSTRAINT=[my set name]\n" append c [my printProperties] @@ -152,7 +152,7 @@ } } - Class PackageToken -superclass MetadataToken -parameter { + Class create PackageToken -superclass MetadataToken -parameter { {version ""} {type ""} } @@ -163,7 +163,7 @@ "procList" = list of all proc token and "cl"= class name. } } - Class ObjToken -superclass MetadataToken -parameter { + Class create ObjToken -superclass MetadataToken -parameter { {procList ""} cl } @@ -203,7 +203,7 @@ "instprocList" = list of all instproc token. } } - Class ClassToken -superclass ObjToken -parameter { + Class create ClassToken -superclass ObjToken -parameter { {instprocList ""} } ClassToken instproc print {} { @@ -216,7 +216,7 @@ Token for Meta-Class metadata. } } - Class MetaClassToken -superclass ClassToken + Class create MetaClassToken -superclass ClassToken MetaClassToken instproc print {} { regsub "^CLASS=" [next] "META-CLASS=" r return $r @@ -229,7 +229,7 @@ "obj" name, "abstract" = 0 or 1 (whether its an abstract method or not). } } - Class MethodToken -superclass MetadataToken -parameter { + Class create MethodToken -superclass MetadataToken -parameter { arguments returnValue obj @@ -256,7 +256,7 @@ Token for Proc metadata } } - Class ProcToken -superclass MethodToken + Class create ProcToken -superclass MethodToken ProcToken instproc print {} { regsub "^ METHOD=" [next] " PROC=" r return $r @@ -267,7 +267,7 @@ Token for Instproc metadata. } } - Class InstprocToken -superclass MethodToken + Class create InstprocToken -superclass MethodToken InstprocToken instproc print {} { regsub "^ METHOD=" [next] " INSTPROC=" r return $r @@ -277,7 +277,7 @@ description "Handler class for building a metadata runtime structure" } - Class MetadataAnalyzer -parameter { + Class create MetadataAnalyzer -parameter { {objList ""} {packageList ""} {knownMetaclasses "Class"} @@ -446,7 +446,7 @@ @ Class AnalyzerCmd { description {Class that overload the unknown mechanism of @ to provide metadata analysis.} } - Class AnalyzerCmd -parameter { + Class create AnalyzerCmd -parameter { {analyzerObj ""} {onOff 0} } @@ -492,7 +492,7 @@ @ AnalyzerCmd @ { description {Recreate @ with metadata analyis funtionality.} } - AnalyzerCmd @ + AnalyzerCmd create @ namespace export \ MetadataToken FileToken ConstraintToken PackageToken ObjToken \ Index: library/lib/package.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -ra6087540279fa5a9110728605795620ecd43e10e --- library/lib/package.xotcl (.../package.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ library/lib/package.xotcl (.../package.xotcl) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -33,7 +33,7 @@ } } - Object package + Object create package package set component . package set verbose 0 package proc unknown args { @@ -82,7 +82,7 @@ return $v } - Object package::tracker + Object create package::tracker package::tracker set verbose 0 package::tracker proc storeEntry {table index} { my instvar verbose $table @@ -103,7 +103,7 @@ ::Object add mixin [self]::M } - Class package::tracker::M + Class create package::tracker::M package::tracker::M instproc create {cls args} { set table [string tolower [string trimleft [self] :]] package::tracker storeEntry $table [lindex $args 0] Index: library/lib/staticMetadata.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -ra6087540279fa5a9110728605795620ecd43e10e --- library/lib/staticMetadata.xotcl (.../staticMetadata.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ library/lib/staticMetadata.xotcl (.../staticMetadata.xotcl) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -20,7 +20,7 @@ } } - Class StaticMetadataAnalyzer -superclass MetadataAnalyzer \ + Class create StaticMetadataAnalyzer -superclass MetadataAnalyzer \ -parameter {{namespace ::}} StaticMetadataAnalyzer instproc cmdsplit {cmd} { # from Jeffrey's tkcon Index: library/lib/xodoc.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -ra6087540279fa5a9110728605795620ecd43e10e --- library/lib/xodoc.xotcl (.../xodoc.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ library/lib/xodoc.xotcl (.../xodoc.xotcl) (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -21,7 +21,7 @@ are registered for all token types. } } - Class MetadataTokenHTML + Class create MetadataTokenHTML @ MetadataTokenHTML abstract instproc printHTML {} { description {Print token to HTML document object} } @@ -72,7 +72,7 @@ MetadataToken instmixin [concat [MetadataToken info instmixin] MetadataTokenHTML] @ Class FileTokenHTML -superclass MetadataTokenHTML - Class FileTokenHTML -superclass MetadataTokenHTML + Class create FileTokenHTML -superclass MetadataTokenHTML FileTokenHTML instproc printHTML {htmlDoc} { $htmlDoc addLineBreak $htmlDoc addString " Filename: " @@ -87,7 +87,7 @@ FileToken instmixin [concat [FileToken info instmixin] FileTokenHTML] @ Class ConstraintTokenHTML -superclass MetadataTokenHTML - Class ConstraintTokenHTML -superclass MetadataTokenHTML + Class create ConstraintTokenHTML -superclass MetadataTokenHTML ConstraintTokenHTML instproc printHTML {htmlDoc} { $htmlDoc addAnchor "" -name [my set name] $htmlDoc addString "

Constraint: [my set name]

" @@ -100,7 +100,7 @@ ConstraintToken instmixin [concat [ConstraintToken info instmixin] ConstraintTokenHTML] @ Class ObjTokenHTML -superclass MetadataTokenHTML - Class ObjTokenHTML -superclass MetadataTokenHTML + Class create ObjTokenHTML -superclass MetadataTokenHTML ObjTokenHTML instproc getProcsHTML {htmlDoc} { set c "" set pl [MetadataToken sortTokenList [my procList]] @@ -154,14 +154,14 @@ ObjToken instmixin [concat [ObjToken info instmixin] ObjTokenHTML] @ Class MethodTokenHTML -superclass MetadataTokenHTML - Class MethodTokenHTML -superclass MetadataTokenHTML + Class create MethodTokenHTML -superclass MetadataTokenHTML # Prints out method information as HTML. MethodTokenHTML instproc printHTML {htmlDoc} { #my showVars set argText "\n" - HtmlBuilder args + HtmlBuilder create args set a "Arguments:" @@ -211,7 +211,7 @@ @ Class XODoc { description "Handler class for building a documentation database" } - Class XODoc -superclass StaticMetadataAnalyzer + Class create XODoc -superclass StaticMetadataAnalyzer @ XODoc proc documentFileAsHTML { file "filename of the xotcl file to be documented" @@ -224,7 +224,7 @@ } XODoc proc documentFileAsHTML {file docdir} { - set docdb [XODoc [XODoc autoname docdb]] + set docdb [XODoc create [XODoc autoname docdb]] ::@ set analyzerObj $docdb $docdb analyzeFile $file set ext [file extension $file] @@ -361,7 +361,7 @@ description "Create HTML documentation object from metadata token" } XODoc instproc printHTML {name} { - HtmlBuilder htmlDoc + HtmlBuilder create htmlDoc htmlDoc startDocument -title "XOTcl - Documentation -- $name" \ -bgcolor FFFFFF -stylesheet xotcl-doc.css htmlDoc addStringIncr "

" Index: tests/protected.xotcl =================================================================== diff -u --- tests/protected.xotcl (revision 0) +++ tests/protected.xotcl (revision a6087540279fa5a9110728605795620ecd43e10e) @@ -0,0 +1,108 @@ +package require XOTcl; namespace import ::xotcl::* +package require xotcl::test + +set count 1 +proc ? {cmd expected {msg ""}} { + if {$msg ne ""} { + set t [Test new -cmd $cmd -count $::count -msg $msg] + } else { + set t [Test new -cmd $cmd -count $::count] + } + $t expected $expected + $t run +} + +Class create C +::xotcl::alias C SET ::set +C method foo {} {return [self proc]} +C method bar {} {return [self proc]} +C method bar-foo {} { + c1 foo +} +C method bar-SET {} { + c1 SET x 1 +} + +C create c1 +C create c2 + +? {c1 SET x 1} {1} +? {c1 foo} {foo} +? {c1 bar-SET} {1} +? {c1 bar-foo} {foo} + +::xotcl::methodproperty C SET protected true +? {catch {c1 SET x 1} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {::xotcl::dispatch c1 SET x 2} {2} "dispatch of protected methods works" +? {c1 foo} {foo} +? {c1 bar} {bar} +? {c1 bar-SET} {1} +? {c1 bar-foo} {foo} +? {catch {c2 bar-SET} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {c2 bar-foo} {foo} + +::xotcl::methodproperty C foo protected true +? {catch {c1 SET x 1} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {::xotcl::dispatch c1 SET x 2} {2} "dispatch of protected methods works" +? {c1 bar} {bar} "other method work" +? {catch {c1 foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} +? {c1 bar-SET} {1} "internal call of protected C implementend method" +? {c1 bar-foo} {foo} "internal call of protected Tcl implemented method" +? {catch {c2 bar-SET} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {catch {c2 bar-foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} + +# unset protected +? {::xotcl::methodproperty C SET protected} 1 +::xotcl::methodproperty C SET protected false +? {::xotcl::methodproperty C SET protected} 0 +? {::xotcl::methodproperty C foo protected} 1 +::xotcl::methodproperty C foo protected false +? {::xotcl::methodproperty C foo protected} 0 + +? {c1 SET x 3} 3 +? {::xotcl::dispatch c1 SET x 2} {2} +? {c1 foo} {foo} +? {c1 bar} {bar} +? {c1 bar-SET} {1} +? {c1 bar-foo} {foo} +? {c2 bar-SET} 1 +? {c2 bar-foo} {foo} + +# define a protected method +C method -protected foo {} {return [self proc]} +? {::xotcl::methodproperty C SET protected} 0 +? {c1 SET x 3} 3 +? {::xotcl::dispatch c1 SET x 4} {4} +? {catch {c1 foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} +? {c1 bar} {bar} +? {c1 bar-SET} {1} +? {c1 bar-foo} foo +? {c2 bar-SET} 1 +? {catch {c2 bar-foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} + +? {::xotcl::methodproperty C SET static true} 1 +? {catch {C method SET {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} +? {::xotcl::methodproperty C foo static true} 1 +? {catch {C method foo {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'foo' of ::C can not be overwritten. Derive e.g. a sub-class!} +# check a predefined protection +? {catch {::xotcl::Class method dealloc {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'dealloc' of ::xotcl::Class can not be overwritten. Derive e.g. a sub-class!} +# try to redefined via alias +? {catch {::xotcl::alias Class dealloc ::set} errorMsg; set errorMsg} \ + {Method 'dealloc' of ::xotcl::Class can not be overwritten. Derive e.g. a sub-class!} +# try to redefine via forward +? {catch {C instforward SET ::set} errorMsg; set errorMsg} \ + {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} +# try to redefine via forward +? {catch {C instparametercmd SET} errorMsg; set errorMsg} \ + {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} + +# overwrite-protect object specific method +Object create o +o method foo {} {return 13} +::xotcl::methodproperty o foo static true +? {catch {o method foo {} {return 14}} errorMsg; set errorMsg} \ + {Method 'foo' of ::o can not be overwritten. Derive e.g. a sub-class!} +