Tcl Source Code

Artifact 0cbba2273ec7237d44cf3fbb71682cadf78bd8b9:

#!/usr/bin/env tclsh

package require Tcl 8.5.1
package require TclOO
tcl::mathfunc::srand 0x12345678

namespace eval tstoo {}

proc msg args {}
#proc msg args {puts {*}$args}

proc randint {range} {
    expr {int($range * rand())}
}

proc randname {} {
    set k 10
    while {[incr k -1] >= 0} {
        append name [string index "abcdefghijklmnopqrstuvwxyz" [randint 26]]
    }
    return $name
}

proc randclass {} {
    namespace eval [set ns [randname]] {}
    oo::class create ${ns}::[randname] {
        constructor {} {
            my variable foo opt
            set foo [self]
            array set opt {
                foo jsdhgjk
                bar kjhls
                zap jhdhjl
            }
            set opt(page) [string repeat [randint 10] 4096]
            msg "[self] new"
        }
        destructor {
            my variable opt
            unset opt
            msg "[self] destroy ([namespace current])"
            #namespace delete [namespace current]
        }
        method bar {} {
            my variable foo opt
            msg "my name: [self] == $foo"
        }
    }
}

proc main {} {
    set nClassesCreate 10
    set nClassesDestroy 5
    set nInstancesCreate 10
    set nInstancesDestroy 2

    set iterations 100
    while {[incr iterations -1] >= 0} {
        set k $nClassesCreate
        while {[incr k -1] >= 0} {

            set name [randclass]
            lappend classList $name
            msg "name=$name"
            msg [info commands [namespace qualifiers $name]::*]

            set j $nInstancesCreate
            while {[incr j -1] >= 0} {
                set inst [$name new]
                lappend instList($name) $inst
                $inst bar
            }
        }

        #msg $classList
        #msg [array get instList]
        #msg ""

        if {[randint 2]} {
            set j $nInstancesDestroy
            while {[incr j -1] >= 0} {
                set name [lindex $classList [randint [llength $classList]]]
                set i [randint [llength $instList($name)]]
                set inst [lindex $instList($name) $i]
                set instList($name) [lreplace $instList($name) $i $i]
                $inst destroy
            }
        } else {
            set k $nClassesDestroy
            while {[incr k -1] >= 0} {
                set i [randint [llength $classList]]
                set name [lindex $classList $i]
                set classList [lreplace $classList $i $i]
                unset instList($name)
                $name destroy
                namespace delete [namespace qualifiers $name]
            }
        }
        #msg $classList
        #msg [array get instList]
        #msg ""
    }

    msg [info commands ::oo::*]
    msg [info commands ::tstoo::*]
    msg [namespace children ::]

    while {[llength $classList] > 0} {
        if {[randint 2]} {
            set j $nInstancesDestroy
            while {[incr j -1] >= 0} {
                set name [lindex $classList [randint [llength $classList]]]
                set i [randint [llength $instList($name)]]
                set inst [lindex $instList($name) $i]
                set instList($name) [lreplace $instList($name) $i $i]
                $inst destroy
            }
        } else {
            set k $nClassesDestroy
            while {[incr k -1] >= 0} {
                set i [randint [llength $classList]]
                set name [lindex $classList $i]
                set classList [lreplace $classList $i $i]
                unset instList($name)
                $name destroy
                namespace delete [namespace qualifiers $name]
            }
        }
    }

    puts [array get instList]
    puts [info commands ::oo::*]
    puts [namespace children ::]

}

main
proc exit args {}
return