diff --git a/src/vendormodules/voo-1.0.0.tm b/src/vendormodules/voo-1.0.0.tm index a70a19be..64262b07 100644 --- a/src/vendormodules/voo-1.0.0.tm +++ b/src/vendormodules/voo-1.0.0.tm @@ -1,768 +1,768 @@ - -#https://github.com/AlaoPrado/voo -#License: MIT - -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: 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? ?? - 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: ?