# stooop
# Simple Tcl Only Object Oriented Programming
# An object oriented extension to the Tcl programming language
#
# Copyright (c) 2002 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: stooop.tcl,v 1.9 2004/01/15 06:36:14 andreas_kupries Exp $
# check whether empty named arrays and array unset are supported:
package require Tcl 8.3
package provide stooop 4.4.1
# rename proc before it is overloaded, ignore error in case of multiple
# inclusion of this file:
catch {rename proc _proc}
namespace eval ::stooop {
variable check
variable trace
# no checking by default: use an empty instruction to avoid any performance
# hit:
set check(code) {}
if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} {
array set ::env\
{STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1}
}
set check(procedures) [expr {\
[info exists ::env(STOOOPCHECKPROCEDURES)]&&\
$::env(STOOOPCHECKPROCEDURES)\
}]
set check(data) [expr {\
[info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)\
}]
set check(objects) [expr {\
[info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)\
}]
if {$check(procedures)} {
append check(code) {::stooop::checkProcedure;}
}
if {[info exists ::env(STOOOPTRACEALL)]} {
# use same channel for both traces
set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
}
if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES)
switch $trace(procedureChannel) {
stdout - stderr {}
default {
# eventually truncate output file if it exists:
set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+]
}
}
# default format:
set trace(procedureFormat)\
{class: %C, procedure: %p, object: %O, arguments: %a}
# eventually override with user defined format:
catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)}
append check(code) {::stooop::traceProcedure;}
}
if {[info exists ::env(STOOOPTRACEDATA)]} {
set trace(dataChannel) $::env(STOOOPTRACEDATA)
switch $trace(dataChannel) {
stdout - stderr {}
default {
# eventually truncate output file if it exists
set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+]
}
}
# default format:
set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
# eventually override with user defined format:
catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)}
# trace all operations by default:
set trace(dataOperations) rwu
# eventually override with user defined operations:
catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)}
}
namespace export class virtual new delete classof ;# export public commands
if {![info exists newId]} {
# initialize object id counter only once even if this file is sourced
# several times:
variable newId 0
}
# create an object of specified class or copy an existing object:
_proc new {classOrId args} {
variable newId
variable fullClass
# use local variable for identifier because new can be invoked
# recursively:
if {[string is integer $classOrId]} {
# first argument is an object identifier (unsigned integer), copy
# source object to new object of identical class
if {[catch {\
set fullClass([set id [incr newId]]) $fullClass($classOrId)\
}]} {
error "invalid object identifier $classOrId"
}
# invoke the copy constructor for the class in caller's variable
# context so that object copy is transparent (see above):
uplevel 1 $fullClass($classOrId)::_copy $id $classOrId
} else { ;# first argument is a class
# generate constructor name:
set constructor ${classOrId}::[namespace tail $classOrId]
# we could detect here whether class was ever declared but that
# would prevent stooop packages to load properly, because
# constructor would not be invoked and thus class source file never
# sourced
# invoke the constructor for the class with optional arguments in
# caller's variable context so that object creation is transparent
# and that array names as constructor parameters work with a simple
# upvar
# note: if class is in a package, the class namespace code is loaded
# here, as the first object of the class is created
uplevel 1 $constructor [set id [incr newId]] $args
# generate fully qualified class namespace name now that we are sure
# that class namespace code has been invoked:
set fullClass($id) [namespace qualifiers\
[uplevel 1 namespace which -command $constructor]\
]
}
return $id ;# return a unique object identifier
}
_proc delete {args} { ;# delete one or more objects
variable fullClass
foreach id $args {
# destruct in caller's variable context so that object deletion is
# transparent:
uplevel 1 ::stooop::deleteObject $fullClass($id) $id
unset fullClass($id)
}
}
# delete object data starting at specified class layer and going up the base
# class hierarchy if any
# invoke the destructor for the object class and unset all the object data
# members for the class
# the destructor will in turn delete the base classes layers
_proc deleteObject {fullClass id} {
# invoke the destructor for the class in caller's variable context so
# that object deletion is transparent:
uplevel 1 ${fullClass}::~[namespace tail $fullClass] $id
# delete all this object data members if any (assume that they were
# stored as ${class}::($id,memberName)):
array unset ${fullClass}:: $id,*
# data member arrays deletion is left to the user
}
_proc classof {id} {
variable fullClass
return $fullClass($id) ;# return class of object
}
# copy object data members from one object to another:
_proc copy {fullClass from to} {
set index [string length $from]
# copy regular data members:
foreach {name value} [array get ${fullClass}:: $from,*] {
set ${fullClass}::($to[string range $name $index end]) $value
}
# if any, array data members copy is left to the class programmer
# through the then mandatory copy constructor
}
}
_proc ::stooop::class {args} {
variable declared
set class [lindex $args 0]
# register class using its fully qualified name:
set declared([uplevel 1 namespace eval $class {namespace current}]) {}
# create the empty name array used to hold all class objects so that static
# members can be directly initialized within the class declaration but
# outside member procedures
uplevel 1 namespace eval $class [list "::variable {}\n[lindex $args end]"]
}
# if procedure is a member of a known class, class and procedure names are set
# and true is returned, otherwise false is returned:
_proc ::stooop::parseProcedureName {\
namespace name fullClassVariable procedureVariable messageVariable\
} {
# namespace argument is the current namespace (fully qualified) in which the
# procedure is defined
variable declared
upvar 1 $fullClassVariable fullClass $procedureVariable procedure\
$messageVariable message
if {\
[info exists declared($namespace)]&&\
([string length [namespace qualifiers $name]]==0)\
} {
# a member procedure is being defined inside a class namespace
set fullClass $namespace
set procedure $name ;# member procedure name is full name
return 1
} else {
# procedure is either a member of a known class or a regular procedure
if {![string match ::* $name]} {
# eventually fully qualify procedure name
if {[string equal $namespace ::]} { ;# global namespace special case
set name ::$name
} else {
set name ${namespace}::$name
}
}
# eventual class name is leading part:
set fullClass [namespace qualifiers $name]
if {[info exists declared($fullClass)]} { ;# if class is known
set procedure [namespace tail $name] ;# procedure always is the tail
return 1
} else { ;# not a member procedure
if {[string length $fullClass]==0} {
set message "procedure $name class name is empty"
} else {
set message "procedure $name class $fullClass is unknown"
}
return 0
}
}
}
# virtual operator, to be placed before proc
# virtualize a member procedure, determine whether it is a pure virtual, check
# for procedures that cannot be virtualized
_proc ::stooop::virtual {keyword name arguments args} {
# set a flag so that proc knows it is acting upon a virtual procedure, also
# serves as a pure indicator:
variable pureVirtual
if {![string equal [uplevel 1 namespace which -command $keyword] ::proc]} {
error "virtual operator works only on proc, not $keyword"
}
if {![parseProcedureName\
[uplevel 1 namespace current] $name fullClass procedure message\
]} {
error $message ;# not in a member procedure definition
}
set class [namespace tail $fullClass]
if {[string equal $class $procedure]} {
error "cannot make class $fullClass constructor virtual"
}
if {[string equal ~$class $procedure]} {
error "cannot make class $fullClass destructor virtual"
}
if {![string equal [lindex $arguments 0] this]} {
error "cannot make static procedure $procedure of class $fullClass virtual"
}
# no procedure body means pure virtual:
set pureVirtual [expr {[llength $args]==0}]
# process procedure declaration, body being empty for pure virtual procedure
# make virtual transparent by using uplevel:
uplevel 1 ::proc [list $name $arguments [lindex $args 0]]
unset pureVirtual
}
_proc proc {name arguments args} {
if {![::stooop::parseProcedureName\
[uplevel 1 namespace current] $name fullClass procedure message\
]} {
# not in a member procedure definition, fall back to normal procedure
# declaration
# uplevel is required instead of eval here otherwise tcl seems to forget
# the procedure namespace if it exists
uplevel 1 _proc [list $name $arguments] $args
return
}
if {[llength $args]==0} { ;# check for procedure body presence
error "missing body for ${fullClass}::$procedure"
}
set class [namespace tail $fullClass]
if {[string equal $class $procedure]} { ;# class constructor definition
if {![string equal [lindex $arguments 0] this]} {
error "class $fullClass constructor first argument must be this"
}
if {[string equal [lindex $arguments 1] copy]} {
# user defined copy constructor definition
if {[llength $arguments]!=2} {
error "class $fullClass copy constructor must have 2 arguments exactly"
}
# make sure of proper declaration order:
if {[catch {info body ::${fullClass}::$class}]} {
error "class $fullClass copy constructor defined before constructor"
}
eval ::stooop::constructorDeclaration\
$fullClass $class 1 \{$arguments\} $args
} else { ;# main constructor
eval ::stooop::constructorDeclaration\
$fullClass $class 0 \{$arguments\} $args
# always generate default copy constructor:
::stooop::generateDefaultCopyConstructor $fullClass
}
} elseif {[string equal ~$class $procedure]} {
# class destructor declaration
if {[llength $arguments]!=1} {
error "class $fullClass destructor must have 1 argument exactly"
}
if {![string equal [lindex $arguments 0] this]} {
error "class $fullClass destructor argument must be this"
}
# make sure of proper declaration order
# (use fastest method for testing procedure existence):
if {[catch {info body ::${fullClass}::$class}]} {
error "class $fullClass destructor defined before constructor"
}
::stooop::destructorDeclaration\
$fullClass $class $arguments [lindex $args 0]
} else {
# regular member procedure, may be static if there is no this first
# argument
# make sure of proper declaration order:
if {[catch {info body ::${fullClass}::$class}]} {
error "class $fullClass member procedure $procedure defined before constructor"
}
::stooop::memberProcedureDeclaration\
$fullClass $class $procedure $arguments [lindex $args 0]
}
}
# copy flag is set for user defined copy constructor:
_proc ::stooop::constructorDeclaration {fullClass class copy arguments args} {
variable check
variable fullBases
variable variable
set number [llength $args]
# check that each base class constructor has arguments:
if {($number%2)==0} {
error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing"
}
if {[string equal [lindex $arguments end] args]} {
# remember that there is a variable number of arguments in class
# constructor
set variable($fullClass) {}
}
if {!$copy} {
# do not initialize (or reinitialize in case of multiple class file
# source statements) base classes for copy constructor
set fullBases($fullClass) {}
}
# check base classes and their constructor arguments:
foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] {
# fully qualify base class namespace by looking up constructor, which
# must exist
set constructor ${base}::[namespace tail $base]
# in case base class is defined in a file that is part of a package,
# make sure that file is sourced through the tcl package auto-loading
# mechanism by directly invoking the base class constructor while
# ignoring the resulting error
catch {$constructor}
# determine fully qualified base class name in user invocation level
# (up 2 levels from here since this procedure is invoked exclusively by
# proc)
set fullBase [namespace qualifiers\
[uplevel 2 namespace which -command $constructor]\
]
if {[string length $fullBase]==0} { ;# base constructor is not defined
if {[string match *$base $fullClass]} {
# if the specified base class name is included last in the fully
# qualified class name, assume that it was meant to be the same
error "class $fullClass cannot be derived from itself"
} else {
error "class $fullClass constructor defined before base class $base constructor"
}
}
# check and save base classes only for main constructor that defines
# them:
if {!$copy} {
if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} {
error "class $fullClass directly inherits from class $fullBase more than once"
}
lappend fullBases($fullClass) $fullBase
}
# replace new lines with blanks in base arguments part in case user has
# formatted long declarations with new lines
regsub -all {\n} $baseArguments { } constructorArguments($fullBase)
}
# setup access to class data (an empty named array)
# fully qualify tcl variable command for it may have been redefined within
# the class namespace
# since constructor is directly invoked by new, the object identifier must
# be valid, so debugging the procedure is pointless
set constructorBody \
"::variable {}
$check(code)
"
# base class(es) derivation specified:
if {[llength $fullBases($fullClass)]>0} {
# invoke base class constructors before evaluating constructor body
# then set base part hidden derived member so that virtual procedures
# are invoked at base class level as in C++
if {[info exists variable($fullClass)]} {
# variable number of arguments in derived class constructor
foreach fullBase $fullBases($fullClass) {
if {![info exists constructorArguments($fullBase)]} {
error "missing base class $fullBase constructor arguments from class $fullClass constructor"
}
set baseConstructor ${fullBase}::[namespace tail $fullBase]
if {\
[info exists variable($fullBase)]&&\
([string first {$args} $constructorArguments($fullBase)]>=0)\
} {
# variable number of arguments in base class constructor and
# in derived class base class constructor arguments
# use eval so that base class constructor sees arguments
# instead of a list
# only the last argument of the base class constructor
# arguments is considered as a variable list
# (it usually is $args but could be a procedure invocation,
# such as [filter $args])
# fully qualify tcl commands such as set, for they may have
# been redefined within the class namespace
append constructorBody \
"::set _list \[::list $constructorArguments($fullBase)\]
::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\]
::unset _list
::set ${fullBase}::(\$this,_derived) $fullClass
"
} else {
# no special processing needed
# variable number of arguments in base class constructor or
# variable arguments list passed as is to base class
# constructor
append constructorBody \
"$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
}
}
} else { ;# constant number of arguments
foreach fullBase $fullBases($fullClass) {
if {![info exists constructorArguments($fullBase)]} {
error "missing base class $fullBase constructor arguments from class $fullClass constructor"
}
set baseConstructor ${fullBase}::[namespace tail $fullBase]
append constructorBody \
"$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
}
}
} ;# else no base class derivation specified
if {$copy} {
# for user defined copy constructor, copy derived class member if it
# exists
append constructorBody \
"::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)}
"
}
# finally append user defined procedure body:
append constructorBody [lindex $args end]
if {$copy} {
_proc ${fullClass}::_copy $arguments $constructorBody
} else {
_proc ${fullClass}::$class $arguments $constructorBody
}
}
_proc ::stooop::destructorDeclaration {fullClass class arguments body} {
variable check
variable fullBases
# setup access to class data
# since the object identifier is always valid at this point, debugging the
# procedure is pointless
set body \
"::variable {}
$check(code)
$body
"
# if there are any, delete base classes parts in reverse order of
# construction
for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}\
{incr index -1}\
{
set fullBase [lindex $fullBases($fullClass) $index]
append body \
"::stooop::deleteObject $fullBase \$this
"
}
_proc ${fullClass}::~$class $arguments $body
}
_proc ::stooop::memberProcedureDeclaration {\
fullClass class procedure arguments body\
} {
variable check
variable pureVirtual
if {[info exists pureVirtual]} { ;# virtual declaration
if {$pureVirtual} { ;# pure virtual declaration
# setup access to class data
# evaluate derived procedure which must exists. derived procedure
# return value is automatically returned
_proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]
"
} else { ;# regular virtual declaration
# setup access to class data
# evaluate derived procedure and return if it exists
# else evaluate the base class procedure which can be invoked from
# derived class procedure by prepending _
_proc ${fullClass}::_$procedure $arguments \
"::variable {}
$check(code)
$body
"
_proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} {
::return \[::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel 1 ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\]
"
}
} else { ;# non virtual declaration
# setup access to class data:
_proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
$body
"
}
}
# generate default copy procedure which may be overriden by the user for any
# class layer:
_proc ::stooop::generateDefaultCopyConstructor {fullClass} {
variable fullBases
# generate code for cloning base classes layers if there is at least one
# base class
foreach fullBase $fullBases($fullClass) {
append body \
"${fullBase}::_copy \$this \$sibling
"
}
append body \
"::stooop::copy $fullClass \$sibling \$this
"
_proc ${fullClass}::_copy {this sibling} $body
}
if {[llength [array names ::env STOOOP*]]>0} {
# if one or more environment variables are set, we are in debugging mode
# gracefully handle multiple sourcing of this file:
catch {rename ::stooop::class ::stooop::_class}
# use a new class procedure instead of adding debugging code to existing one
_proc ::stooop::class {args} {
variable trace
variable check
set class [lindex $args 0]
if {$check(data)} {
# check write and unset operations on empty named array holding
# class data
uplevel 1 namespace eval $class\
[list {::trace variable {} wu ::stooop::checkData}]
}
if {[info exists ::env(STOOOPTRACEDATA)]} {
# trace write and unset operations on empty named array holding
# class data
uplevel 1 namespace eval $class [list\
"::trace variable {} $trace(dataOperations) ::stooop::traceData"\
]
}
uplevel 1 ::stooop::_class $args
}
if {$::stooop::check(procedures)} {
# prevent the creation of any object of a pure interface class
# use a new virtual procedure instead of adding debugging code to
# existing one
# gracefully handle multiple sourcing of this file:
catch {rename ::stooop::virtual ::stooop::_virtual}
# keep track of interface classes (which have at least 1 pure virtual
# procedure):
_proc ::stooop::virtual {keyword name arguments args} {
variable interface
uplevel 1 ::stooop::_virtual [list $keyword $name $arguments] $args
parseProcedureName [uplevel 1 namespace current] $name\
fullClass procedure message
if {[llength $args]==0} { ;# no procedure body means pure virtual
set interface($fullClass) {}
}
}
}
if {$::stooop::check(objects)} {
_proc invokingProcedure {} {
if {[catch {set procedure [lindex [info level -2] 0]}]} {
# no invoking procedure
return {top level}
} elseif {\
([string length $procedure]==0)||\
[string equal $procedure namespace]\
} { ;# invoked from a namespace body
return "namespace [uplevel 2 namespace current]"
} else {
# store fully qualified name, visible from creator procedure
# invoking procedure
return [uplevel 3 namespace which -command $procedure]
}
}
}
if {$::stooop::check(procedures)||$::stooop::check(objects)} {
# gracefully handle multiple sourcing of this file:
catch {rename ::stooop::new ::stooop::_new}
# use a new new procedure instead of adding debugging code to existing
# one:
_proc ::stooop::new {classOrId args} {
variable newId
variable check
if {$check(procedures)} {
variable fullClass
variable interface
}
if {$check(objects)} {
variable creator
}
if {$check(procedures)} {
if {[string is integer $classOrId]} {
# first argument is an object identifier
# class code, if from a package, must already be loaded
set fullName $fullClass($classOrId)
} else { ;# first argument is a class
# generate constructor name:
set constructor ${classOrId}::[namespace tail $classOrId]
# force loading in case class is in a package so namespace
# commands work properly:
catch {$constructor}
set fullName [namespace qualifiers\
[uplevel 1 namespace which -command $constructor]\
]
# anticipate full class name storage in original new{} in
# order to avoid invalid object identifier error in
# checkProcedure{} when member procedure is invoked from
# within contructor, in which case full class name would
# have yet to be stored.
set fullClass([expr {$newId+1}]) $fullName
# new identifier is really incremented in original new{}
}
if {[info exists interface($fullName)]} {
error "class $fullName with pure virtual procedures should not be instanciated"
}
}
if {$check(objects)} {
# keep track of procedure in which creation occured (new
# identifier is really incremented in original new{})
set creator([expr {$newId+1}]) [invokingProcedure]
}
return [uplevel 1 ::stooop::_new $classOrId $args]
}
}
if {$::stooop::check(objects)} {
_proc ::stooop::delete {args} {
variable fullClass
variable deleter
# keep track of procedure in which deletion occured:
set procedure [invokingProcedure]
foreach id $args {
uplevel 1 ::stooop::deleteObject $fullClass($id) $id
unset fullClass($id)
set deleter($id) $procedure
}
}
}
# return the unsorted list of ancestors in class hierarchy:
_proc ::stooop::ancestors {fullClass} {
variable ancestors ;# use a cache for efficiency
variable fullBases
if {[info exists ancestors($fullClass)]} {
return $ancestors($fullClass) ;# found in the cache
}
set list {}
foreach class $fullBases($fullClass) {
set list [concat $list [list $class] [ancestors $class]]
}
set ancestors($fullClass) $list ;# save in cache
return $list
}
# since this procedure is always invoked from a debug procedure, take the
# extra level in the stack frame into account
# parameters (passed as references) that cannot be determined are not set
_proc ::stooop::debugInformation {\
className fullClassName procedureName fullProcedureName\
thisParameterName\
} {
upvar 1 $className class $fullClassName fullClass\
$procedureName procedure $fullProcedureName fullProcedure\
$thisParameterName thisParameter
variable declared
set namespace [uplevel 2 namespace current]
# not in a class namespace:
if {[lsearch -exact [array names declared] $namespace]<0} return
# remove redundant global qualifier:
set fullClass [string trimleft $namespace :]
set class [namespace tail $fullClass] ;# class name
set list [info level -2]
set first [lindex $list 0]
if {([llength $list]==0)||[string equal $first namespace]}\
return ;# not in a procedure, nothing else to do
set procedure $first
# procedure must be known at the invoker level:
set fullProcedure [uplevel 3 namespace which -command $procedure]
set procedure [namespace tail $procedure] ;# strip procedure name
if {[string equal $class $procedure]} { ;# constructor
set procedure constructor
} elseif {[string equal ~$class $procedure]} { ;# destructor
set procedure destructor
}
if {[string equal [lindex [info args $fullProcedure] 0] this]} {
# non static procedure
# object identifier is first argument:
set thisParameter [lindex $list 1]
}
}
# check that member procedure is valid for object passed as parameter:
_proc ::stooop::checkProcedure {} {
variable fullClass
debugInformation class qualifiedClass procedure qualifiedProcedure this
# static procedure, no checking possible:
if {![info exists this]} return
# in constructor, checking useless since object is not yet created:
if {[string equal $procedure constructor]} return
if {![info exists fullClass($this)]} {
error "$this is not a valid object identifier"
}
set fullName [string trimleft $fullClass($this) :]
# procedure and object classes match:
if {[string equal $fullName $qualifiedClass]} return
# restore global qualifiers to compare with internal full class array
# data
if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} {
error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName"
}
}
# gather current procedure data, perform substitutions and output to trace
# channel:
_proc ::stooop::traceProcedure {} {
variable trace
debugInformation class qualifiedClass procedure qualifiedProcedure this
# all debug data is available since we are for sure in a class procedure
set text $trace(procedureFormat)
regsub -all %C $text $qualifiedClass text ;# fully qualified class name
regsub -all %c $text $class text
# fully qualified procedure name:
regsub -all %P $text $qualifiedProcedure text
regsub -all %p $text $procedure text
if {[info exists this]} { ;# non static procedure
regsub -all %O $text $this text
# remaining arguments:
regsub -all %a $text [lrange [info level -1] 2 end] text
} else { ;# static procedure
regsub -all %O $text {} text
# remaining arguments:
regsub -all %a $text [lrange [info level -1] 1 end] text
}
puts $trace(procedureChannel) $text
}
# check that class data member is accessed within procedure of identical
# class
# then if procedure is not static, check that only data belonging to the
# object passed as parameter is accessed
_proc ::stooop::checkData {array name operation} {
scan $name %u,%s identifier member
# ignore internally defined members:
if {[info exists member]&&[string equal $member _derived]} return
debugInformation class qualifiedClass procedure qualifiedProcedure this
# no checking can be done outside of a class namespace:
if {![info exists class]} return
# determine array full name:
set array [uplevel 1 [list namespace which -variable $array]]
if {![info exists procedure]} { ;# inside a class namespace
# compare with empty named array fully qualified name:
if {![string equal $array ::${qualifiedClass}::]} {
# trace command error message is automatically prepended and
# indicates operation
error\
"class access violation in class $qualifiedClass namespace"
}
return ;# done
}
# ignore internal copy procedure:
if {[string equal $qualifiedProcedure ::stooop::copy]} return
if {![string equal $array ::${qualifiedClass}::]} {
# compare with empty named array fully qualified name
# trace command error message is automatically prepended and
# indicates operation
error "class access violation in procedure $qualifiedProcedure"
}
# static procedure, all objects can be accessed:
if {![info exists this]} return
# static data members can be accessed:
if {![info exists identifier]} return
# check that accessed data belongs to this object:
if {$this!=$identifier} {
error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this"
}
}
# gather accessed data member information, perform substitutions and output
# to trace channel
_proc ::stooop::traceData {array name operation} {
variable trace
scan $name %u,%s identifier member
# ignore internally defined members:
if {[info exists member]&&[string equal $member _derived]} return
# ignore internal destruction:
if {\
![catch {lindex [info level -1] 0} procedure]&&\
[string equal ::stooop::deleteObject $procedure]\
} return
set class {} ;# in case we are outside a class
set qualifiedClass {}
set procedure {} ;# in case we are outside a class procedure
set qualifiedProcedure {}
debugInformation class qualifiedClass procedure qualifiedProcedure this
set text $trace(dataFormat)
regsub -all %C $text $qualifiedClass text ;# fully qualified class name
regsub -all %c $text $class text
if {[info exists member]} {
regsub -all %m $text $member text
} else {
regsub -all %m $text $name text ;# static member
}
# fully qualified procedure name:
regsub -all %P $text $qualifiedProcedure text
regsub -all %p $text $procedure text
# fully qualified array name with global qualifiers stripped:
regsub -all %A $text [string trimleft\
[uplevel 1 [list namespace which -variable $array]] :\
] text
if {[info exists this]} { ;# non static procedure
regsub -all %O $text $this text
} else { ;# static procedure
regsub -all %O $text {} text
}
array set string {r read w write u unset}
regsub -all %o $text $string($operation) text
if {[string equal $operation u]} {
regsub -all %v $text {} text ;# no value when unsetting
} else {
regsub -all %v $text [uplevel 1 set ${array}($name)] text
}
puts $trace(dataChannel) $text
}
if {$::stooop::check(objects)} {
# print existing objects along with creation procedure, with optional
# class pattern (see the string Tcl command manual)
_proc ::stooop::printObjects {{pattern *}} {
variable fullClass
variable creator
puts "stooop::printObjects invoked from [invokingProcedure]:"
foreach id [lsort -integer [array names fullClass]] {
if {[string match $pattern $fullClass($id)]} {
puts "$fullClass($id)\($id\) + $creator($id)"
}
}
}
# record all existing objects for later report:
_proc ::stooop::record {} {
variable fullClass
variable checkpointFullClass
puts "stooop::record invoked from [invokingProcedure]"
catch {unset checkpointFullClass}
array set checkpointFullClass [array get fullClass]
}
# print all new or deleted object since last record, with optional class
# pattern:
_proc ::stooop::report {{pattern *}} {
variable fullClass
variable checkpointFullClass
variable creator
variable deleter
puts "stooop::report invoked from [invokingProcedure]:"
set checkpointIds [lsort -integer [array names checkpointFullClass]]
set currentIds [lsort -integer [array names fullClass]]
foreach id $currentIds {
if {\
[string match $pattern $fullClass($id)]&&\
([lsearch -exact $checkpointIds $id]<0)\
} {
puts "+ $fullClass($id)\($id\) + $creator($id)"
}
}
foreach id $checkpointIds {
if {\
[string match $pattern $checkpointFullClass($id)]&&\
([lsearch -exact $currentIds $id]<0)\
} {
puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)"
}
}
}
}
}
