123 changed files with 18437 additions and 5517 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,35 @@ |
|||||||
|
package require tcltest |
||||||
|
|
||||||
|
namespace eval ::testspace { |
||||||
|
namespace import ::tcltest::* |
||||||
|
variable common { |
||||||
|
set result "" |
||||||
|
} |
||||||
|
|
||||||
|
test renderline_basic_noansi {basic renderline calls with no ansi in underlay or overlay}\ |
||||||
|
-setup $common -body { |
||||||
|
set undertext "abcdefghij" |
||||||
|
|
||||||
|
#there must be no ansi codes in the output (e.g no resets introduced by renderline)) |
||||||
|
|
||||||
|
set editedline [overtype::renderline -insert_mode 0 $undertext ABCDE] |
||||||
|
#set lineview [ansistring VIEW $editedline] |
||||||
|
lappend result $editedline |
||||||
|
|
||||||
|
set editedline [overtype::renderline -insert_mode 1 $undertext ABCDE] |
||||||
|
lappend result $editedline |
||||||
|
|
||||||
|
}\ |
||||||
|
-cleanup { |
||||||
|
}\ |
||||||
|
-result [list\ |
||||||
|
ABCDEfghij ABCDEabcde |
||||||
|
] |
||||||
|
|
||||||
|
#todo - test |
||||||
|
#P% overtype::left -transparent 1 [textblock::block 10 2 -] " [a+ underline yellow].\n [a+ underline yellow]yyy" |
||||||
|
#- --.------- |
||||||
|
#- --yyy----- |
||||||
|
#we expect the dot to be yellow and underlined and the yyy to be yellow and underlined - but not the dashes. |
||||||
|
|
||||||
|
} |
||||||
@ -0,0 +1,139 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2025 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application test::overtype 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
|
||||||
|
tcl::namespace::eval test::overtype { |
||||||
|
variable PUNKARGS |
||||||
|
variable pkg test::overtype |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
|
||||||
|
package require packagetest |
||||||
|
packagetest::makeAPI test::overtype $version overtype; #will package provide test::overtype $version |
||||||
|
package forget overtype |
||||||
|
package require overtype |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
# Sample 'about' function with punk::args documentation |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
tcl::namespace::eval test::overtype { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
variable PUNKARGS |
||||||
|
variable PUNKARGS_aliases |
||||||
|
|
||||||
|
lappend PUNKARGS [list { |
||||||
|
@id -id "(package)test::overtype" |
||||||
|
@package -name "test::overtype" -help\ |
||||||
|
"Test suites for overtype module" |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval argdoc { |
||||||
|
#namespace for custom argument documentation |
||||||
|
proc package_name {} { |
||||||
|
return test::overtype |
||||||
|
} |
||||||
|
proc about_topics {} { |
||||||
|
#info commands results are returned in an arbitrary order (like array keys) |
||||||
|
set topic_funs [info commands [namespace current]::get_topic_*] |
||||||
|
set about_topics [list] |
||||||
|
foreach f $topic_funs { |
||||||
|
set tail [namespace tail $f] |
||||||
|
lappend about_topics [string range $tail [string length get_topic_] end] |
||||||
|
} |
||||||
|
#Adjust this function or 'default_topics' if a different order is required |
||||||
|
return [lsort $about_topics] |
||||||
|
} |
||||||
|
proc default_topics {} {return [list Description *]} |
||||||
|
|
||||||
|
# ------------------------------------------------------------- |
||||||
|
# get_topic_ functions add more to auto-include in about topics |
||||||
|
# ------------------------------------------------------------- |
||||||
|
proc get_topic_Description {} { |
||||||
|
punk::args::lib::tstr [string trim { |
||||||
|
package test::overtype |
||||||
|
test suite for overtype module |
||||||
|
} \n] |
||||||
|
} |
||||||
|
proc get_topic_License {} { |
||||||
|
return "MIT" |
||||||
|
} |
||||||
|
proc get_topic_Version {} { |
||||||
|
return "$::test::overtype::version" |
||||||
|
} |
||||||
|
proc get_topic_Contributors {} { |
||||||
|
set authors {{<julian@precisium.com> Julian Noble}} |
||||||
|
set contributors "" |
||||||
|
foreach a $authors { |
||||||
|
append contributors $a \n |
||||||
|
} |
||||||
|
if {[string index $contributors end] eq "\n"} { |
||||||
|
set contributors [string range $contributors 0 end-1] |
||||||
|
} |
||||||
|
return $contributors |
||||||
|
} |
||||||
|
proc get_topic_custom-topic {} { |
||||||
|
punk::args::lib::tstr -return string { |
||||||
|
A custom |
||||||
|
topic |
||||||
|
etc |
||||||
|
} |
||||||
|
} |
||||||
|
# ------------------------------------------------------------- |
||||||
|
} |
||||||
|
|
||||||
|
# we re-use the argument definition from punk::args::standard_about and override some items |
||||||
|
set overrides [dict create] |
||||||
|
dict set overrides @id -id "::test::overtype::about" |
||||||
|
dict set overrides @cmd -name "test::overtype::about" |
||||||
|
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||||
|
About test::overtype module |
||||||
|
}] \n] |
||||||
|
dict set overrides topic -choices [list {*}[test::overtype::argdoc::about_topics] *] |
||||||
|
dict set overrides topic -choicerestricted 1 |
||||||
|
dict set overrides topic -default [test::overtype::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||||
|
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||||
|
lappend PUNKARGS [list $newdef] |
||||||
|
proc about {args} { |
||||||
|
package require punk::args |
||||||
|
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||||
|
set argd [punk::args::parse $args withid ::test::overtype::about] |
||||||
|
lassign [dict values $argd] _leaders opts values _received |
||||||
|
punk::args::package::standard_about -package_about_namespace ::test::overtype::argdoc {*}$opts {*}[dict get $values topic] |
||||||
|
} |
||||||
|
} |
||||||
|
# end of sample 'about' function |
||||||
|
# == === === === === === === === === === === === === === === |
||||||
|
|
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
# variable PUNKARGS |
||||||
|
# variable PUNKARGS_aliases |
||||||
|
namespace eval ::punk::args::register { |
||||||
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||||
|
lappend ::punk::args::register::NAMESPACES ::test::overtype |
||||||
|
} |
||||||
|
# ----------------------------------------------------------------------------- |
||||||
|
|
||||||
|
package provide test::overtype [tcl::namespace::eval test::overtype { |
||||||
|
variable pkg test::overtype |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
## Ready |
||||||
|
return |
||||||
@ -0,0 +1,3 @@ |
|||||||
|
1.7.4 |
||||||
|
#First line must be a tcl package version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,57 @@ |
|||||||
|
package require tcltest |
||||||
|
|
||||||
|
namespace eval ::testspace { |
||||||
|
namespace import ::tcltest::* |
||||||
|
variable common { |
||||||
|
set result "" |
||||||
|
} |
||||||
|
|
||||||
|
test linelist_default_trimming {}\ |
||||||
|
-setup $common -body { |
||||||
|
#default -block is {trimhead1 trimtail1} which should trim 1 line from head and tail if they are empty. |
||||||
|
lappend result [punk::lib::linelist "line1\nline2\nline3"] ;# -> {line1 line2 line3} |
||||||
|
lappend result [punk::lib::linelist "\nline1\nline2\nline3\n"] ;# -> {line1 line2 line3} |
||||||
|
lappend result [punk::lib::linelist "\n\nline1\nline2\nline3\n\n"] ;# -> {{} line1 line2 line3 {}} |
||||||
|
lappend result [punk::lib::linelist "\n\nline1\nline2\nline3\n\n\n"] ;# -> {{} line1 line2 line3 {} {}} |
||||||
|
lappend result [punk::lib::linelist "\n\nline1\nline2\nline3\n"] ;# -> {{} line1 line2 line3} |
||||||
|
#make sure only head and tail are trimmed, not inner empty lines. |
||||||
|
lappend result [punk::lib::linelist "\nline1\n\nline2\n\n\nline3\n"] ;# -> {line1 {} line2 {} {} line3} |
||||||
|
|
||||||
|
|
||||||
|
}\ |
||||||
|
-cleanup { |
||||||
|
}\ |
||||||
|
-result [list\ |
||||||
|
{line1 line2 line3} \ |
||||||
|
{line1 line2 line3} \ |
||||||
|
{{} line1 line2 line3 {}} \ |
||||||
|
{{} line1 line2 line3 {} {}} \ |
||||||
|
{{} line1 line2 line3} \ |
||||||
|
{line1 {} line2 {} {} line3} \ |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
test linelist_block_collateempty {}\ |
||||||
|
-setup $common -body { |
||||||
|
#with -block collateempty empty (and without trimhead1 and trimtail1) lines should be collated together into single empty lines. |
||||||
|
lappend result [punk::lib::linelist -block collateempty "line1\nline2\nline3"] ;# -> {line1 line2 line3} |
||||||
|
lappend result [punk::lib::linelist -block collateempty "\nline1\nline2\nline3\n"] ;# -> {{} line1 line2 line3 {}} |
||||||
|
lappend result [punk::lib::linelist -block collateempty "\n\nline1\nline2\nline3\n\n"] ;# -> {{} line1 line2 line3 {}} |
||||||
|
lappend result [punk::lib::linelist -block collateempty "\n\nline1\nline2\nline3\n\n\n"] ;# -> {{} line1 line2 line3 {}} |
||||||
|
lappend result [punk::lib::linelist -block collateempty "\n\nline1\nline2\nline3\n"] ;# -> {{} line1 line2 line3 {}} |
||||||
|
lappend result [punk::lib::linelist -block collateempty "\nline1\n\nline2\n\n\nline3\n"] ;# -> {{} line1 line2 line3 {}} |
||||||
|
|
||||||
|
}\ |
||||||
|
-cleanup { |
||||||
|
}\ |
||||||
|
-result [list\ |
||||||
|
{line1 line2 line3} \ |
||||||
|
{{} line1 line2 line3 {}} \ |
||||||
|
{{} line1 line2 line3 {}} \ |
||||||
|
{{} line1 line2 line3 {}} \ |
||||||
|
{{} line1 line2 line3 {}} \ |
||||||
|
{{} line1 line2 line3 {}} |
||||||
|
] |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,764 @@ |
|||||||
|
namespace eval voo { |
||||||
|
# package version |
||||||
|
variable version 1.0.0 |
||||||
|
variable handlerToObjectMap {} |
||||||
|
variable handlerCounter 0 |
||||||
|
|
||||||
|
|
||||||
|
##\brief Check if a namespace is a valid voo class |
||||||
|
# \param[in] namespaceName the namespace to check |
||||||
|
# \return 1 if valid voo class, 0 otherwise |
||||||
|
proc isVooClass {namespaceName} { |
||||||
|
if {![uplevel [list namespace exists $namespaceName]]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
return [expr {[uplevel [list namespace eval $namespaceName { |
||||||
|
info exists __defaultObj |
||||||
|
}]]}] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a new voo class namespace and process its class body |
||||||
|
# \param[in] args Arguments for class declaration: <className> <body> and optional -extends parent |
||||||
|
# \note Creates the class namespace, imports parent fields/methods when using -extends, |
||||||
|
# and registers constructors and exports |
||||||
|
proc class {args} { |
||||||
|
set optDict {} |
||||||
|
set defaultArgs {} |
||||||
|
set numArgs [llength $args] |
||||||
|
for {set i 0} {$i < $numArgs} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {$arg eq "-extends"} { |
||||||
|
if {$i + 1 >= $numArgs} { |
||||||
|
error "Constructor option ’$arg’ requires an argument" |
||||||
|
} |
||||||
|
dict set optDict $arg [lindex $args [incr i]] |
||||||
|
} elseif {$arg eq "-virtual" || $arg eq "-v"} { |
||||||
|
dict set optDict "-virtual" {} |
||||||
|
} else { |
||||||
|
lappend defaultArgs $arg |
||||||
|
} |
||||||
|
} |
||||||
|
lassign $defaultArgs className body |
||||||
|
set vooNs [namespace current] |
||||||
|
# create the namespace for the class |
||||||
|
uplevel [list namespace eval $className [subst -nocommands { |
||||||
|
namespace path [list $vooNs] |
||||||
|
variable __defaultObj {} |
||||||
|
variable __fields {} |
||||||
|
variable __tmp_isPublicEnabled 1 |
||||||
|
}]] |
||||||
|
|
||||||
|
uplevel [list namespace eval $className { |
||||||
|
##\brief Access default object for this class |
||||||
|
# \return Default class instance (list) |
||||||
|
# \note Used for inheritance and constructor defaults |
||||||
|
proc class.defaultObj {} { |
||||||
|
variable __defaultObj |
||||||
|
return $__defaultObj |
||||||
|
} |
||||||
|
##\brief Get list of field names for this class |
||||||
|
# \return List of field names in declaration order |
||||||
|
# \note Useful for introspection and constructor -name new.args |
||||||
|
proc class.fields {} { |
||||||
|
variable __fields |
||||||
|
return $__fields |
||||||
|
} |
||||||
|
}] |
||||||
|
|
||||||
|
if {[dict exists $optDict -virtual] && [dict exists $optDict -extends]} { |
||||||
|
error "voo::class: cannot use -virtual with -extends; child classes inherit virtual automatically from a -virtual parent" |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $optDict -virtual]} { |
||||||
|
set normalizedClassName [uplevel [list namespace eval $className {namespace current}]] |
||||||
|
uplevel [list namespace eval $className [list variable __voo_is_virtual_class 1]] |
||||||
|
uplevel [list namespace eval $className [list variable __voo_class_namespace $normalizedClassName]] |
||||||
|
# Pre-populate __defaultObj with namespace tag at index 0 BEFORE field declarations |
||||||
|
# so that _getClassCurrNumFields returns 1 for the first field declared |
||||||
|
uplevel [list namespace eval $className [list set __defaultObj [list $normalizedClassName]]] |
||||||
|
} |
||||||
|
|
||||||
|
#81 |
||||||
|
# variable __parentClassNamespace {} |
||||||
|
if {[dict exists $optDict -extends]} { |
||||||
|
set parentClassName [dict get $optDict -extends] |
||||||
|
|
||||||
|
if {![uplevel [list namespace exists $parentClassName]]} { |
||||||
|
error "Parent class ’$parentClassName’ does not exist." |
||||||
|
} |
||||||
|
|
||||||
|
# check if parent class exists |
||||||
|
if {![uplevel [list namespace eval $parentClassName {info exists __defaultObj}]]} { |
||||||
|
error "Parent class ’$parentClassName’ is not a valid voo class." |
||||||
|
} |
||||||
|
|
||||||
|
# normalize namespace name of parent class |
||||||
|
set parentClassName [uplevel [list namespace eval $parentClassName { |
||||||
|
namespace current |
||||||
|
}]] |
||||||
|
|
||||||
|
uplevel [list namespace eval $className [subst -nocommands { |
||||||
|
variable __parentClassNamespace $parentClassName |
||||||
|
}]] |
||||||
|
|
||||||
|
# import parent’s default object values |
||||||
|
set parentDefaultObj [${parentClassName}::class.defaultObj] |
||||||
|
uplevel [list namespace eval $className [list set __defaultObj $parentDefaultObj]] |
||||||
|
|
||||||
|
|
||||||
|
# if parent is virtual, update namespace tag at index 0 to child’s namespace |
||||||
|
set parentIsVirtual [uplevel [list namespace eval $parentClassName {info exists __voo_is_virtual_class}]] |
||||||
|
if {$parentIsVirtual} { |
||||||
|
set normalizedChildName [uplevel [list namespace eval $className {namespace current}]] |
||||||
|
uplevel [list namespace eval $className \ |
||||||
|
[list set __defaultObj [lreplace $parentDefaultObj 0 0 $normalizedChildName]]] |
||||||
|
uplevel [list namespace eval $className [list variable __voo_is_virtual_class 1]] |
||||||
|
uplevel [list namespace eval $className [list variable __voo_class_namespace $normalizedChildName]] |
||||||
|
} |
||||||
|
|
||||||
|
# 121 |
||||||
|
# import parent’s field index variables by copying actual index values from parent |
||||||
|
set parentFields [${parentClassName}::class.fields] |
||||||
|
foreach field $parentFields { |
||||||
|
set fieldIdx [uplevel [list namespace eval $parentClassName [list set $field]]] |
||||||
|
uplevel [list namespace eval $className [list variable $field $fieldIdx]] |
||||||
|
uplevel [list namespace eval $className [list lappend __fields $field]] |
||||||
|
} |
||||||
|
|
||||||
|
# import parent’s acessors in child class with namespace import |
||||||
|
uplevel [list namespace eval $className [subst -nocommands { |
||||||
|
namespace import ${parentClassName}::get.* |
||||||
|
namespace import ${parentClassName}::set.* |
||||||
|
namespace import ${parentClassName}::update.* |
||||||
|
}]] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# 136 |
||||||
|
|
||||||
|
uplevel [list namespace eval $className $body] |
||||||
|
|
||||||
|
uplevel [list namespace eval $className { |
||||||
|
if {[info commands new] eq ""} { |
||||||
|
constructor |
||||||
|
} |
||||||
|
if {[info commands new()] eq ""} { |
||||||
|
constructor -noargs [_buildConstructorNoArgsBody] |
||||||
|
} |
||||||
|
if {[info commands new.args] eq ""} { |
||||||
|
constructor -name new.args {args} [_buildConstructorArgsBody] |
||||||
|
} |
||||||
|
}] |
||||||
|
|
||||||
|
|
||||||
|
# 151 |
||||||
|
uplevel [list namespace eval $className { |
||||||
|
# export class methods |
||||||
|
namespace export * |
||||||
|
}] |
||||||
|
|
||||||
|
uplevel [list namespace eval $className { |
||||||
|
# clean temporary variable |
||||||
|
unset __tmp_isPublicEnabled |
||||||
|
}] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# 161 |
||||||
|
##\brief Return the default value for a given field type |
||||||
|
# \param[in] type the field type token (double,int,bool,...) |
||||||
|
# \return The default value appropriate for the type |
||||||
|
proc _getDefaultValueByType {type} { |
||||||
|
switch -- $type { |
||||||
|
double { return 0.0 } |
||||||
|
int { return 0 } |
||||||
|
bool { return 0 } |
||||||
|
default { return {} } |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Get the current number of fields declared in the current class |
||||||
|
# \return Number of fields (integer) |
||||||
|
proc _getClassCurrNumFields {} { |
||||||
|
return [uplevel 2 {llength $__defaultObj}] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Check whether public mode is enabled during class body parsing |
||||||
|
# \return 1 if public mode is enabled, 0 otherwise |
||||||
|
proc _getClassIsPublicEnabled {} { |
||||||
|
return [uplevel 2 {set __tmp_isPublicEnabled}] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare getter/setter/updater accessors for a class field |
||||||
|
# \param[in] fieldName name of the field |
||||||
|
# \param[in] isPublic boolean whether accessors are public |
||||||
|
# \param[in] isStatic boolean whether field is static (class-level) |
||||||
|
proc _declareFieldAcessors {fieldName isPublic isStatic} { |
||||||
|
set prefix {} |
||||||
|
|
||||||
|
if {$isStatic} { |
||||||
|
append prefix class. |
||||||
|
} |
||||||
|
if {!$isPublic} { |
||||||
|
append prefix my. |
||||||
|
} |
||||||
|
set getterName "${prefix}get.$fieldName" |
||||||
|
set setterName "${prefix}set.$fieldName" |
||||||
|
set updaterName "${prefix}update.$fieldName" |
||||||
|
if {$isStatic} { |
||||||
|
uplevel 2 [list proc $getterName {} [subst -nocommands { |
||||||
|
variable $fieldName |
||||||
|
return $$fieldName |
||||||
|
}]] |
||||||
|
uplevel 2 [list proc $setterName {value} [subst -nocommands { |
||||||
|
variable $fieldName |
||||||
|
set $fieldName "\$value" |
||||||
|
}]] |
||||||
|
|
||||||
|
uplevel 2 [list proc $updaterName {tempVar body} [subst -nocommands { |
||||||
|
variable $fieldName |
||||||
|
upvar "\$tempVar" temp |
||||||
|
set temp $$fieldName |
||||||
|
# break link with class variable to avoid copy-on-write |
||||||
|
set $fieldName {} |
||||||
|
try { |
||||||
|
uplevel \$body |
||||||
|
} finally { |
||||||
|
set $fieldName "\$temp" |
||||||
|
} |
||||||
|
}]] |
||||||
|
|
||||||
|
} else { |
||||||
|
uplevel 2 [list getter $getterName $fieldName] |
||||||
|
uplevel 2 [list setter $setterName $fieldName] |
||||||
|
uplevel 2 [list updater $updaterName $fieldName] |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Validate a field name for illegal characters |
||||||
|
# \param[in] fieldName the field name to validate |
||||||
|
# \return Raises an error if invalid |
||||||
|
proc _validateFieldName {fieldName} { |
||||||
|
if {[string first "." $fieldName] != -1 || [string first "::" $fieldName] != -1} { |
||||||
|
error "Field name ’$fieldName’ cannot contain ’.’ or ’::’ substrings." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Ensure a field name does not already exist in the class |
||||||
|
# \param[in] fieldName the field name to check |
||||||
|
# \return Raises an error if the field already exists |
||||||
|
# \note Uses __fields for instance fields and fully-qualified namespace lookup for static |
||||||
|
# fields to avoid false positives from global variables with the same name |
||||||
|
proc _validateFieldDoesNotExist {fieldName} { |
||||||
|
# Check instance fields tracked in __fields (class-scoped, no global bleed) |
||||||
|
if {$fieldName in [uplevel 2 {set __fields}]} { |
||||||
|
error "Field name ’$fieldName’ already exists in the class." |
||||||
|
} |
||||||
|
# Check static fields via fully-qualified namespace variable; info exists ::Ns::var |
||||||
|
# only matches that exact namespace variable, never a same-named global |
||||||
|
set classNs [uplevel 2 {namespace current}] |
||||||
|
if {[info exists ${classNs}::$fieldName]} { |
||||||
|
error "Field name ’$fieldName’ already exists in the class." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Validate a variable initial value according to its declared type |
||||||
|
# \param[in] type the declared type (double,int,bool,list,dict) |
||||||
|
# \param[in] value the value to validate |
||||||
|
# \return Raises an error if the value does not match the type |
||||||
|
proc _validateVarValueByType {type value} { |
||||||
|
switch -- $type { |
||||||
|
double { |
||||||
|
if {[string is double -strict $value] == 0} { |
||||||
|
error "Value for t_double must be a double, got ’$value’" |
||||||
|
} |
||||||
|
} |
||||||
|
int { |
||||||
|
if {[string is integer -strict $value] == 0} { |
||||||
|
error "Value for t_int must be an integer, got ’$value’" |
||||||
|
} |
||||||
|
} |
||||||
|
bool { |
||||||
|
if {[string is boolean -strict $value] == 0} { |
||||||
|
error "Value for t_bool must be a boolean, got ’$value’" |
||||||
|
} |
||||||
|
} |
||||||
|
list { |
||||||
|
if {[catch {llength $value}]} { |
||||||
|
error "Value for t_list must be a list, got ’$value’" |
||||||
|
} |
||||||
|
} |
||||||
|
dict { |
||||||
|
if {[catch {dict size $value}]} { |
||||||
|
error "Value for t_dict must be a dict, got ’$value’" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a field variable inside the class body |
||||||
|
# \param[in] type the field type token (double,int,string,bool,list,dict,obj) |
||||||
|
# \param[in] argList arguments: ?-static? <name> ?<initialValue>? |
||||||
|
proc _var {type argList} { |
||||||
|
set defaultArgs {} |
||||||
|
set optDict {} |
||||||
|
set numArgs [llength $argList] |
||||||
|
for {set i 0} {$i < $numArgs} {incr i} { |
||||||
|
set arg [lindex $argList $i] |
||||||
|
if {$arg eq "-static"} { |
||||||
|
dict set optDict $arg {} |
||||||
|
} else { |
||||||
|
lappend defaultArgs $arg |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $defaultArgs] == 0} { |
||||||
|
error "Variable definition requires: ?<option>? <name> ?<initialValue>?" |
||||||
|
} |
||||||
|
if {[llength $defaultArgs] == 2} { |
||||||
|
lassign $defaultArgs name initVal |
||||||
|
} else { |
||||||
|
lassign $defaultArgs name |
||||||
|
set initVal [_getDefaultValueByType $type] |
||||||
|
} |
||||||
|
|
||||||
|
_validateFieldName $name |
||||||
|
_validateFieldDoesNotExist $name |
||||||
|
_validateVarValueByType $type $initVal |
||||||
|
if {[dict exists $optDict -static]} { |
||||||
|
# static field |
||||||
|
uplevel [list variable $name $initVal] |
||||||
|
} else { |
||||||
|
set currNumFields [_getClassCurrNumFields] |
||||||
|
uplevel [list variable $name $currNumFields] |
||||||
|
uplevel [list lappend __defaultObj $initVal] |
||||||
|
uplevel [list lappend __fields $name] |
||||||
|
} |
||||||
|
set isPublicEnabled [_getClassIsPublicEnabled] |
||||||
|
_declareFieldAcessors $name $isPublicEnabled [dict exists $optDict -static] |
||||||
|
return |
||||||
|
} |
||||||
|
# 341 |
||||||
|
|
||||||
|
##\brief Declare a double-typed field |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc double_t {args} { |
||||||
|
uplevel [list _var "double" $args] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare an integer-typed field |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc int_t {args} { |
||||||
|
uplevel [list _var "int" $args] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a string-typed field |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc string_t {args} { |
||||||
|
uplevel [list _var "string" $args] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a boolean-typed field |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc bool_t {args} { |
||||||
|
uplevel [list _var "bool" $args] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a list-typed field |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc list_t {args} { |
||||||
|
uplevel [list _var "list" $args] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a dict-typed field |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc dict_t {args} { |
||||||
|
uplevel [list _var "dict" $args] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare an object-typed field (nested vanilla object) |
||||||
|
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||||
|
proc obj_t {args} { |
||||||
|
uplevel [list _var "object" $args] |
||||||
|
} |
||||||
|
|
||||||
|
# 386 |
||||||
|
##\brief Enable public mode for declarations inside the provided body |
||||||
|
# \param[in] body script to execute with public accessors enabled |
||||||
|
# \return Result of executing body |
||||||
|
proc public {body} { |
||||||
|
uplevel $body |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Execute the provided body with private mode enabled (temporarily disables public accessors) |
||||||
|
# \param[in] body script to execute with private accessors |
||||||
|
# \return Result of executing body |
||||||
|
proc private {body} { |
||||||
|
uplevel {variable __tmp_isPublicEnabled 0} |
||||||
|
try { |
||||||
|
uplevel $body |
||||||
|
} finally { |
||||||
|
uplevel {variable __tmp_isPublicEnabled 1} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Build the body for a no-argument constructor |
||||||
|
# \return A script chunk used as constructor body that returns the class default object |
||||||
|
proc _buildConstructorNoArgsBody {} { |
||||||
|
return { |
||||||
|
variable __defaultObj |
||||||
|
return $__defaultObj; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Build the body for a constructor that accepts named args (-field value pairs) |
||||||
|
# \return A script chunk used as constructor body that applies named arguments to the default object |
||||||
|
proc _buildConstructorArgsBody {} { |
||||||
|
return { |
||||||
|
variable __defaultObj |
||||||
|
set obj $__defaultObj |
||||||
|
if {[catch {dict size $args}]} { |
||||||
|
error "Constructor argument must be a list of ’-<field> <value>’ pairs" |
||||||
|
} |
||||||
|
dict for {key value} $args { |
||||||
|
if {[string index $key 0] ne "-"} { |
||||||
|
error "Constructor argument keys must start with ’-’, got ’$key’" |
||||||
|
} |
||||||
|
set field [string range $key 1 end] |
||||||
|
set setter set.$field |
||||||
|
if {[info commands $setter] ne ""} { |
||||||
|
$setter obj $value |
||||||
|
} else { |
||||||
|
set setter my.set.$field |
||||||
|
if {[info commands $setter] ne ""} { |
||||||
|
$setter obj $value |
||||||
|
} else { |
||||||
|
error "Unknown field option: $field" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $obj |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Build constructor parameter list and body for positional constructors |
||||||
|
# \return A list of two elements: argument names list and a body script that returns them as a list |
||||||
|
# \note For virtual classes, the concrete class namespace is embedded as a literal string at |
||||||
|
# class-definition time (not looked up at runtime), producing: |
||||||
|
# return [list ::ClassName $f1 $f2 ...] |
||||||
|
# This avoids all runtime proc calls (class.defaultObj, set.*) and variable lookups, |
||||||
|
# making virtual object creation as cheap as non-virtual. |
||||||
|
proc _buildConstructorParams {} { |
||||||
|
set argList [uplevel 2 {set __fields}] |
||||||
|
set isVirtual [uplevel 2 {info exists __voo_is_virtual_class}] |
||||||
|
set spacedArgVarListStr {} |
||||||
|
foreach arg $argList { |
||||||
|
append spacedArgVarListStr "\$$arg " |
||||||
|
} |
||||||
|
if {$isVirtual} { |
||||||
|
# Read the normalized class namespace at definition time so subst embeds it |
||||||
|
# as a literal in the generated body - no runtime variable lookup required. |
||||||
|
set classNs [uplevel 2 {set __voo_class_namespace}] |
||||||
|
set spacedArgVarListStr "{$classNs} $spacedArgVarListStr" |
||||||
|
set body [subst -nocommands { |
||||||
|
return [list $spacedArgVarListStr] |
||||||
|
}] |
||||||
|
} else { |
||||||
|
set body [subst -nocommands { |
||||||
|
return [list $spacedArgVarListStr] |
||||||
|
}] |
||||||
|
} |
||||||
|
return [list $argList $body] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Define a constructor for the current class |
||||||
|
# \param[in] args Constructor declaration options and body |
||||||
|
# \note Supports -name, -noargs and -typed variants |
||||||
|
proc constructor {args} { |
||||||
|
set defaultArgs {} |
||||||
|
set optDict {} |
||||||
|
set numArgs [llength $args] |
||||||
|
for {set i 0} {$i < $numArgs} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {$arg eq "-name" || $arg eq "-noargs" || $arg eq "-typed"} { |
||||||
|
if {$i + 1 >= $numArgs} { |
||||||
|
error "Constructor option ’$arg’ requires an argument" |
||||||
|
} |
||||||
|
dict set optDict $arg [lindex $args [incr i]] |
||||||
|
} else { |
||||||
|
lappend defaultArgs $arg |
||||||
|
} |
||||||
|
} |
||||||
|
# check valid option combinations |
||||||
|
if {[dict exists $optDict -name]} { |
||||||
|
if {[dict exists $optDict -noargs] || [dict exists $optDict -typed]} { |
||||||
|
error "Constructor cannot have -name option with -noargs or -typed options" |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $optDict -noargs] && [dict exists $optDict -typed]} { |
||||||
|
error "Constructor cannot have both -noargs and -typed options" |
||||||
|
} |
||||||
|
if {[dict exists $optDict -name]} { |
||||||
|
set constructorName [dict get $optDict -name] |
||||||
|
} elseif {[dict exists $optDict -noargs]} { |
||||||
|
set constructorName "new()" |
||||||
|
} elseif {[dict exists $optDict -typed]} { |
||||||
|
set constructorName "new([join [dict get $optDict -typed] ,])" |
||||||
|
} else { |
||||||
|
set constructorName "new" |
||||||
|
} |
||||||
|
if {[dict exists $optDict -noargs]} { |
||||||
|
if {[llength $defaultArgs] != 0} { |
||||||
|
error "Invalid constructor definition, expected ’?...? ?<body>?’ for -noargs" |
||||||
|
} |
||||||
|
set argList {} |
||||||
|
set body [dict get $optDict -noargs] |
||||||
|
} else { |
||||||
|
if {[llength $defaultArgs] == 0} { |
||||||
|
lassign [_buildConstructorParams] argList body |
||||||
|
} else { |
||||||
|
if {[llength $defaultArgs] != 2} { |
||||||
|
error "Invalid constructor definition, expected ’?...? ?<argList> <body>?’" |
||||||
|
} |
||||||
|
lassign $defaultArgs argList body |
||||||
|
} |
||||||
|
} |
||||||
|
uplevel [list proc $constructorName $argList $body] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# 531 |
||||||
|
##\brief Generate a getter procedure for a field |
||||||
|
# \param[in] methodName name of the generated getter (may include namespace prefix) |
||||||
|
# \param[in] fieldName name of the field to read |
||||||
|
proc getter {methodName fieldName} { |
||||||
|
# implementation of getter definition |
||||||
|
set fieldIdx [uplevel [list set $fieldName]] |
||||||
|
uplevel [subst -nocommands { |
||||||
|
##\\brief Getter for $fieldName |
||||||
|
# \\param\[in\] this class instance |
||||||
|
# \\return $fieldName value |
||||||
|
proc $methodName {this} { |
||||||
|
return [lindex \$this $fieldIdx] |
||||||
|
} |
||||||
|
}] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Generate a setter procedure for a field |
||||||
|
# \param[in] methodName name of the generated setter (may include namespace prefix) |
||||||
|
# \param[in] fieldName name of the field to write |
||||||
|
proc setter {methodName fieldName} { |
||||||
|
# implementation of setter definition |
||||||
|
set fieldIdx [uplevel [list set $fieldName]] |
||||||
|
uplevel [subst -nocommands { |
||||||
|
##\\brief Setter for $fieldName |
||||||
|
# \\param\[in\] thisVar name of variable containing class instance |
||||||
|
# \\param\[in\] value new value for $fieldName |
||||||
|
proc $methodName {thisVar value} { |
||||||
|
upvar \$thisVar this |
||||||
|
lset this $fieldIdx \$value |
||||||
|
} |
||||||
|
}] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Generate an updater procedure for a field (copy-on-write safe) |
||||||
|
# \param[in] methodName name of the generated updater (may include namespace prefix) |
||||||
|
# \param[in] fieldName name of the field to update by reference |
||||||
|
# \note The updater detaches the field to avoid unnecessary copying during updates |
||||||
|
proc updater {methodName fieldName} { |
||||||
|
# implementation of updater definition |
||||||
|
set fieldIdx [uplevel [list set $fieldName]] |
||||||
|
uplevel [subst -nocommands { |
||||||
|
##\\brief Update $fieldName by reference |
||||||
|
# \\param\[in\] thisVar name of variable containing class instance |
||||||
|
# \\param\[out\] tempVar name of variable to hold $fieldName during update |
||||||
|
# \\param\[in\] body script to execute with $fieldName in tempVar |
||||||
|
# \\note Avoids copy-on-write by detaching field during update |
||||||
|
proc $methodName {thisVar tempVar body} { |
||||||
|
upvar \$thisVar this |
||||||
|
upvar \$tempVar temp |
||||||
|
set temp [lindex \$this $fieldIdx] |
||||||
|
# break link with object to avoid copy-on-write |
||||||
|
lset this $fieldIdx {} |
||||||
|
try { |
||||||
|
uplevel \$body |
||||||
|
} finally { |
||||||
|
lset this $fieldIdx \$temp |
||||||
|
} |
||||||
|
} |
||||||
|
}] |
||||||
|
} |
||||||
|
|
||||||
|
##\brief Declare a method in the current class namespace |
||||||
|
# \param[in] args Method declaration arguments: name, argList, body and options (-static, -upvar, -update, -override) |
||||||
|
proc method {args} { |
||||||
|
set isPublicEnabled [_getClassIsPublicEnabled] |
||||||
|
set defaultArgs {} |
||||||
|
set optDict {} |
||||||
|
set numArgs [llength $args] |
||||||
|
for {set i 0} {$i < $numArgs} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {$arg eq "-static" || $arg eq "-upvar"} { |
||||||
|
dict set optDict $arg {} |
||||||
|
} elseif {$arg eq "-update"} { |
||||||
|
if {$i + 1 >= $numArgs} { |
||||||
|
error "Method option ’$arg’ requires an argument" |
||||||
|
} |
||||||
|
dict set optDict $arg [lindex $args [incr i]] |
||||||
|
} elseif {$arg eq "-override"} { |
||||||
|
# Explicit override indicator |
||||||
|
dict set optDict $arg {} |
||||||
|
} elseif {$arg eq "-virtual"} { |
||||||
|
dict set optDict $arg {} |
||||||
|
} else { |
||||||
|
lappend defaultArgs $arg |
||||||
|
} |
||||||
|
} |
||||||
|
lassign $defaultArgs name argList body |
||||||
|
|
||||||
|
# check valid option combinations |
||||||
|
if {[dict exists $optDict -static]} { |
||||||
|
if {[dict exists $optDict -upvar] || [dict exists $optDict -update]} { |
||||||
|
error "Method cannot have both -static and -upvar or -update options" |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $optDict -update]} { |
||||||
|
if {![dict exists $optDict -upvar]} { |
||||||
|
# automatically add -upvar if -update is specified |
||||||
|
dict set optDict -upvar {} |
||||||
|
} |
||||||
|
} |
||||||
|
set finalArgList {} |
||||||
|
set finalBody {} |
||||||
|
if {[dict exists $optDict -upvar]} { |
||||||
|
lappend finalArgList "thisVar" |
||||||
|
append finalBody { |
||||||
|
upvar $thisVar this |
||||||
|
} |
||||||
|
} elseif {![dict exists $optDict -static]} { |
||||||
|
lappend finalArgList "this" |
||||||
|
} |
||||||
|
lappend finalArgList {*}$argList |
||||||
|
set className [uplevel {namespace current}] |
||||||
|
if {[dict exists $optDict -update]} { |
||||||
|
set updateFields [dict get $optDict -update] |
||||||
|
if {[llength $updateFields] == 0} { |
||||||
|
error "-update option requires at least one field name" |
||||||
|
} |
||||||
|
foreach field $updateFields { |
||||||
|
try { |
||||||
|
set fieldIdx [uplevel [list set $field]] |
||||||
|
} trap {} {} { |
||||||
|
error "Field ’$field’ specified in -update option does not exist in class ’$className’" |
||||||
|
} |
||||||
|
append finalBody [subst -nocommands { |
||||||
|
set $field [lindex \$this $fieldIdx] |
||||||
|
lset this $fieldIdx {} |
||||||
|
}] |
||||||
|
} |
||||||
|
append finalBody "try \{" |
||||||
|
} |
||||||
|
append finalBody $body |
||||||
|
if {[dict exists $optDict -update]} { |
||||||
|
append finalBody "\} finally \{" |
||||||
|
foreach field $updateFields { |
||||||
|
set fieldIdx [uplevel [list set $field]] |
||||||
|
append finalBody [subst -nocommands { |
||||||
|
lset this $fieldIdx \$$field |
||||||
|
}] |
||||||
|
} |
||||||
|
append finalBody "\}" |
||||||
|
} |
||||||
|
if {!$isPublicEnabled} { |
||||||
|
set name "my.$name" |
||||||
|
} |
||||||
|
if {[dict exists $optDict -override]} { |
||||||
|
set parentNs [uplevel {set __parentClassNamespace}] |
||||||
|
if {[info commands "${parentNs}::$name"] eq ""} { |
||||||
|
error "Method ’$name’ does not override any method in parent class ’$parentNs’" |
||||||
|
} |
||||||
|
# If parent’s method is virtual (has base.<name>), auto-promote this override |
||||||
|
# to a dispatcher so that deep inheritance dispatch works correctly |
||||||
|
if {[uplevel {info exists __voo_is_virtual_class}] && \ |
||||||
|
[info commands "${parentNs}::base.$name"] ne ""} { |
||||||
|
dict set optDict -virtual {} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $optDict -virtual]} { |
||||||
|
if {![uplevel {info exists __voo_is_virtual_class}]} { |
||||||
|
error "Method ’$name’ is declared -virtual but ’[uplevel {namespace current}]’ is not a virtual class" |
||||||
|
} |
||||||
|
if {[dict exists $optDict -upvar] || [dict exists $optDict -update] || [dict exists $optDict -static]} { |
||||||
|
error "Method ’$name’ cannot combine -virtual with -upvar, -update, or -static" |
||||||
|
} |
||||||
|
# Register base.<name> with the original body for direct parent calls from subclasses |
||||||
|
uplevel [list proc "base.$name" $finalArgList $finalBody] |
||||||
|
# Build dispatch body: route to concrete class implementation at runtime |
||||||
|
set dispatchBody "set __voo_cls \[lindex \$this 0\]\n" |
||||||
|
append dispatchBody "if \{\$__voo_cls ne \[namespace current\] && \[info commands \${__voo_cls}::$name\] ne {}\} \{\n" |
||||||
|
append dispatchBody " return \[\${__voo_cls}::$name \$this" |
||||||
|
foreach arg $argList { |
||||||
|
append dispatchBody " \$$arg" |
||||||
|
} |
||||||
|
append dispatchBody "\]\n\}\n" |
||||||
|
append dispatchBody "return \[base.$name \$this" |
||||||
|
foreach arg $argList { |
||||||
|
append dispatchBody " \$$arg" |
||||||
|
} |
||||||
|
append dispatchBody "\]" |
||||||
|
set finalBody $dispatchBody |
||||||
|
} |
||||||
|
uplevel [list proc $name $finalArgList $finalBody] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# 726 |
||||||
|
|
||||||
|
##\brief Import one or more methods from parent class into the current (child) class namespace. |
||||||
|
# \param[in] methods List of method names (or a single method name) to import from parent. |
||||||
|
# \note Must be called inside a class declared with -extends. Methods are copied at class-definition time. |
||||||
|
proc importMethods {methods} { |
||||||
|
set parentNs [uplevel {set __parentClassNamespace}] |
||||||
|
# Validate caller context and get parent namespace stored by -extends handling |
||||||
|
if {$parentNs eq ""} { |
||||||
|
error "importMethods can only be used inside a class declared with -extends" |
||||||
|
} |
||||||
|
# Normalize to a list of method names |
||||||
|
if {[string length [string trim $methods]] == 0} { |
||||||
|
return |
||||||
|
} |
||||||
|
if {[catch {llength $methods}]} { |
||||||
|
set methodList [list $methods] |
||||||
|
} else { |
||||||
|
set methodList $methods |
||||||
|
} |
||||||
|
foreach methodName $methodList { |
||||||
|
set fullMethodName "${parentNs}::$methodName" |
||||||
|
# Validate parent method exists |
||||||
|
if {[info commands $fullMethodName] eq ""} { |
||||||
|
error "Method ’$methodName’ not found in parent class ’$parentNs’" |
||||||
|
} |
||||||
|
# Define a copy in the child namespace so unqualified calls resolve to child |
||||||
|
set argList [info args $fullMethodName] |
||||||
|
set body [info body $fullMethodName] |
||||||
|
uplevel [list proc $methodName $argList $body] |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
namespace export * |
||||||
|
} |
||||||
|
# provide the package |
||||||
|
package provide voo $::voo::version |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue