home *** CD-ROM | disk | FTP | other *** search
/ CyberMycha 2006 April / SGP.iso / dema / Keepsake-Demo-en-li-v1.0.exe / res / bin / prime / stooop.tcl < prev    next >
Text File  |  2005-09-26  |  40KB  |  939 lines
  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$
  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. }
  939.