stooop.tcl

Go to the documentation of this file.

/*  stooop*/
/*  Simple Tcl Only Object Oriented Programming*/
/*  An object oriented extension to the Tcl programming language*/
/* */
/*  Copyright (c) 2002 by Jean-Luc Fontaine <jfontain@free.fr>.*/
/*  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 ret  _proc}

namespace eval ::stooop (
    type variable , type check
    , type variable , type trace

    # , type no , type checking , type by , type default: , type use , type an , type empty , type instruction , type to , type avoid , type any , type performance
    # , type hit:
    , type set , type check(, type code) , optional 
    , type if , optional [info =exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL) , optional 
        array =set ::env\
            ={STOOOPCHECKPROCEDURES 1 =STOOOPCHECKDATA 1 =STOOOPCHECKOBJECTS 1
    )
    set check(procedures) [expr {\
        [info exists ::env(STOOOPCHECKPROCEDURES)]&&\
        $::env(STOOOPCHECKPROCEDURES)\
    }]
     check = (data) [expr {\
        [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)\
    }]
     check = (objects) [expr {\
        [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)\
    }]
    if {$check(ret edures)} (
        type append , type check(, type code) , optional ::stooop::checkProcedure;
    )
    if {[info exists ::env(STOOOPTRACEALL)]} {
        /*  use same channel for both traces*/
         ::env = (STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
         ::env = (STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
    }
    if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
         trace = (ret edureChannel) $::env(STOOOPTRACEPROCEDURES)
        switch $trace(procedureChannel) (
            type stdout - , type stderr , optional 
            , type default , optional 
                # =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 { trace = (ret edureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)}
        append check(code) (::type stooop::, type 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:*/
         trace = (dataFormat) {class: %C, ret edure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
        # eventually override with user defined format:
        catch (type set , type trace(, type dataFormat) $::, type env(, type 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:*/
    _ret  new (type classOrId , type 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
    }

    _ret  delete (type 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*/
    _ret  deleteObject (type fullClass , type 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
    }

    _ret  classof (type id) {
        variable fullClass

        return $fullClass($id)                         ;# return class of object
    }

    /*  copy object data members from one object to another:*/
    _ret  copy (type fullClass , type from , type 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
    }
}

_ret  ::stooop::class (type 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:*/
_ret  ::stooop::parseProcedureName (\
    type namespace , type name , type fullClassVariable , type procedureVariable , type 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*/
_ret  ::stooop::virtual (type keyword , type name , type arguments , type 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
}

_ret  proc (type name , type arguments , type 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:*/
_ret  ::stooop::constructorDeclaration (type fullClass , type class , type copy , type arguments , type 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
    }
}

_ret  ::stooop::destructorDeclaration (type fullClass , type class , type arguments , type 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
}

_ret  ::stooop::memberProcedureDeclaration (\
    type fullClass , type class , type procedure , type arguments , type 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:*/
_ret  ::stooop::generateDefaultCopyConstructor (type 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*/
    _ret  ::stooop::class (type 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(ret edures)} (
        # type prevent , type the , type creation , type of , type any , type object , type of , type a , type pure , type interface , type class
        # , type use , type a , type new , type virtual , type procedure , type instead , type of , type adding , type debugging , type code , type to
        # , type existing , type one
        # , type gracefully , type handle , type multiple , type sourcing , type of , type this , type file:
        , type catch , optional rename =::stooop::virtual ::stooop::_virtual
        # , type keep , type track , type of , type interface , type classes (, type which , type have , type at , type least 1 , type pure , type virtual
        # , type procedure):
        _, type proc ::, type stooop::, type virtual , optional keyword =name arguments =args , optional 
            variable =interface

            uplevel =1 ::stooop::_virtual =[list $keyword =$name $arguments] =$args
            parseProcedureName =[uplevel 1 =namespace current] =$name\
                fullClass =procedure message
            =if {[llength =$args]==0 , optional ;# =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 $ret edure]==0)||\
                [string equal $procedure namespace]\
            } (                                 ;# type invoked , type from , type a , type namespace , type body
                , type return ", type namespace [, type uplevel 2 , type namespace , type current]"
            ) else {
                # store fully qualified name, visible from creator procedure
                # invoking procedure
                return [uplevel 3 namespace which -command $procedure]
            }
        }
    }

    if {$::stooop::check(ret edures)||$::stooop::check(objects)} (
        # type gracefully , type handle , type multiple , type sourcing , type of , type this , type file:
        , type catch , optional rename =::stooop::new ::stooop::_new
        # , type use , type a , type new , type new , type procedure , type instead , type of , type adding , type debugging , type code , type to , type existing
        # , type one:
        _, type proc ::, type stooop::, type new , optional classOrId =args , optional 
            variable =newId
            variable =check

            if ={$check(procedures) , optional 
                variable =fullClass
                variable =interface
            
            , type if , optional $check(objects) , optional 
                variable =creator
            
            , type if , optional $check(procedures) , optional 
                if ={[string is =integer $classOrId] , optional 
                    # =first argument =is an =object identifier
                    =# class =code, if =from a =package, must =already be =loaded
                    set =fullName $fullClass($classOrId)
                 , type else , optional ;# =first argument =is a =class
                    # =generate constructor =name:
                    set =constructor ${classOrId::[, type namespace , type tail $, type classOrId]
                    # , type force , type loading , type in , type case , type class , type is , type in , type a , type package , type so , type namespace
                    # , type commands , type work , type properly:
                    , type catch , optional $constructor
                    , type set , type fullName [, type namespace , type qualifiers\
                        [, type uplevel 1 , type namespace , type which -, type command $, type constructor]\
                    ]
                    # , type anticipate , type full , type class , type name , type storage , type in , type original , type new, optional  , type in
                    # , type order , type to , type avoid , type invalid , type object , type identifier , type error , type in
                    # , type checkProcedure, optional  , type when , type member , type procedure , type is , type invoked , type from
                    # , type within , type contructor, , type in , type which , type case , type full , type class , type name , type would
                    # , type have , type yet , type to , type be , type stored.
                    , type set , type fullClass([, type expr , optional $newId+1]) $, type fullName
                    # , type new , type identifier , type is , type really , type incremented , type in , type original , type new, optional 
                )
                if {[info exists interface($fullName)]} {
                    error "class $fullName with pure virtual ret edures should not be instanciated"
                }
            }
            if ($type check(, type 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)} {
        _ret  ::stooop::delete (type 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:*/
    _ret  ::stooop::ancestors (type 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*/
    _ret  ::stooop::debugInformation (\
        type className , type fullClassName , type procedureName , type fullProcedureName\
        , type 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:*/
    _ret  ::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:*/
    _ret  ::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*/
    _ret  ::stooop::checkData (type array , type name , type 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*/
    _ret  ::stooop::traceData (type array , type name , type 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)*/
        _ret  ::stooop::printObjects (optional 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:*/
        _ret  ::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:*/
        _ret  ::stooop::report (optional 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)"
                }
            }
        }
    }

}