| 1 | # stooop |
|---|
| 2 | # Simple Tcl Only Object Oriented Programming |
|---|
| 3 | # An object oriented extension to the Tcl programming language |
|---|
| 4 | # |
|---|
| 5 | # Copyright (c) 2002 by Jean-Luc Fontaine <jfontain@free.fr>. |
|---|
| 6 | # This code may be distributed under the same terms as Tcl. |
|---|
| 7 | # |
|---|
| 8 | # $Id: stooop.tcl,v 1.9 2004/01/15 06:36:14 andreas_kupries Exp $ |
|---|
| 9 | |
|---|
| 10 | |
|---|
| 11 | # check whether empty named arrays and array unset are supported: |
|---|
| 12 | package require Tcl 8.3 |
|---|
| 13 | |
|---|
| 14 | package provide stooop 4.4.1 |
|---|
| 15 | |
|---|
| 16 | # rename proc before it is overloaded, ignore error in case of multiple |
|---|
| 17 | # inclusion of this file: |
|---|
| 18 | catch {rename proc _proc} |
|---|
| 19 | |
|---|
| 20 | namespace eval ::stooop { |
|---|
| 21 | variable check |
|---|
| 22 | variable trace |
|---|
| 23 | |
|---|
| 24 | # no checking by default: use an empty instruction to avoid any performance |
|---|
| 25 | # hit: |
|---|
| 26 | set check(code) {} |
|---|
| 27 | if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} { |
|---|
| 28 | array set ::env\ |
|---|
| 29 | {STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1} |
|---|
| 30 | } |
|---|
| 31 | set check(procedures) [expr {\ |
|---|
| 32 | [info exists ::env(STOOOPCHECKPROCEDURES)]&&\ |
|---|
| 33 | $::env(STOOOPCHECKPROCEDURES)\ |
|---|
| 34 | }] |
|---|
| 35 | set check(data) [expr {\ |
|---|
| 36 | [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)\ |
|---|
| 37 | }] |
|---|
| 38 | set check(objects) [expr {\ |
|---|
| 39 | [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)\ |
|---|
| 40 | }] |
|---|
| 41 | if {$check(procedures)} { |
|---|
| 42 | append check(code) {::stooop::checkProcedure;} |
|---|
| 43 | } |
|---|
| 44 | if {[info exists ::env(STOOOPTRACEALL)]} { |
|---|
| 45 | # use same channel for both traces |
|---|
| 46 | set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL) |
|---|
| 47 | set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL) |
|---|
| 48 | } |
|---|
| 49 | if {[info exists ::env(STOOOPTRACEPROCEDURES)]} { |
|---|
| 50 | set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES) |
|---|
| 51 | switch $trace(procedureChannel) { |
|---|
| 52 | stdout - stderr {} |
|---|
| 53 | default { |
|---|
| 54 | # eventually truncate output file if it exists: |
|---|
| 55 | set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+] |
|---|
| 56 | } |
|---|
| 57 | } |
|---|
| 58 | # default format: |
|---|
| 59 | set trace(procedureFormat)\ |
|---|
| 60 | {class: %C, procedure: %p, object: %O, arguments: %a} |
|---|
| 61 | # eventually override with user defined format: |
|---|
| 62 | catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)} |
|---|
| 63 | append check(code) {::stooop::traceProcedure;} |
|---|
| 64 | } |
|---|
| 65 | if {[info exists ::env(STOOOPTRACEDATA)]} { |
|---|
| 66 | set trace(dataChannel) $::env(STOOOPTRACEDATA) |
|---|
| 67 | switch $trace(dataChannel) { |
|---|
| 68 | stdout - stderr {} |
|---|
| 69 | default { |
|---|
| 70 | # eventually truncate output file if it exists |
|---|
| 71 | set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+] |
|---|
| 72 | } |
|---|
| 73 | } |
|---|
| 74 | # default format: |
|---|
| 75 | set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v} |
|---|
| 76 | # eventually override with user defined format: |
|---|
| 77 | catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)} |
|---|
| 78 | # trace all operations by default: |
|---|
| 79 | set trace(dataOperations) rwu |
|---|
| 80 | # eventually override with user defined operations: |
|---|
| 81 | catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)} |
|---|
| 82 | } |
|---|
| 83 | |
|---|
| 84 | namespace export class virtual new delete classof ;# export public commands |
|---|
| 85 | |
|---|
| 86 | if {![info exists newId]} { |
|---|
| 87 | # initialize object id counter only once even if this file is sourced |
|---|
| 88 | # several times: |
|---|
| 89 | variable newId 0 |
|---|
| 90 | } |
|---|
| 91 | |
|---|
| 92 | # create an object of specified class or copy an existing object: |
|---|
| 93 | _proc new {classOrId args} { |
|---|
| 94 | variable newId |
|---|
| 95 | variable fullClass |
|---|
| 96 | |
|---|
| 97 | # use local variable for identifier because new can be invoked |
|---|
| 98 | # recursively: |
|---|
| 99 | if {[string is integer $classOrId]} { |
|---|
| 100 | # first argument is an object identifier (unsigned integer), copy |
|---|
| 101 | # source object to new object of identical class |
|---|
| 102 | if {[catch {\ |
|---|
| 103 | set fullClass([set id [incr newId]]) $fullClass($classOrId)\ |
|---|
| 104 | }]} { |
|---|
| 105 | error "invalid object identifier $classOrId" |
|---|
| 106 | } |
|---|
| 107 | # invoke the copy constructor for the class in caller's variable |
|---|
| 108 | # context so that object copy is transparent (see above): |
|---|
| 109 | uplevel 1 $fullClass($classOrId)::_copy $id $classOrId |
|---|
| 110 | } else { ;# first argument is a class |
|---|
| 111 | # generate constructor name: |
|---|
| 112 | set constructor ${classOrId}::[namespace tail $classOrId] |
|---|
| 113 | # we could detect here whether class was ever declared but that |
|---|
| 114 | # would prevent stooop packages to load properly, because |
|---|
| 115 | # constructor would not be invoked and thus class source file never |
|---|
| 116 | # sourced |
|---|
| 117 | # invoke the constructor for the class with optional arguments in |
|---|
| 118 | # caller's variable context so that object creation is transparent |
|---|
| 119 | # and that array names as constructor parameters work with a simple |
|---|
| 120 | # upvar |
|---|
| 121 | # note: if class is in a package, the class namespace code is loaded |
|---|
| 122 | # here, as the first object of the class is created |
|---|
| 123 | uplevel 1 $constructor [set id [incr newId]] $args |
|---|
| 124 | # generate fully qualified class namespace name now that we are sure |
|---|
| 125 | # that class namespace code has been invoked: |
|---|
| 126 | set fullClass($id) [namespace qualifiers\ |
|---|
| 127 | [uplevel 1 namespace which -command $constructor]\ |
|---|
| 128 | ] |
|---|
| 129 | } |
|---|
| 130 | return $id ;# return a unique object identifier |
|---|
| 131 | } |
|---|
| 132 | |
|---|
| 133 | _proc delete {args} { ;# delete one or more objects |
|---|
| 134 | variable fullClass |
|---|
| 135 | |
|---|
| 136 | foreach id $args { |
|---|
| 137 | # destruct in caller's variable context so that object deletion is |
|---|
| 138 | # transparent: |
|---|
| 139 | uplevel 1 ::stooop::deleteObject $fullClass($id) $id |
|---|
| 140 | unset fullClass($id) |
|---|
| 141 | } |
|---|
| 142 | } |
|---|
| 143 | |
|---|
| 144 | # delete object data starting at specified class layer and going up the base |
|---|
| 145 | # class hierarchy if any |
|---|
| 146 | # invoke the destructor for the object class and unset all the object data |
|---|
| 147 | # members for the class |
|---|
| 148 | # the destructor will in turn delete the base classes layers |
|---|
| 149 | _proc deleteObject {fullClass id} { |
|---|
| 150 | # invoke the destructor for the class in caller's variable context so |
|---|
| 151 | # that object deletion is transparent: |
|---|
| 152 | uplevel 1 ${fullClass}::~[namespace tail $fullClass] $id |
|---|
| 153 | # delete all this object data members if any (assume that they were |
|---|
| 154 | # stored as ${class}::($id,memberName)): |
|---|
| 155 | array unset ${fullClass}:: $id,* |
|---|
| 156 | # data member arrays deletion is left to the user |
|---|
| 157 | } |
|---|
| 158 | |
|---|
| 159 | _proc classof {id} { |
|---|
| 160 | variable fullClass |
|---|
| 161 | |
|---|
| 162 | return $fullClass($id) ;# return class of object |
|---|
| 163 | } |
|---|
| 164 | |
|---|
| 165 | # copy object data members from one object to another: |
|---|
| 166 | _proc copy {fullClass from to} { |
|---|
| 167 | set index [string length $from] |
|---|
| 168 | # copy regular data members: |
|---|
| 169 | foreach {name value} [array get ${fullClass}:: $from,*] { |
|---|
| 170 | set ${fullClass}::($to[string range $name $index end]) $value |
|---|
| 171 | } |
|---|
| 172 | # if any, array data members copy is left to the class programmer |
|---|
| 173 | # through the then mandatory copy constructor |
|---|
| 174 | } |
|---|
| 175 | } |
|---|
| 176 | |
|---|
| 177 | _proc ::stooop::class {args} { |
|---|
| 178 | variable declared |
|---|
| 179 | |
|---|
| 180 | set class [lindex $args 0] |
|---|
| 181 | # register class using its fully qualified name: |
|---|
| 182 | set declared([uplevel 1 namespace eval $class {namespace current}]) {} |
|---|
| 183 | # create the empty name array used to hold all class objects so that static |
|---|
| 184 | # members can be directly initialized within the class declaration but |
|---|
| 185 | # outside member procedures |
|---|
| 186 | uplevel 1 namespace eval $class [list "::variable {}\n[lindex $args end]"] |
|---|
| 187 | } |
|---|
| 188 | |
|---|
| 189 | # if procedure is a member of a known class, class and procedure names are set |
|---|
| 190 | # and true is returned, otherwise false is returned: |
|---|
| 191 | _proc ::stooop::parseProcedureName {\ |
|---|
| 192 | namespace name fullClassVariable procedureVariable messageVariable\ |
|---|
| 193 | } { |
|---|
| 194 | # namespace argument is the current namespace (fully qualified) in which the |
|---|
| 195 | # procedure is defined |
|---|
| 196 | variable declared |
|---|
| 197 | upvar 1 $fullClassVariable fullClass $procedureVariable procedure\ |
|---|
| 198 | $messageVariable message |
|---|
| 199 | |
|---|
| 200 | if {\ |
|---|
| 201 | [info exists declared($namespace)]&&\ |
|---|
| 202 | ([string length [namespace qualifiers $name]]==0)\ |
|---|
| 203 | } { |
|---|
| 204 | # a member procedure is being defined inside a class namespace |
|---|
| 205 | set fullClass $namespace |
|---|
| 206 | set procedure $name ;# member procedure name is full name |
|---|
| 207 | return 1 |
|---|
| 208 | } else { |
|---|
| 209 | # procedure is either a member of a known class or a regular procedure |
|---|
| 210 | if {![string match ::* $name]} { |
|---|
| 211 | # eventually fully qualify procedure name |
|---|
| 212 | if {[string equal $namespace ::]} { ;# global namespace special case |
|---|
| 213 | set name ::$name |
|---|
| 214 | } else { |
|---|
| 215 | set name ${namespace}::$name |
|---|
| 216 | } |
|---|
| 217 | } |
|---|
| 218 | # eventual class name is leading part: |
|---|
| 219 | set fullClass [namespace qualifiers $name] |
|---|
| 220 | if {[info exists declared($fullClass)]} { ;# if class is known |
|---|
| 221 | set procedure [namespace tail $name] ;# procedure always is the tail |
|---|
| 222 | return 1 |
|---|
| 223 | } else { ;# not a member procedure |
|---|
| 224 | if {[string length $fullClass]==0} { |
|---|
| 225 | set message "procedure $name class name is empty" |
|---|
| 226 | } else { |
|---|
| 227 | set message "procedure $name class $fullClass is unknown" |
|---|
| 228 | } |
|---|
| 229 | return 0 |
|---|
| 230 | } |
|---|
| 231 | } |
|---|
| 232 | } |
|---|
| 233 | |
|---|
| 234 | # virtual operator, to be placed before proc |
|---|
| 235 | # virtualize a member procedure, determine whether it is a pure virtual, check |
|---|
| 236 | # for procedures that cannot be virtualized |
|---|
| 237 | _proc ::stooop::virtual {keyword name arguments args} { |
|---|
| 238 | # set a flag so that proc knows it is acting upon a virtual procedure, also |
|---|
| 239 | # serves as a pure indicator: |
|---|
| 240 | variable pureVirtual |
|---|
| 241 | |
|---|
| 242 | if {![string equal [uplevel 1 namespace which -command $keyword] ::proc]} { |
|---|
| 243 | error "virtual operator works only on proc, not $keyword" |
|---|
| 244 | } |
|---|
| 245 | if {![parseProcedureName\ |
|---|
| 246 | [uplevel 1 namespace current] $name fullClass procedure message\ |
|---|
| 247 | ]} { |
|---|
| 248 | error $message ;# not in a member procedure definition |
|---|
| 249 | } |
|---|
| 250 | set class [namespace tail $fullClass] |
|---|
| 251 | if {[string equal $class $procedure]} { |
|---|
| 252 | error "cannot make class $fullClass constructor virtual" |
|---|
| 253 | } |
|---|
| 254 | if {[string equal ~$class $procedure]} { |
|---|
| 255 | error "cannot make class $fullClass destructor virtual" |
|---|
| 256 | } |
|---|
| 257 | if {![string equal [lindex $arguments 0] this]} { |
|---|
| 258 | error "cannot make static procedure $procedure of class $fullClass virtual" |
|---|
| 259 | } |
|---|
| 260 | # no procedure body means pure virtual: |
|---|
| 261 | set pureVirtual [expr {[llength $args]==0}] |
|---|
| 262 | # process procedure declaration, body being empty for pure virtual procedure |
|---|
| 263 | # make virtual transparent by using uplevel: |
|---|
| 264 | uplevel 1 ::proc [list $name $arguments [lindex $args 0]] |
|---|
| 265 | unset pureVirtual |
|---|
| 266 | } |
|---|
| 267 | |
|---|
| 268 | _proc proc {name arguments args} { |
|---|
| 269 | if {![::stooop::parseProcedureName\ |
|---|
| 270 | [uplevel 1 namespace current] $name fullClass procedure message\ |
|---|
| 271 | ]} { |
|---|
| 272 | # not in a member procedure definition, fall back to normal procedure |
|---|
| 273 | # declaration |
|---|
| 274 | # uplevel is required instead of eval here otherwise tcl seems to forget |
|---|
| 275 | # the procedure namespace if it exists |
|---|
| 276 | uplevel 1 _proc [list $name $arguments] $args |
|---|
| 277 | return |
|---|
| 278 | } |
|---|
| 279 | if {[llength $args]==0} { ;# check for procedure body presence |
|---|
| 280 | error "missing body for ${fullClass}::$procedure" |
|---|
| 281 | } |
|---|
| 282 | set class [namespace tail $fullClass] |
|---|
| 283 | if {[string equal $class $procedure]} { ;# class constructor definition |
|---|
| 284 | if {![string equal [lindex $arguments 0] this]} { |
|---|
| 285 | error "class $fullClass constructor first argument must be this" |
|---|
| 286 | } |
|---|
| 287 | if {[string equal [lindex $arguments 1] copy]} { |
|---|
| 288 | # user defined copy constructor definition |
|---|
| 289 | if {[llength $arguments]!=2} { |
|---|
| 290 | error "class $fullClass copy constructor must have 2 arguments exactly" |
|---|
| 291 | } |
|---|
| 292 | # make sure of proper declaration order: |
|---|
| 293 | if {[catch {info body ::${fullClass}::$class}]} { |
|---|
| 294 | error "class $fullClass copy constructor defined before constructor" |
|---|
| 295 | } |
|---|
| 296 | eval ::stooop::constructorDeclaration\ |
|---|
| 297 | $fullClass $class 1 \{$arguments\} $args |
|---|
| 298 | } else { ;# main constructor |
|---|
| 299 | eval ::stooop::constructorDeclaration\ |
|---|
| 300 | $fullClass $class 0 \{$arguments\} $args |
|---|
| 301 | # always generate default copy constructor: |
|---|
| 302 | ::stooop::generateDefaultCopyConstructor $fullClass |
|---|
| 303 | } |
|---|
| 304 | } elseif {[string equal ~$class $procedure]} { |
|---|
| 305 | # class destructor declaration |
|---|
| 306 | if {[llength $arguments]!=1} { |
|---|
| 307 | error "class $fullClass destructor must have 1 argument exactly" |
|---|
| 308 | } |
|---|
| 309 | if {![string equal [lindex $arguments 0] this]} { |
|---|
| 310 | error "class $fullClass destructor argument must be this" |
|---|
| 311 | } |
|---|
| 312 | # make sure of proper declaration order |
|---|
| 313 | # (use fastest method for testing procedure existence): |
|---|
| 314 | if {[catch {info body ::${fullClass}::$class}]} { |
|---|
| 315 | error "class $fullClass destructor defined before constructor" |
|---|
| 316 | } |
|---|
| 317 | ::stooop::destructorDeclaration\ |
|---|
| 318 | $fullClass $class $arguments [lindex $args 0] |
|---|
| 319 | } else { |
|---|
| 320 | # regular member procedure, may be static if there is no this first |
|---|
| 321 | # argument |
|---|
| 322 | # make sure of proper declaration order: |
|---|
| 323 | if {[catch {info body ::${fullClass}::$class}]} { |
|---|
| 324 | error "class $fullClass member procedure $procedure defined before constructor" |
|---|
| 325 | } |
|---|
| 326 | ::stooop::memberProcedureDeclaration\ |
|---|
| 327 | $fullClass $class $procedure $arguments [lindex $args 0] |
|---|
| 328 | } |
|---|
| 329 | } |
|---|
| 330 | |
|---|
| 331 | # copy flag is set for user defined copy constructor: |
|---|
| 332 | _proc ::stooop::constructorDeclaration {fullClass class copy arguments args} { |
|---|
| 333 | variable check |
|---|
| 334 | variable fullBases |
|---|
| 335 | variable variable |
|---|
| 336 | |
|---|
| 337 | set number [llength $args] |
|---|
| 338 | # check that each base class constructor has arguments: |
|---|
| 339 | if {($number%2)==0} { |
|---|
| 340 | error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing" |
|---|
| 341 | } |
|---|
| 342 | if {[string equal [lindex $arguments end] args]} { |
|---|
| 343 | # remember that there is a variable number of arguments in class |
|---|
| 344 | # constructor |
|---|
| 345 | set variable($fullClass) {} |
|---|
| 346 | } |
|---|
| 347 | if {!$copy} { |
|---|
| 348 | # do not initialize (or reinitialize in case of multiple class file |
|---|
| 349 | # source statements) base classes for copy constructor |
|---|
| 350 | set fullBases($fullClass) {} |
|---|
| 351 | } |
|---|
| 352 | # check base classes and their constructor arguments: |
|---|
| 353 | foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] { |
|---|
| 354 | # fully qualify base class namespace by looking up constructor, which |
|---|
| 355 | # must exist |
|---|
| 356 | set constructor ${base}::[namespace tail $base] |
|---|
| 357 | # in case base class is defined in a file that is part of a package, |
|---|
| 358 | # make sure that file is sourced through the tcl package auto-loading |
|---|
| 359 | # mechanism by directly invoking the base class constructor while |
|---|
| 360 | # ignoring the resulting error |
|---|
| 361 | catch {$constructor} |
|---|
| 362 | # determine fully qualified base class name in user invocation level |
|---|
| 363 | # (up 2 levels from here since this procedure is invoked exclusively by |
|---|
| 364 | # proc) |
|---|
| 365 | set fullBase [namespace qualifiers\ |
|---|
| 366 | [uplevel 2 namespace which -command $constructor]\ |
|---|
| 367 | ] |
|---|
| 368 | if {[string length $fullBase]==0} { ;# base constructor is not defined |
|---|
| 369 | if {[string match *$base $fullClass]} { |
|---|
| 370 | # if the specified base class name is included last in the fully |
|---|
| 371 | # qualified class name, assume that it was meant to be the same |
|---|
| 372 | error "class $fullClass cannot be derived from itself" |
|---|
| 373 | } else { |
|---|
| 374 | error "class $fullClass constructor defined before base class $base constructor" |
|---|
| 375 | } |
|---|
| 376 | } |
|---|
| 377 | # check and save base classes only for main constructor that defines |
|---|
| 378 | # them: |
|---|
| 379 | if {!$copy} { |
|---|
| 380 | if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} { |
|---|
| 381 | error "class $fullClass directly inherits from class $fullBase more than once" |
|---|
| 382 | } |
|---|
| 383 | lappend fullBases($fullClass) $fullBase |
|---|
| 384 | } |
|---|
| 385 | # replace new lines with blanks in base arguments part in case user has |
|---|
| 386 | # formatted long declarations with new lines |
|---|
| 387 | regsub -all {\n} $baseArguments { } constructorArguments($fullBase) |
|---|
| 388 | } |
|---|
| 389 | # setup access to class data (an empty named array) |
|---|
| 390 | # fully qualify tcl variable command for it may have been redefined within |
|---|
| 391 | # the class namespace |
|---|
| 392 | # since constructor is directly invoked by new, the object identifier must |
|---|
| 393 | # be valid, so debugging the procedure is pointless |
|---|
| 394 | set constructorBody \ |
|---|
| 395 | "::variable {} |
|---|
| 396 | $check(code) |
|---|
| 397 | " |
|---|
| 398 | # base class(es) derivation specified: |
|---|
| 399 | if {[llength $fullBases($fullClass)]>0} { |
|---|
| 400 | # invoke base class constructors before evaluating constructor body |
|---|
| 401 | # then set base part hidden derived member so that virtual procedures |
|---|
| 402 | # are invoked at base class level as in C++ |
|---|
| 403 | if {[info exists variable($fullClass)]} { |
|---|
| 404 | # variable number of arguments in derived class constructor |
|---|
| 405 | foreach fullBase $fullBases($fullClass) { |
|---|
| 406 | if {![info exists constructorArguments($fullBase)]} { |
|---|
| 407 | error "missing base class $fullBase constructor arguments from class $fullClass constructor" |
|---|
| 408 | } |
|---|
| 409 | set baseConstructor ${fullBase}::[namespace tail $fullBase] |
|---|
| 410 | if {\ |
|---|
| 411 | [info exists variable($fullBase)]&&\ |
|---|
| 412 | ([string first {$args} $constructorArguments($fullBase)]>=0)\ |
|---|
| 413 | } { |
|---|
| 414 | # variable number of arguments in base class constructor and |
|---|
| 415 | # in derived class base class constructor arguments |
|---|
| 416 | # use eval so that base class constructor sees arguments |
|---|
| 417 | # instead of a list |
|---|
| 418 | # only the last argument of the base class constructor |
|---|
| 419 | # arguments is considered as a variable list |
|---|
| 420 | # (it usually is $args but could be a procedure invocation, |
|---|
| 421 | # such as [filter $args]) |
|---|
| 422 | # fully qualify tcl commands such as set, for they may have |
|---|
| 423 | # been redefined within the class namespace |
|---|
| 424 | append constructorBody \ |
|---|
| 425 | "::set _list \[::list $constructorArguments($fullBase)\] |
|---|
| 426 | ::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\] |
|---|
| 427 | ::unset _list |
|---|
| 428 | ::set ${fullBase}::(\$this,_derived) $fullClass |
|---|
| 429 | " |
|---|
| 430 | } else { |
|---|
| 431 | # no special processing needed |
|---|
| 432 | # variable number of arguments in base class constructor or |
|---|
| 433 | # variable arguments list passed as is to base class |
|---|
| 434 | # constructor |
|---|
| 435 | append constructorBody \ |
|---|
| 436 | "$baseConstructor \$this $constructorArguments($fullBase) |
|---|
| 437 | ::set ${fullBase}::(\$this,_derived) $fullClass |
|---|
| 438 | " |
|---|
| 439 | } |
|---|
| 440 | } |
|---|
| 441 | } else { ;# constant number of arguments |
|---|
| 442 | foreach fullBase $fullBases($fullClass) { |
|---|
| 443 | if {![info exists constructorArguments($fullBase)]} { |
|---|
| 444 | error "missing base class $fullBase constructor arguments from class $fullClass constructor" |
|---|
| 445 | } |
|---|
| 446 | set baseConstructor ${fullBase}::[namespace tail $fullBase] |
|---|
| 447 | append constructorBody \ |
|---|
| 448 | "$baseConstructor \$this $constructorArguments($fullBase) |
|---|
| 449 | ::set ${fullBase}::(\$this,_derived) $fullClass |
|---|
| 450 | " |
|---|
| 451 | } |
|---|
| 452 | } |
|---|
| 453 | } ;# else no base class derivation specified |
|---|
| 454 | if {$copy} { |
|---|
| 455 | # for user defined copy constructor, copy derived class member if it |
|---|
| 456 | # exists |
|---|
| 457 | append constructorBody \ |
|---|
| 458 | "::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)} |
|---|
| 459 | " |
|---|
| 460 | } |
|---|
| 461 | # finally append user defined procedure body: |
|---|
| 462 | append constructorBody [lindex $args end] |
|---|
| 463 | if {$copy} { |
|---|
| 464 | _proc ${fullClass}::_copy $arguments $constructorBody |
|---|
| 465 | } else { |
|---|
| 466 | _proc ${fullClass}::$class $arguments $constructorBody |
|---|
| 467 | } |
|---|
| 468 | } |
|---|
| 469 | |
|---|
| 470 | _proc ::stooop::destructorDeclaration {fullClass class arguments body} { |
|---|
| 471 | variable check |
|---|
| 472 | variable fullBases |
|---|
| 473 | |
|---|
| 474 | # setup access to class data |
|---|
| 475 | # since the object identifier is always valid at this point, debugging the |
|---|
| 476 | # procedure is pointless |
|---|
| 477 | set body \ |
|---|
| 478 | "::variable {} |
|---|
| 479 | $check(code) |
|---|
| 480 | $body |
|---|
| 481 | " |
|---|
| 482 | # if there are any, delete base classes parts in reverse order of |
|---|
| 483 | # construction |
|---|
| 484 | for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}\ |
|---|
| 485 | {incr index -1}\ |
|---|
| 486 | { |
|---|
| 487 | set fullBase [lindex $fullBases($fullClass) $index] |
|---|
| 488 | append body \ |
|---|
| 489 | "::stooop::deleteObject $fullBase \$this |
|---|
| 490 | " |
|---|
| 491 | } |
|---|
| 492 | _proc ${fullClass}::~$class $arguments $body |
|---|
| 493 | } |
|---|
| 494 | |
|---|
| 495 | _proc ::stooop::memberProcedureDeclaration {\ |
|---|
| 496 | fullClass class procedure arguments body\ |
|---|
| 497 | } { |
|---|
| 498 | variable check |
|---|
| 499 | variable pureVirtual |
|---|
| 500 | |
|---|
| 501 | if {[info exists pureVirtual]} { ;# virtual declaration |
|---|
| 502 | if {$pureVirtual} { ;# pure virtual declaration |
|---|
| 503 | # setup access to class data |
|---|
| 504 | # evaluate derived procedure which must exists. derived procedure |
|---|
| 505 | # return value is automatically returned |
|---|
| 506 | _proc ${fullClass}::$procedure $arguments \ |
|---|
| 507 | "::variable {} |
|---|
| 508 | $check(code) |
|---|
| 509 | ::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\] |
|---|
| 510 | " |
|---|
| 511 | } else { ;# regular virtual declaration |
|---|
| 512 | # setup access to class data |
|---|
| 513 | # evaluate derived procedure and return if it exists |
|---|
| 514 | # else evaluate the base class procedure which can be invoked from |
|---|
| 515 | # derived class procedure by prepending _ |
|---|
| 516 | _proc ${fullClass}::_$procedure $arguments \ |
|---|
| 517 | "::variable {} |
|---|
| 518 | $check(code) |
|---|
| 519 | $body |
|---|
| 520 | " |
|---|
| 521 | _proc ${fullClass}::$procedure $arguments \ |
|---|
| 522 | "::variable {} |
|---|
| 523 | $check(code) |
|---|
| 524 | if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} { |
|---|
| 525 | ::return \[::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\] |
|---|
| 526 | } |
|---|
| 527 | ::uplevel 1 ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\] |
|---|
| 528 | " |
|---|
| 529 | } |
|---|
| 530 | } else { ;# non virtual declaration |
|---|
| 531 | # setup access to class data: |
|---|
| 532 | _proc ${fullClass}::$procedure $arguments \ |
|---|
| 533 | "::variable {} |
|---|
| 534 | $check(code) |
|---|
| 535 | $body |
|---|
| 536 | " |
|---|
| 537 | } |
|---|
| 538 | } |
|---|
| 539 | |
|---|
| 540 | # generate default copy procedure which may be overriden by the user for any |
|---|
| 541 | # class layer: |
|---|
| 542 | _proc ::stooop::generateDefaultCopyConstructor {fullClass} { |
|---|
| 543 | variable fullBases |
|---|
| 544 | |
|---|
| 545 | # generate code for cloning base classes layers if there is at least one |
|---|
| 546 | # base class |
|---|
| 547 | foreach fullBase $fullBases($fullClass) { |
|---|
| 548 | append body \ |
|---|
| 549 | "${fullBase}::_copy \$this \$sibling |
|---|
| 550 | " |
|---|
| 551 | } |
|---|
| 552 | append body \ |
|---|
| 553 | "::stooop::copy $fullClass \$sibling \$this |
|---|
| 554 | " |
|---|
| 555 | _proc ${fullClass}::_copy {this sibling} $body |
|---|
| 556 | } |
|---|
| 557 | |
|---|
| 558 | |
|---|
| 559 | if {[llength [array names ::env STOOOP*]]>0} { |
|---|
| 560 | # if one or more environment variables are set, we are in debugging mode |
|---|
| 561 | |
|---|
| 562 | # gracefully handle multiple sourcing of this file: |
|---|
| 563 | catch {rename ::stooop::class ::stooop::_class} |
|---|
| 564 | # use a new class procedure instead of adding debugging code to existing one |
|---|
| 565 | _proc ::stooop::class {args} { |
|---|
| 566 | variable trace |
|---|
| 567 | variable check |
|---|
| 568 | |
|---|
| 569 | set class [lindex $args 0] |
|---|
| 570 | if {$check(data)} { |
|---|
| 571 | # check write and unset operations on empty named array holding |
|---|
| 572 | # class data |
|---|
| 573 | uplevel 1 namespace eval $class\ |
|---|
| 574 | [list {::trace variable {} wu ::stooop::checkData}] |
|---|
| 575 | } |
|---|
| 576 | if {[info exists ::env(STOOOPTRACEDATA)]} { |
|---|
| 577 | # trace write and unset operations on empty named array holding |
|---|
| 578 | # class data |
|---|
| 579 | uplevel 1 namespace eval $class [list\ |
|---|
| 580 | "::trace variable {} $trace(dataOperations) ::stooop::traceData"\ |
|---|
| 581 | ] |
|---|
| 582 | } |
|---|
| 583 | uplevel 1 ::stooop::_class $args |
|---|
| 584 | } |
|---|
| 585 | |
|---|
| 586 | if {$::stooop::check(procedures)} { |
|---|
| 587 | # prevent the creation of any object of a pure interface class |
|---|
| 588 | # use a new virtual procedure instead of adding debugging code to |
|---|
| 589 | # existing one |
|---|
| 590 | # gracefully handle multiple sourcing of this file: |
|---|
| 591 | catch {rename ::stooop::virtual ::stooop::_virtual} |
|---|
| 592 | # keep track of interface classes (which have at least 1 pure virtual |
|---|
| 593 | # procedure): |
|---|
| 594 | _proc ::stooop::virtual {keyword name arguments args} { |
|---|
| 595 | variable interface |
|---|
| 596 | |
|---|
| 597 | uplevel 1 ::stooop::_virtual [list $keyword $name $arguments] $args |
|---|
| 598 | parseProcedureName [uplevel 1 namespace current] $name\ |
|---|
| 599 | fullClass procedure message |
|---|
| 600 | if {[llength $args]==0} { ;# no procedure body means pure virtual |
|---|
| 601 | set interface($fullClass) {} |
|---|
| 602 | } |
|---|
| 603 | } |
|---|
| 604 | } |
|---|
| 605 | |
|---|
| 606 | if {$::stooop::check(objects)} { |
|---|
| 607 | _proc invokingProcedure {} { |
|---|
| 608 | if {[catch {set procedure [lindex [info level -2] 0]}]} { |
|---|
| 609 | # no invoking procedure |
|---|
| 610 | return {top level} |
|---|
| 611 | } elseif {\ |
|---|
| 612 | ([string length $procedure]==0)||\ |
|---|
| 613 | [string equal $procedure namespace]\ |
|---|
| 614 | } { ;# invoked from a namespace body |
|---|
| 615 | return "namespace [uplevel 2 namespace current]" |
|---|
| 616 | } else { |
|---|
| 617 | # store fully qualified name, visible from creator procedure |
|---|
| 618 | # invoking procedure |
|---|
| 619 | return [uplevel 3 namespace which -command $procedure] |
|---|
| 620 | } |
|---|
| 621 | } |
|---|
| 622 | } |
|---|
| 623 | |
|---|
| 624 | if {$::stooop::check(procedures)||$::stooop::check(objects)} { |
|---|
| 625 | # gracefully handle multiple sourcing of this file: |
|---|
| 626 | catch {rename ::stooop::new ::stooop::_new} |
|---|
| 627 | # use a new new procedure instead of adding debugging code to existing |
|---|
| 628 | # one: |
|---|
| 629 | _proc ::stooop::new {classOrId args} { |
|---|
| 630 | variable newId |
|---|
| 631 | variable check |
|---|
| 632 | |
|---|
| 633 | if {$check(procedures)} { |
|---|
| 634 | variable fullClass |
|---|
| 635 | variable interface |
|---|
| 636 | } |
|---|
| 637 | if {$check(objects)} { |
|---|
| 638 | variable creator |
|---|
| 639 | } |
|---|
| 640 | if {$check(procedures)} { |
|---|
| 641 | if {[string is integer $classOrId]} { |
|---|
| 642 | # first argument is an object identifier |
|---|
| 643 | # class code, if from a package, must already be loaded |
|---|
| 644 | set fullName $fullClass($classOrId) |
|---|
| 645 | } else { ;# first argument is a class |
|---|
| 646 | # generate constructor name: |
|---|
| 647 | set constructor ${classOrId}::[namespace tail $classOrId] |
|---|
| 648 | # force loading in case class is in a package so namespace |
|---|
| 649 | # commands work properly: |
|---|
| 650 | catch {$constructor} |
|---|
| 651 | set fullName [namespace qualifiers\ |
|---|
| 652 | [uplevel 1 namespace which -command $constructor]\ |
|---|
| 653 | ] |
|---|
| 654 | # anticipate full class name storage in original new{} in |
|---|
| 655 | # order to avoid invalid object identifier error in |
|---|
| 656 | # checkProcedure{} when member procedure is invoked from |
|---|
| 657 | # within contructor, in which case full class name would |
|---|
| 658 | # have yet to be stored. |
|---|
| 659 | set fullClass([expr {$newId+1}]) $fullName |
|---|
| 660 | # new identifier is really incremented in original new{} |
|---|
| 661 | } |
|---|
| 662 | if {[info exists interface($fullName)]} { |
|---|
| 663 | error "class $fullName with pure virtual procedures should not be instanciated" |
|---|
| 664 | } |
|---|
| 665 | } |
|---|
| 666 | if {$check(objects)} { |
|---|
| 667 | # keep track of procedure in which creation occured (new |
|---|
| 668 | # identifier is really incremented in original new{}) |
|---|
| 669 | set creator([expr {$newId+1}]) [invokingProcedure] |
|---|
| 670 | } |
|---|
| 671 | return [uplevel 1 ::stooop::_new $classOrId $args] |
|---|
| 672 | } |
|---|
| 673 | } |
|---|
| 674 | |
|---|
| 675 | if {$::stooop::check(objects)} { |
|---|
| 676 | _proc ::stooop::delete {args} { |
|---|
| 677 | variable fullClass |
|---|
| 678 | variable deleter |
|---|
| 679 | |
|---|
| 680 | # keep track of procedure in which deletion occured: |
|---|
| 681 | set procedure [invokingProcedure] |
|---|
| 682 | foreach id $args { |
|---|
| 683 | uplevel 1 ::stooop::deleteObject $fullClass($id) $id |
|---|
| 684 | unset fullClass($id) |
|---|
| 685 | set deleter($id) $procedure |
|---|
| 686 | } |
|---|
| 687 | } |
|---|
| 688 | } |
|---|
| 689 | |
|---|
| 690 | # return the unsorted list of ancestors in class hierarchy: |
|---|
| 691 | _proc ::stooop::ancestors {fullClass} { |
|---|
| 692 | variable ancestors ;# use a cache for efficiency |
|---|
| 693 | variable fullBases |
|---|
| 694 | |
|---|
| 695 | if {[info exists ancestors($fullClass)]} { |
|---|
| 696 | return $ancestors($fullClass) ;# found in the cache |
|---|
| 697 | } |
|---|
| 698 | set list {} |
|---|
| 699 | foreach class $fullBases($fullClass) { |
|---|
| 700 | set list [concat $list [list $class] [ancestors $class]] |
|---|
| 701 | } |
|---|
| 702 | set ancestors($fullClass) $list ;# save in cache |
|---|
| 703 | return $list |
|---|
| 704 | } |
|---|
| 705 | |
|---|
| 706 | # since this procedure is always invoked from a debug procedure, take the |
|---|
| 707 | # extra level in the stack frame into account |
|---|
| 708 | # parameters (passed as references) that cannot be determined are not set |
|---|
| 709 | _proc ::stooop::debugInformation {\ |
|---|
| 710 | className fullClassName procedureName fullProcedureName\ |
|---|
| 711 | thisParameterName\ |
|---|
| 712 | } { |
|---|
| 713 | upvar 1 $className class $fullClassName fullClass\ |
|---|
| 714 | $procedureName procedure $fullProcedureName fullProcedure\ |
|---|
| 715 | $thisParameterName thisParameter |
|---|
| 716 | variable declared |
|---|
| 717 | |
|---|
| 718 | set namespace [uplevel 2 namespace current] |
|---|
| 719 | # not in a class namespace: |
|---|
| 720 | if {[lsearch -exact [array names declared] $namespace]<0} return |
|---|
| 721 | # remove redundant global qualifier: |
|---|
| 722 | set fullClass [string trimleft $namespace :] |
|---|
| 723 | set class [namespace tail $fullClass] ;# class name |
|---|
| 724 | set list [info level -2] |
|---|
| 725 | set first [lindex $list 0] |
|---|
| 726 | if {([llength $list]==0)||[string equal $first namespace]}\ |
|---|
| 727 | return ;# not in a procedure, nothing else to do |
|---|
| 728 | set procedure $first |
|---|
| 729 | # procedure must be known at the invoker level: |
|---|
| 730 | set fullProcedure [uplevel 3 namespace which -command $procedure] |
|---|
| 731 | set procedure [namespace tail $procedure] ;# strip procedure name |
|---|
| 732 | if {[string equal $class $procedure]} { ;# constructor |
|---|
| 733 | set procedure constructor |
|---|
| 734 | } elseif {[string equal ~$class $procedure]} { ;# destructor |
|---|
| 735 | set procedure destructor |
|---|
| 736 | } |
|---|
| 737 | if {[string equal [lindex [info args $fullProcedure] 0] this]} { |
|---|
| 738 | # non static procedure |
|---|
| 739 | # object identifier is first argument: |
|---|
| 740 | set thisParameter [lindex $list 1] |
|---|
| 741 | } |
|---|
| 742 | } |
|---|
| 743 | |
|---|
| 744 | # check that member procedure is valid for object passed as parameter: |
|---|
| 745 | _proc ::stooop::checkProcedure {} { |
|---|
| 746 | variable fullClass |
|---|
| 747 | |
|---|
| 748 | debugInformation class qualifiedClass procedure qualifiedProcedure this |
|---|
| 749 | # static procedure, no checking possible: |
|---|
| 750 | if {![info exists this]} return |
|---|
| 751 | # in constructor, checking useless since object is not yet created: |
|---|
| 752 | if {[string equal $procedure constructor]} return |
|---|
| 753 | if {![info exists fullClass($this)]} { |
|---|
| 754 | error "$this is not a valid object identifier" |
|---|
| 755 | } |
|---|
| 756 | set fullName [string trimleft $fullClass($this) :] |
|---|
| 757 | # procedure and object classes match: |
|---|
| 758 | if {[string equal $fullName $qualifiedClass]} return |
|---|
| 759 | # restore global qualifiers to compare with internal full class array |
|---|
| 760 | # data |
|---|
| 761 | if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} { |
|---|
| 762 | error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName" |
|---|
| 763 | } |
|---|
| 764 | } |
|---|
| 765 | |
|---|
| 766 | # gather current procedure data, perform substitutions and output to trace |
|---|
| 767 | # channel: |
|---|
| 768 | _proc ::stooop::traceProcedure {} { |
|---|
| 769 | variable trace |
|---|
| 770 | |
|---|
| 771 | debugInformation class qualifiedClass procedure qualifiedProcedure this |
|---|
| 772 | # all debug data is available since we are for sure in a class procedure |
|---|
| 773 | set text $trace(procedureFormat) |
|---|
| 774 | regsub -all %C $text $qualifiedClass text ;# fully qualified class name |
|---|
| 775 | regsub -all %c $text $class text |
|---|
| 776 | # fully qualified procedure name: |
|---|
| 777 | regsub -all %P $text $qualifiedProcedure text |
|---|
| 778 | regsub -all %p $text $procedure text |
|---|
| 779 | if {[info exists this]} { ;# non static procedure |
|---|
| 780 | regsub -all %O $text $this text |
|---|
| 781 | # remaining arguments: |
|---|
| 782 | regsub -all %a $text [lrange [info level -1] 2 end] text |
|---|
| 783 | } else { ;# static procedure |
|---|
| 784 | regsub -all %O $text {} text |
|---|
| 785 | # remaining arguments: |
|---|
| 786 | regsub -all %a $text [lrange [info level -1] 1 end] text |
|---|
| 787 | } |
|---|
| 788 | puts $trace(procedureChannel) $text |
|---|
| 789 | } |
|---|
| 790 | |
|---|
| 791 | # check that class data member is accessed within procedure of identical |
|---|
| 792 | # class |
|---|
| 793 | # then if procedure is not static, check that only data belonging to the |
|---|
| 794 | # object passed as parameter is accessed |
|---|
| 795 | _proc ::stooop::checkData {array name operation} { |
|---|
| 796 | scan $name %u,%s identifier member |
|---|
| 797 | # ignore internally defined members: |
|---|
| 798 | if {[info exists member]&&[string equal $member _derived]} return |
|---|
| 799 | |
|---|
| 800 | debugInformation class qualifiedClass procedure qualifiedProcedure this |
|---|
| 801 | # no checking can be done outside of a class namespace: |
|---|
| 802 | if {![info exists class]} return |
|---|
| 803 | # determine array full name: |
|---|
| 804 | set array [uplevel 1 [list namespace which -variable $array]] |
|---|
| 805 | if {![info exists procedure]} { ;# inside a class namespace |
|---|
| 806 | # compare with empty named array fully qualified name: |
|---|
| 807 | if {![string equal $array ::${qualifiedClass}::]} { |
|---|
| 808 | # trace command error message is automatically prepended and |
|---|
| 809 | # indicates operation |
|---|
| 810 | error\ |
|---|
| 811 | "class access violation in class $qualifiedClass namespace" |
|---|
| 812 | } |
|---|
| 813 | return ;# done |
|---|
| 814 | } |
|---|
| 815 | # ignore internal copy procedure: |
|---|
| 816 | if {[string equal $qualifiedProcedure ::stooop::copy]} return |
|---|
| 817 | if {![string equal $array ::${qualifiedClass}::]} { |
|---|
| 818 | # compare with empty named array fully qualified name |
|---|
| 819 | # trace command error message is automatically prepended and |
|---|
| 820 | # indicates operation |
|---|
| 821 | error "class access violation in procedure $qualifiedProcedure" |
|---|
| 822 | } |
|---|
| 823 | # static procedure, all objects can be accessed: |
|---|
| 824 | if {![info exists this]} return |
|---|
| 825 | # static data members can be accessed: |
|---|
| 826 | if {![info exists identifier]} return |
|---|
| 827 | # check that accessed data belongs to this object: |
|---|
| 828 | if {$this!=$identifier} { |
|---|
| 829 | error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this" |
|---|
| 830 | } |
|---|
| 831 | } |
|---|
| 832 | |
|---|
| 833 | # gather accessed data member information, perform substitutions and output |
|---|
| 834 | # to trace channel |
|---|
| 835 | _proc ::stooop::traceData {array name operation} { |
|---|
| 836 | variable trace |
|---|
| 837 | |
|---|
| 838 | scan $name %u,%s identifier member |
|---|
| 839 | # ignore internally defined members: |
|---|
| 840 | if {[info exists member]&&[string equal $member _derived]} return |
|---|
| 841 | |
|---|
| 842 | # ignore internal destruction: |
|---|
| 843 | if {\ |
|---|
| 844 | ![catch {lindex [info level -1] 0} procedure]&&\ |
|---|
| 845 | [string equal ::stooop::deleteObject $procedure]\ |
|---|
| 846 | } return |
|---|
| 847 | set class {} ;# in case we are outside a class |
|---|
| 848 | set qualifiedClass {} |
|---|
| 849 | set procedure {} ;# in case we are outside a class procedure |
|---|
| 850 | set qualifiedProcedure {} |
|---|
| 851 | |
|---|
| 852 | debugInformation class qualifiedClass procedure qualifiedProcedure this |
|---|
| 853 | set text $trace(dataFormat) |
|---|
| 854 | regsub -all %C $text $qualifiedClass text ;# fully qualified class name |
|---|
| 855 | regsub -all %c $text $class text |
|---|
| 856 | if {[info exists member]} { |
|---|
| 857 | regsub -all %m $text $member text |
|---|
| 858 | } else { |
|---|
| 859 | regsub -all %m $text $name text ;# static member |
|---|
| 860 | } |
|---|
| 861 | # fully qualified procedure name: |
|---|
| 862 | regsub -all %P $text $qualifiedProcedure text |
|---|
| 863 | regsub -all %p $text $procedure text |
|---|
| 864 | # fully qualified array name with global qualifiers stripped: |
|---|
| 865 | regsub -all %A $text [string trimleft\ |
|---|
| 866 | [uplevel 1 [list namespace which -variable $array]] :\ |
|---|
| 867 | ] text |
|---|
| 868 | if {[info exists this]} { ;# non static procedure |
|---|
| 869 | regsub -all %O $text $this text |
|---|
| 870 | } else { ;# static procedure |
|---|
| 871 | regsub -all %O $text {} text |
|---|
| 872 | } |
|---|
| 873 | array set string {r read w write u unset} |
|---|
| 874 | regsub -all %o $text $string($operation) text |
|---|
| 875 | if {[string equal $operation u]} { |
|---|
| 876 | regsub -all %v $text {} text ;# no value when unsetting |
|---|
| 877 | } else { |
|---|
| 878 | regsub -all %v $text [uplevel 1 set ${array}($name)] text |
|---|
| 879 | } |
|---|
| 880 | puts $trace(dataChannel) $text |
|---|
| 881 | } |
|---|
| 882 | |
|---|
| 883 | if {$::stooop::check(objects)} { |
|---|
| 884 | # print existing objects along with creation procedure, with optional |
|---|
| 885 | # class pattern (see the string Tcl command manual) |
|---|
| 886 | _proc ::stooop::printObjects {{pattern *}} { |
|---|
| 887 | variable fullClass |
|---|
| 888 | variable creator |
|---|
| 889 | |
|---|
| 890 | puts "stooop::printObjects invoked from [invokingProcedure]:" |
|---|
| 891 | foreach id [lsort -integer [array names fullClass]] { |
|---|
| 892 | if {[string match $pattern $fullClass($id)]} { |
|---|
| 893 | puts "$fullClass($id)\($id\) + $creator($id)" |
|---|
| 894 | } |
|---|
| 895 | } |
|---|
| 896 | } |
|---|
| 897 | |
|---|
| 898 | # record all existing objects for later report: |
|---|
| 899 | _proc ::stooop::record {} { |
|---|
| 900 | variable fullClass |
|---|
| 901 | variable checkpointFullClass |
|---|
| 902 | |
|---|
| 903 | puts "stooop::record invoked from [invokingProcedure]" |
|---|
| 904 | catch {unset checkpointFullClass} |
|---|
| 905 | array set checkpointFullClass [array get fullClass] |
|---|
| 906 | } |
|---|
| 907 | |
|---|
| 908 | # print all new or deleted object since last record, with optional class |
|---|
| 909 | # pattern: |
|---|
| 910 | _proc ::stooop::report {{pattern *}} { |
|---|
| 911 | variable fullClass |
|---|
| 912 | variable checkpointFullClass |
|---|
| 913 | variable creator |
|---|
| 914 | variable deleter |
|---|
| 915 | |
|---|
| 916 | puts "stooop::report invoked from [invokingProcedure]:" |
|---|
| 917 | set checkpointIds [lsort -integer [array names checkpointFullClass]] |
|---|
| 918 | set currentIds [lsort -integer [array names fullClass]] |
|---|
| 919 | foreach id $currentIds { |
|---|
| 920 | if {\ |
|---|
| 921 | [string match $pattern $fullClass($id)]&&\ |
|---|
| 922 | ([lsearch -exact $checkpointIds $id]<0)\ |
|---|
| 923 | } { |
|---|
| 924 | puts "+ $fullClass($id)\($id\) + $creator($id)" |
|---|
| 925 | } |
|---|
| 926 | } |
|---|
| 927 | foreach id $checkpointIds { |
|---|
| 928 | if {\ |
|---|
| 929 | [string match $pattern $checkpointFullClass($id)]&&\ |
|---|
| 930 | ([lsearch -exact $currentIds $id]<0)\ |
|---|
| 931 | } { |
|---|
| 932 | puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)" |
|---|
| 933 | } |
|---|
| 934 | } |
|---|
| 935 | } |
|---|
| 936 | } |
|---|
| 937 | |
|---|
| 938 | } |
|---|
