# gmlObject.tcl -- # # Implements an object mechanism in Tcl. # # Copyright (c) 2001-2005 LIG/IIHM # # See the file "gml_LicenseTerms.txt" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Version 1.072, Oct. 2, 2007: FB # Added method "setAttribute" to gmlObjRootClass. # # Version 1.071, Aug. 29, 2005: FB # "gmlObject info methods" now prefixes inherited method by the <name of the supperclass>:: # # Version 1.07, Sept. 4, 2004: FB # Call to the constructor is no more protected in a catch: errors are reported immediately # without trying to cleanup the partially constructed object. # # Version 1.06, July 30, 2004: FB # WARNING! Icompatibility: the destructor is now called even if the call to the # constructor failed. # # Version 1.05, July 27, 2004: FB # Added "newName" method to gmlObjRootClass. # # Version 1.04, June 23, 2004: FB # Added "attribute" method to gmlObjRootClass. # Now correctly handles strange object name such as containing spaces. # # Version 1.033, March 1, 2004: FB # Classes and objects can now be renamed with the "rename" tcl command. # # Version 1.032, December 1, 2003: FB # Added "gmlObject info objects all" # # Version 1.031, October 1, 2003: FB # Corrected a bug that prevented "gmlObject info class" and "gmlObject info interface" # to work. # # Version 1.03, September 22, 2003: FB # Corrected a bug in "gmlObject info classes <className>" that would provoque an error. # Completed "gmlObject info class <className>" to include inherit commands. # Completed "gmlObject info methods (<className> | <objName)" to accept objects (used to # accept only classes. # "gmlObject info methods ..." now returns a list containing inherited methods (used to return # only the class methods). The same list is included in the error message when calling a # non-existant method on an object. # # Version 1.02, April 13, 2003: FB # Better "errorInfo" handling: # When a constructor or a destructor generates an error, the call stack # is correctly stored in the global variable errorInfo. # # "inherit" inserts superclasses in the head of the list so # that the last inherited class are searched first for # inherited methods. # # "inherit" silently returns when inheriting from a class that # is already an ancestor (it used to report an error in this case). # # Fixed and changed the "inherited" method mechanism: # The "inherited" method can only be called in the context of a # specialized method and on the object "this". Thus it is no longer necessary # to specify the name of the inherited method because it is the name of # the calling method. Example of a call: "this inherited x y z". # # Added the "unknown" method mechanism: # when an unknown method is called on an object, it is replaced by a call to # the "unknown" method. The name of the unknown method is placed at the head # of the arguments. # For example: object "O" has no method "m". The call "O m x y z" is # replaced by the call "O unknown m x y z". # By default, every object inherits from "gmlObjRootClass" "unknown" method # that simply reports an error. # # Version 1.01, Januray 25, 2003: FB # added the possibility to specify a base class on method calls: # "objName aBaseClass::methodName ..." # "inherit" now auto-loads the definition file of the superclass # if it is not yet defined when "inherit" is called. # # Version 1.0, March 14, 2002: FB # # Created on December 28, 2001 (FB). # Side effects: # # Function (re)definitions: # method # inherit # this # gmlObjInit # gmlObjDestroy # gmlObjClassExists # gmlObjObjectExists # gmlObjMethodExists # gmlObjNewClass # gmlObjDeleteClass # gmlObjNewObject # gmlObjDeleteObject # gmlObjDeleteMethod # gmlObjRenameEntity # gmlObject # gmlObject_delete # gmlObject_info # gmlObjObjectDispatch # gmlObjFindMethod # gmlObjIsAncestor # gmlObjBuildClassList # gmlObjBuildMethodList # one function for every method, the name of the function is # "gmlObj_" followed by the class name (class methods) or the object name (object methods), # followed by underscore ("_"), followed by the method name. # For example for the method named "method" of the class named "class": # "gmlObj_class_method" # # Global variable definitions: # gmlObject # one variable for every object, the name of the variable is the name of the object. # one variable for every class, the name of the variable is the name of the class. proc gmlObjInit {} { global gmlObject if { ![info exists gmlObject] } { set gmlObject(classes) [list] # gmlObjRootClass::dispose -- # # Destroy the object. method gmlObjRootClass dispose {} { gmlObject delete object $objName } # gmlObjRootClass::attribute -- # # Returns the value of the object attribute named <name>. method gmlObjRootClass attribute { name } { return $this($name) } # gmlObjRootClass::setAttribute -- # # Set the value of object's attribute <name> to <value>. method gmlObjRootClass setAttribute { name value } { return [set this($name) $value] } # gmlObjRootClass::attributes -- # # Returns the value of the object attributes which names are # in the list <args>. method gmlObjRootClass attributes { args } { set res [list] foreach attribute $args { lappend res $this($attribute) } return $res } # gmlObjRootClass::newName -- # # Creates a new object that is a new name for this object (the base object) and name it <name>. # A new name object shares its state with the base object. The only difference # between the base object and the new name object is when disposing: # disposing the new name object does not affect the base object. # disposing the base object disposes all its new name objects. # A new name object can act as a base objects to its own new names. method gmlObjRootClass newName { name } { gmlObjNewObject $objName [gmlObject info classofobject $objName] $name } # gmlObjRootClass::unknown -- # # The "unknown" method is called when an undefined method is called on this object. # The name of the undefined method is passed in the <method> argument, and the # call arguments are concatened in the <args> argument. method gmlObjRootClass unknown { method args } { global gmlObject error "invalid method name \"$method\": should be one of \"[gmlObjBuildMethodList [gmlObject info classofobject $objName]]\"" } } } proc gmlObjDestroy {} { global gmlObject if { [info exists gmlObject] } { if { [info exists gmlObject(classes)] } { foreach tmpClass $gmlObject(classes) { if { [catch { gmlObjDeleteClass $tmpClass } tmpRes] } { puts stderr "gmlObjDestroy: WARNING, could not delete class \"$tmpClass\": $tmpRes" } } } unset gmlObject } foreach tmpFunction [list \ method \ inherit \ this \ gmlObjInit \ gmlObjDestroy \ gmlObjClassExists \ gmlObjObjectExists \ gmlObjMethodExists \ gmlObjNewClass \ gmlObjDeleteClass \ gmlObjNewObject \ gmlObjDeleteObject \ gmlObjDeleteMethod \ gmlObjRenameEntity \ gmlObject \ gmlObject_delete \ gmlObject_info \ gmlObjObjectDispatch \ gmlObjFindMethod \ gmlObjIsAncestor \ gmlObjBuildClassList \ gmlObjBuildMethodList \ ] { if { [catch { rename $tmpFunction {} } tmpRes] } { puts stderr "gmlObjDestroy: WARNING, could not delete function \"$tmpFunction\": $tmpRes" } } return } proc gmlObjClassExists { className } { global gmlObject return [info exists gmlObject(class,$className,classes)] } proc gmlObjObjectExists { objName } { global gmlObject return [info exists gmlObject(object,$objName,class)] } proc gmlObjMethodExists { className methodName } { global gmlObject return [info exists gmlObject(class,$className,method,$methodName)] } proc gmlObjNewClass { className } { global gmlObject upvar #0 $className class if { [info exists class] } { error "could not create class \"$className\": a global variable with that name already exists" } if { [llength [info command $className]] } { error "could not create class \"$className\": a command with that name already exists" } set gmlObject(class,$className,objects) [list] set gmlObject(class,$className,methods) [list] set gmlObject(class,$className,classes) [list] set gmlObject(class,$className,specializations) [list] proc $className { args } "return \[uplevel gmlObjNewObject [list [list {}]] $className \$args\]" lappend gmlObject(classes) $className if { ![string equal $className gmlObjRootClass] } { inherit $className gmlObjRootClass } trace add command $className rename "gmlObjRenameEntity class" return } proc gmlObjDeleteClass { className } { global gmlObject upvar #0 $className class trace remove command $className rename "gmlObjRenameEntity class" set tmpIdx [lsearch -exact $gmlObject(classes) $className] if { $tmpIdx != -1 } { # remove this class as a specialization of its parent classes foreach tmpSuperName $gmlObject(class,$className,classes) { set tmpIdx2 [lsearch -exact $gmlObject(class,$tmpSuperName,specializations) $className] if { $tmpIdx2 != -1 } { set gmlObject(class,$tmpSuperName,specializations) \ [lreplace $gmlObject(class,$tmpSuperName,specializations) $tmpIdx2 $tmpIdx2] } } # delete all objects of this class foreach tmpObjName $gmlObject(class,$className,objects) { if { [catch { gmlObjDeleteObject $tmpObjName } tmpRes] } { puts stderr "gmlObjDeleteClass WARNING, while deleting object \"$tmpObjName\": $tmpRes" } } unset gmlObject(class,$className,objects) # delete all methods of this class foreach tmpMethodName $gmlObject(class,$className,methods) { if { [catch { gmlObjDeleteMethod $className $tmpMethodName } tmpRes] } { puts stderr "gmlObjDeleteClass WARNING, could not delete method \"$tmpMethodName\": $tmpRes" } } unset gmlObject(class,$className,methods) # delete class from gmlObject, delete class procedure and global variable unset gmlObject(class,$className,classes) rename $className {} if { [info exists class] } { unset class } set gmlObject(classes) [lreplace $gmlObject(classes) $tmpIdx $tmpIdx] } return } proc gmlObjNewObject { baseObj className objName args } { global gmlObject errorInfo upvar #0 $objName this set tmpClone [expr [string length $baseObj] != 0] set tmpConstructor [gmlObjMethodExists $className constructor] if { !$tmpConstructor && ([llength $args] != 0) } { error "too many args: there is no constructor" } if { [info exists this] } { error "could not create object \"$objName\": a global variable with that name already exists" } if { [llength [info procs $objName]] } { error "could not create object \"$objName\": a procedure with that name already exists" } set gmlObject(object,$objName,class) $className set gmlObject(object,$objName,newNames) [list] lappend gmlObject(class,$className,objects) $objName proc $objName { args } "return \[uplevel gmlObjObjectDispatch [list [list $objName]] \$args\]" if { $tmpClone } { set gmlObject(object,$objName,baseObj) $baseObj lappend gmlObject(object,$baseObj,newNames) $objName uplevel #0 upvar #0 [list $baseObj] [list $objName] } else { set gmlObject(object,$objName,baseObj) {} trace add command $objName rename "gmlObjRenameEntity object" # Call the constructor if it exists. if { $tmpConstructor } { if { [catch { uplevel gmlObjObjectDispatch [list $objName] constructor $args } tmpRes] } { set tmpSavedInfo $errorInfo gmlObjDeleteObject $objName 0 error $tmpRes $tmpSavedInfo } } } return $objName } proc gmlObjDeleteObject { objName { reportDestructorError 1 } } { global gmlObject errorInfo upvar #0 $objName this set tmpClass $gmlObject(object,$objName,class) set tmpCloneof $gmlObject(object,$objName,baseObj) set tmpClone [expr [string length $tmpCloneof] != 0] trace remove command $objName rename "gmlObjRenameEntity object" # Delete all of this object new names. foreach tmpCloneName $gmlObject(object,$objName,newNames) { gmlObjDeleteObject $tmpCloneName } set tmpDestructError 0 if { $tmpClone } { # remove this object from its base object new name list. set tmpIdx [lsearch -exact $gmlObject(object,$tmpCloneof,newNames) $objName] if { $tmpIdx == -1 } { error "gmlObjDeleteObject ${objName}: object not found in the list of newNames of its base object" } set gmlObject(object,$tmpCloneof,newNames) \ [lreplace $gmlObject(object,$tmpCloneof,newNames) $tmpIdx $tmpIdx] # remove this object name reference to base object global variable. uplevel #0 upvar #0 [list {}] [list $objName] } else { # Call destructor if it exists. if { [gmlObjMethodExists $tmpClass destructor] } { set tmpDestructError [catch { uplevel gmlObjObjectDispatch [list $objName] destructor } tmpDestructRes] set tmpSavedErrorInfo $errorInfo } # unset the global variable that stored the object attributes if { [info exists this] } { unset this } } # cleanup this object data in the global gmlObject array unset gmlObject(object,$objName,class) unset gmlObject(object,$objName,baseObj) unset gmlObject(object,$objName,newNames) # delete this object references from its class set tmpIdx [lsearch -exact $gmlObject(class,$tmpClass,objects) $objName] if { $tmpIdx == -1 } { error "gmlObjDeleteObject ${objName}: object not found in the list of objects of its class" } set gmlObject(class,$tmpClass,objects) \ [lreplace $gmlObject(class,$tmpClass,objects) $tmpIdx $tmpIdx] rename $objName {} if { $tmpDestructError && $reportDestructorError } { error $tmpDestructRes $tmpSavedErrorInfo } return } # this -- # # Execute another method of the calling object. # # Only valid inside a method. proc this { args } { upvar objName this return [uplevel gmlObjObjectDispatch [list $this] $args] } # method -- # # Create or modify a method named <methodName> in class <className>. # The method will accept arguments in <paramList> (formatted like the # second parameter of Tcl's <proc> command), and will execute <body> # when called. # # Class <className> will be created if it didn't exist prior to the call. proc method { args } { global gmlObject gmlObjInit if { [llength $args] != 4 } { error "wrong # args: should be \"method className methodName args body\"" } foreach { className methodName paramList body } $args { # If the class doesn't exist yet, create it. if { ![gmlObjClassExists $className] } { gmlObjNewClass $className } set tmpBodyHeader "upvar #0 \$className class \$objName this\n" proc gmlObj_${className}_$methodName \ [linsert $paramList 0 objName className methodName] \ $tmpBodyHeader$body if { ![gmlObjMethodExists $className $methodName] } { lappend gmlObject(class,$className,methods) $methodName set gmlObject(class,$className,method,$methodName) {} } } return } proc gmlObjDeleteMethod { className methodName } { global gmlObject set tmpListIndex class,$className,methods set tmpIdx [lsearch -exact $gmlObject($tmpListIndex) $methodName] if { $tmpIdx == -1 } { error "gmlObjDeleteMethod ${className}::${methodName}: method not found in the list of methods" } set gmlObject($tmpListIndex) \ [lreplace $gmlObject($tmpListIndex) $tmpIdx $tmpIdx] if { ![string length $gmlObject(class,$className,method,$methodName)] } { rename gmlObj_${className}_$methodName {} } unset gmlObject(class,$className,method,$methodName) return } proc gmlObjRenameEntity { classOrObj oldName newName op } { regexp {(::|)(.+)$} $oldName dum dum oldName regexp {(::|)(.+)$} $newName dum dum newName global gmlObject upvar #0 $oldName old $newName new if { [info exists new] } { unset new } set oldPrefix ${classOrObj},${oldName}, set oldPrefixLen [string length $oldPrefix] set newPrefix ${classOrObj},${newName}, set newList [list] foreach { idx val } [array get gmlObject ${oldPrefix}*] { lappend newList ${newPrefix}[string range $idx $oldPrefixLen end] $val } array unset gmlObject ${oldPrefix}* array set gmlObject $newList if { [info exists old] } { foreach idx [array names old] { set new($idx) $old($idx) } unset old } switch -exact $classOrObj \ class { # rename in gmlObject list of all classes set idx [lsearch -exact $gmlObject(classes) $oldName] set gmlObject(classes) [lreplace $gmlObject(classes) $idx $idx $newName] # rename in this class superclasses's specializations foreach tmpSuper $gmlObject(class,$newName,classes) { set idx [lsearch -exact $gmlObject(class,$tmpSuper,specializations) $oldName] set gmlObject(class,$tmpSuper,specializations) \ [lreplace $gmlObject(class,$tmpSuper,specializations) $idx $idx $newName] } # rename in this class specializations' superclasses foreach tmpSpec $gmlObject(class,$newName,specializations) { set idx [lsearch -exact $gmlObject(class,$tmpSpec,classes) $oldName] set gmlObject(class,$tmpSpec,classes) \ [lreplace $gmlObject(class,$tmpSpec,classes) $idx $idx $newName] } # rename this class objects' class foreach tmpObj $gmlObject(class,$newName,objects) { set gmlObject(object,$tmpObj,class) $newName } # rename all methods' procs foreach tmpMethod $gmlObject(class,$newName,methods) { rename gmlObj_${oldName}_$tmpMethod gmlObj_${newName}_$tmpMethod } # redefine this class proc, re-register rename handler proc $newName { args } "return \[uplevel gmlObjNewObject [list [list {}]] $newName \$args\]" trace add command $newName rename "gmlObjRenameEntity class" } \ object { # rename in this object's class object list set tmpClass $gmlObject(object,$newName,class) set idx [lsearch -exact $gmlObject(class,$tmpClass,objects) $oldName] set gmlObject(class,$tmpClass,objects) \ [lreplace $gmlObject(class,$tmpClass,objects) $idx $idx $newName] # redefine this object proc, re-register rename handler proc $newName { args } "return \[uplevel gmlObjObjectDispatch [list [list $newName]] \$args\]" trace add command $newName rename "gmlObjRenameEntity object" } } proc gmlObjObjectDispatch { objName methodName args } { global gmlObject set tmpObjClass $gmlObject(object,$objName,class) if { [regexp {^(.+)::([^:]+)$} $methodName tmpMatch tmpSuperClass methodName] } { if { ![gmlObjIsAncestor $tmpObjClass $tmpSuperClass] } { error "\"$tmpSuperClass\" is not an ancestor of \"$tmpObjClass\"" } set tmpFound [gmlObjFindMethod $tmpSuperClass $methodName 1 tmpFoundClass] } else { if { [string equal $methodName "inherited"] } { upvar className tmpCallClassName objName tmpCallObjName methodName tmpCallMethodName if { (![info exists tmpCallClassName]) || (![info exists tmpCallObjName]) || (![info exists tmpCallMethodName]) || (![string equal $objName $tmpCallObjName]) } { error "\"inherited\" can only be invoked on \"this\" in the context of a method" } set methodName $tmpCallMethodName set tmpFound [gmlObjFindMethod $tmpCallClassName $methodName 0 tmpFoundClass] } else { set tmpFound [gmlObjFindMethod $tmpObjClass $methodName 1 tmpFoundClass] } } if { ! $tmpFound } { return [uplevel [list $objName] unknown $methodName $args] } return [uplevel gmlObj_${tmpFoundClass}_$methodName [list $objName] $tmpFoundClass $methodName $args] } proc gmlObjFindMethod { className methodName searchInBase resVarName } { global gmlObject upvar $resVarName res if { $searchInBase } { if { [gmlObjMethodExists $className $methodName] } { set res $className return 1 } } foreach tmpClassName $gmlObject(class,$className,classes) { if { [gmlObjFindMethod $tmpClassName $methodName 1 res] } { return 1 } } return 0 } proc gmlObjIsAncestor { className ancestorName } { global gmlObject set tmpAncestors $gmlObject(class,$className,classes) if { [lsearch -exact $tmpAncestors $ancestorName] != -1 } { return 1 } foreach tmpClassName $tmpAncestors { if { [gmlObjIsAncestor $tmpClassName $ancestorName] } { return 1 } } return 0 } # inherit -- # # Make <className> inherit all the methods from <superClassName>. # The class named <superClassName> must exist before the call, or must be prensent # in the auto_array index. # The class named <className> is created if it doesn't exist before the call. # # If <superClassName> is already an ancestor of <className>, simply returns without # complaining. proc inherit { className superClassName } { global gmlObject auto_index gmlObjInit if { ![gmlObjClassExists $className] } { gmlObjNewClass $className } if { ![gmlObjClassExists $superClassName] } { if { ![auto_load $superClassName] } { error "class \"$superClassName\" does not exist" } } if { [gmlObjIsAncestor $superClassName $className] } { error "class \"$className\" is an ancestor of class \"$superClassName\"" } if { [gmlObjIsAncestor $className $superClassName] } { return } set gmlObject(class,$className,classes) \ [linsert $gmlObject(class,$className,classes) 0 $superClassName] lappend gmlObject(class,$superClassName,specializations) $className return } # gmlObject -- # # Inspect and modify defined objects and classes. # # # Usage: # # gmlObject delete class <className> # gmlObject delete method <className> <methodName> # gmlObject delete object <objectName> # # gmlObject info args <className> <methodName> # gmlObject info arglist <className> <methodName> # gmlObject info body <className> <methodName> # gmlObject info class <className> # gmlObject info classes ?(<objectName>|<className>)? # gmlObject info classofobject <objName> # gmlObject info exists (class|object) <name> # gmlObject info interface ?(<objectName>|<className>)? # gmlObject info methods (<objectName>|<className>) # gmlObject info objects ?<className>? # gmlObject info specializations <className> proc gmlObject { args } { if { [llength $args] < 1 } { error "wrong # args: should be \"gmlObject <command> ?option? ...\"" } set tmpCommandList [list "delete" "info"] set tmpCommand [lindex $args 0] if { [lsearch -exact $tmpCommandList $tmpCommand] == -1 } { error "wrong command \"$tmpCommand\": should be delete, or info" } return [uplevel gmlObject_$tmpCommand [lrange $args 1 end]] } proc gmlObject_delete { args } { global gmlObject if { ([llength $args] < 2) } { error "wrong # args: should be \"gmlObject delete (class <name> | method <className> <methodName> | object <name>)\"" } set tmpType [lindex $args 0] set tmpName [lindex $args 1] switch $tmpType \ "class" { if { ([llength $args] != 2) } { error "wrong # args: should be \"gmlObject delete class <name>\"" } if { ![gmlObjClassExists $tmpName] } { error "there is no class named \"$tmpName\"" } uplevel gmlObjDeleteClass $tmpName } \ "object" { if { ([llength $args] != 2) } { error "wrong # args: should be \"gmlObject delete object <name>\"" } if { ![gmlObjObjectExists $tmpName] } { error "there is no object named \"$tmpName\"" } uplevel gmlObjDeleteObject [list $tmpName] } \ "method" { if { ([llength $args] != 3) } { error "wrong # args: should be \"gmlObject delete method <className> <methodName>\"" } set tmpClassName [lindex $args 1] set tmpMethodName [lindex $args 2] if { ![gmlObjClassExists $tmpClassName] } { error "there is no class named \"$tmpClassName\"" } uplevel gmlObjDeleteMethod $tmpClassName $tmpMethodName } \ default { error "wrong entity \"$tmpType\": should be class, method or object" } return } proc gmlObjBuildClassList { type entityName } { global gmlObject switch $type \ object { if { ![gmlObjObjectExists $entityName] } { error "there is no object named \"$entityName\"" } set tmpClassName $gmlObject(object,$entityName,class) return [concat $tmpClassName [gmlObjBuildClassList class $tmpClassName]] } \ class { if { ![gmlObjClassExists $entityName] } { error "there is no class named \"$entityName\"" } set tmpSupers $gmlObject(class,$entityName,classes) set tmpRes $tmpSupers foreach tmpSuper $tmpSupers { set tmpInherited [gmlObjBuildClassList class $tmpSuper] foreach tmpClass $tmpInherited { if { [lsearch -exact $tmpRes $tmpClass] == -1 } { lappend tmpRes $tmpClass } } } } return $tmpRes } proc gmlObjBuildMethodList { className { withSuperPrefix 0 } } { global gmlObject if { ![gmlObjClassExists $className] } { error "there is no class named \"$className\"" } set tmpRes $gmlObject(class,$className,methods) foreach tmpSuper $gmlObject(class,$className,classes) { set tmpInherited [gmlObjBuildMethodList $tmpSuper $withSuperPrefix] foreach tmpMethod $tmpInherited { if { [lsearch -exact $tmpRes $tmpMethod] == -1 } { if { $withSuperPrefix && (![regexp {^(.+)::([^:]+)$} $tmpMethod]) } { set tmpMethod ${tmpSuper}::$tmpMethod } lappend tmpRes $tmpMethod } } } return [lsort -dictionary $tmpRes] } proc gmlObject_info { args } { global gmlObject set tmpArgLen [llength $args] if { $tmpArgLen == 0 } { error "wrong #args: should be \"gmlObject info <option> ...\"" } set tmpOption [lindex $args 0] switch $tmpOption \ "arglist" { if { $tmpArgLen != 3 } { error "wrong #args: should be \"gmlObject info arglist <className> <methodName>\"" } foreach { tmpClassName tmpMethodName } [lrange $args 1 2] { if { ![gmlObjMethodExists $tmpClassName $tmpMethodName] } { error "there is no class/method named \"${tmpClassName}::$tmpMethodName\"" } set tmpProcName gmlObj_${tmpClassName}_${tmpMethodName} set tmpList [list] foreach tmpArg \ [lrange [info args $tmpProcName] 3 end] { if { [info default $tmpProcName $tmpArg tmpDefault] } { lappend tmpList [list $tmpArg $tmpDefault] } else { lappend tmpList $tmpArg } } return $tmpList } } \ "args" { if { $tmpArgLen != 3 } { error "wrong #args: should be \"gmlObject info args <className> <methodName>\"" } foreach { tmpClassName tmpMethodName } [lrange $args 1 2] { if { ![gmlObjMethodExists $tmpClassName $tmpMethodName] } { error "there is no class/method named \"${tmpClassName}::$tmpMethodName\"" } return [lrange [info args gmlObj_${tmpClassName}_${tmpMethodName}] 3 end] } } \ "body" { if { $tmpArgLen != 3 } { error "wrong #args: should be \"gmlObject info body <className> <methodName>\"" } foreach { tmpClassName tmpMethodName } [lrange $args 1 2] { if { ![gmlObjMethodExists $tmpClassName $tmpMethodName] } { error "there is no class/method named \"${tmpClassName}::$tmpMethodName\"" } regexp {(^upvar \#0 \$className class \$objName this\n)(.*)} \ [info body gmlObj_${tmpClassName}_${tmpMethodName}] tmpDum tmpHead tmpTail return $tmpTail } } \ "class" { if { $tmpArgLen != 2 } { error "wrong #args: should be \"gmlObject info class <className>\"" } set tmpClassName [lindex $args 1] if { ![gmlObjClassExists $tmpClassName] } { error "there is no class named \"$tmpClassName\"" } set tmpCode {} foreach tmpMethodName $gmlObject(class,$tmpClassName,methods) { set tmpCode "${tmpCode}method $tmpClassName $tmpMethodName { " set tmpCode "${tmpCode}[gmlObject info arglist $tmpClassName $tmpMethodName]" set tmpCode "${tmpCode} } {[gmlObject info body $tmpClassName $tmpMethodName]}\n" } set tmpInheritance {} foreach tmpSuperName [gmlObject info classes $tmpClassName] { if { ![string equal $tmpSuperName gmlObjRootClass] } { set tmpInheritance "inherit $tmpClassName $tmpSuperName\n$tmpInheritance" } } if { [string length $tmpInheritance] } { set tmpCode $tmpCode\n$tmpInheritance } return $tmpCode } \ "classes" { if { $tmpArgLen == 1 } { return $gmlObject(classes) } if { $tmpArgLen > 2 } { error "wrong #args: should be \"gmlObject info classes ?(<objectName>|<className>)?\"" } set tmpEntityName [lindex $args 1] if { [gmlObjObjectExists $tmpEntityName] } { return [gmlObjBuildClassList object $tmpEntityName] } else { return [gmlObjBuildClassList class $tmpEntityName] } } \ "classofobject" { if { $tmpArgLen != 2 } { error "wrong #args: should be \"gmlObject info classofobject <objName>\"" } set tmpObjName [lindex $args 1] if { ![gmlObjObjectExists $tmpObjName] } { error "there is no object named \"$tmpObjName\"" } return [lindex $gmlObject(object,$tmpObjName,class) 0] } \ "exists" { if { $tmpArgLen != 3 } { error "wrong #args: should be \"gmlObject info exists (class|object) <name>\"" } set tmpClassOrObject [lindex $args 1] if { [string equal $tmpClassOrObject "object"] } { return [gmlObjObjectExists [lindex $args 2]] } elseif { [string equal $tmpClassOrObject "class"] } { return [gmlObjClassExists [lindex $args 2]] } else { error "wrong option \"$tmpClassOrObject\": should be class or object" } } \ "interface" { if { $tmpArgLen != 2 } { error "wrong #args: should be \"gmlObject info interface ?(<objectName>|<className>)?\"" } set tmpEntityName [lindex $args 1] if { [gmlObjObjectExists $tmpEntityName] } { set tmpClassName $gmlObject(object,$tmpEntityName,class) } else { set tmpClassName $tmpEntityName } if { ![gmlObjClassExists $tmpClassName] } { error "there is no class named \"$tmpClassName\"" } set tmpCode {} foreach tmpMethodName $gmlObject(class,$tmpClassName,methods) { set tmpCode "${tmpCode}method $tmpClassName $tmpMethodName { " set tmpCode "${tmpCode}[gmlObject info arglist $tmpClassName $tmpMethodName]" set tmpCode "${tmpCode} }\n" } return $tmpCode } \ "methods" { if { $tmpArgLen != 2 } { error "wrong #args: should be \"gmlObject info methods (<objectName> | <className>)\"" } set tmpEntityName [lindex $args 1] if { [gmlObjObjectExists $tmpEntityName] } { return [gmlObjBuildMethodList $gmlObject(object,$tmpEntityName,class) 1] } else { return [gmlObjBuildMethodList $tmpEntityName 1] } } \ "objects" { if { $tmpArgLen > 2 } { error "wrong #args: should be \"gmlObject info objects ?<className>?\"" } if { $tmpArgLen == 1 } { set tmpList [list] foreach tmpClassName $gmlObject(classes) { set tmpList [concat $tmpList $gmlObject(class,$tmpClassName,objects)] } return $tmpList } else { set tmpClassName [lindex $args 1] if { ![gmlObjClassExists $tmpClassName] } { error "there is no class named \"$tmpClassName\"" } return $gmlObject(class,$tmpClassName,objects) } } \ "specializations" { if { $tmpArgLen != 2 } { error "wrong #args: should be \"gmlObject info specializations <className>\"" } set tmpClassName [lindex $args 1] if { ! [info exists gmlObject(class,$tmpClassName,specializations)] } { error "there is no class named \"$tmpClassName\"" } return $gmlObject(class,$tmpClassName,specializations) } \ default { error "wrong option \"$tmpOption\": should be arglist, args, body, class, classes, classofobject, exists, interface, methods, objects, or specializations" } }