499af28298
Tcl commands. Removed the broken obTcl object system and replaced it by
the object.tcl system from sntl. Redid the scan command with this. The
end of this is that SICS is now independent of the tcl version and
works with tcl 8.0 thus giving a factor of up to 10 in script execution
speed.
2.) Added driving an angle through a translation table (object lin2ang)
306 lines
10 KiB
Tcl
Executable File
306 lines
10 KiB
Tcl
Executable File
#
|
|
# $Id: object.tcl,v 1.1 2000/02/25 16:21:41 cvs Exp $
|
|
#
|
|
# This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory.
|
|
#
|
|
# Redistribution and use in source and binary forms, with or without
|
|
# modification, are permitted provided that: (1) source code distributions
|
|
# retain the above copyright notice and this paragraph in its entirety, (2)
|
|
# distributions including binary code include the above copyright notice and
|
|
# this paragraph in its entirety in the documentation or other materials
|
|
# provided with the distribution, and (3) all advertising materials mentioning
|
|
# features or use of this software display the following acknowledgement:
|
|
# ``This product includes software developed by the University of California,
|
|
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
|
|
# the University nor the names of its contributors may be used to endorse
|
|
# or promote products derived from this software without specific prior
|
|
# written permission.
|
|
#
|
|
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
|
|
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
|
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
|
#
|
|
|
|
set object_priv(currentClass) {}
|
|
set object_priv(objectCounter) 0
|
|
|
|
#----------------------------------------------------------------------
|
|
proc object_class {name spec} {
|
|
global object_priv
|
|
set object_priv(currentClass) $name
|
|
lappend object_priv(objects) $name
|
|
upvar #0 ${name}_priv class
|
|
set class(__members) {}
|
|
set class(__methods) {}
|
|
set class(__params) {}
|
|
set class(__class_vars) {}
|
|
set class(__class_methods) {}
|
|
uplevel $spec
|
|
proc $name:config args "uplevel \[concat object_config \$args]"
|
|
proc $name:configure args "uplevel \[concat object_config \$args]"
|
|
proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
|
|
}
|
|
#---------------------------------------------------------------------
|
|
proc method {name args body} {
|
|
global object_priv
|
|
set className $object_priv(currentClass)
|
|
upvar #0 ${className}_priv class
|
|
if {[lsearch $class(__methods) $name] < 0} {
|
|
lappend class(__methods) $name
|
|
}
|
|
set methodArgs self
|
|
append methodArgs " " $args
|
|
proc $className:$name $methodArgs "upvar #0 \$self slot ${className}_priv class_var\n$body"
|
|
}
|
|
#------------------------------------------------------------------
|
|
proc object_method {name {defaultValue {}}} [info body method]
|
|
#------------------------------------------------------------------
|
|
proc member {name {defaultValue {}}} {
|
|
global object_priv
|
|
set className $object_priv(currentClass)
|
|
upvar #0 ${className}_priv class
|
|
lappend class(__members) [list $name $defaultValue]
|
|
}
|
|
#----------------------------------------------------------------------
|
|
proc object_member {name {defaultValue {}}} [info body member]
|
|
#---------------------------------------------------------------------
|
|
proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
|
|
global object_priv
|
|
set className $object_priv(currentClass)
|
|
upvar #0 ${className}_priv class
|
|
if {$resourceClass == ""} {
|
|
set resourceClass \
|
|
[string toupper [string index $name 0]][string range $name 1 end]
|
|
}
|
|
if ![info exists class(__param_info/$name)] {
|
|
lappend class(__params) $name
|
|
}
|
|
set class(__param_info/$name) [list $defaultValue $resourceClass]
|
|
if {$configCode != {}} {
|
|
proc $className:config:$name self $configCode
|
|
}
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
proc object_param {name {defaultValue {}} {resourceClass {}} {configCode {}}} \
|
|
[info body param]
|
|
|
|
#--------------------------------------------------------------------------
|
|
proc object_class_var {name {initialValue ""}} {
|
|
global object_priv
|
|
set className $object_priv(currentClass)
|
|
upvar #0 ${className}_priv class
|
|
set class($name) $initialValue
|
|
set class(__initial_value.$name) $initialValue
|
|
lappend class(__class_vars) $name
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc object_class_method {name args body} {
|
|
global object_priv
|
|
set className $object_priv(currentClass)
|
|
upvar #0 ${className}_priv class
|
|
if {[lsearch $class(__class_methods) $name] < 0} {
|
|
lappend class(__class_methods) $name
|
|
}
|
|
proc $className:$name $args "upvar #0 ${className}_priv class_var\n$body"
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc object_include {super_class_name} {
|
|
global object_priv
|
|
set className $object_priv(currentClass)
|
|
upvar #0 ${className}_priv class
|
|
upvar #0 ${super_class_name}_priv super_class
|
|
foreach p $super_class(__params) {
|
|
lappend class(__params) $p
|
|
set class(__param_info/$p) $super_class(__param_info/$p)
|
|
}
|
|
set class(__members) [concat $super_class(__members) $class(__members)]
|
|
set class(__class_vars) \
|
|
[concat $super_class(__class_vars) $class(__class_vars)]
|
|
foreach v $super_class(__class_vars) {
|
|
set class($v) \
|
|
[set class(__initial_value.$v) $super_class(__initial_value.$v)]
|
|
}
|
|
set class(__class_methods) \
|
|
[concat $super_class(__class_methods) $class(__class_methods)]
|
|
set class(__methods) \
|
|
[concat $super_class(__methods) $class(__methods)]
|
|
foreach m $super_class(__methods) {
|
|
set proc $super_class_name:$m
|
|
proc $className:$m [object_get_formals $proc] [info body $proc]
|
|
}
|
|
foreach m $super_class(__class_methods) {
|
|
set proc $super_class_name:$m
|
|
regexp "^\[^\n\]+\n(.*)" [info body $proc] dummy body
|
|
proc $className:$m [object_get_formals $proc] \
|
|
"upvar #0 ${className}_priv class_var\n$body"
|
|
}
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc object_new {className {name {}}} {
|
|
if {$name == {}} {
|
|
global object_priv
|
|
set name O_[incr object_priv(objectCounter)]
|
|
}
|
|
upvar #0 $name object
|
|
upvar #0 ${className}_priv class
|
|
set object(__class) $className
|
|
foreach var $class(__params) {
|
|
set info $class(__param_info/$var)
|
|
set resourceClass [lindex $info 1]
|
|
if ![catch {set val [option get $name $var $resourceClass]}] {
|
|
if {$val == ""} {
|
|
set val [lindex $info 0]
|
|
}
|
|
} else {
|
|
set val [lindex $info 0]
|
|
}
|
|
set object($var) $val
|
|
}
|
|
foreach var $class(__members) {
|
|
set object([lindex $var 0]) [lindex $var 1]
|
|
}
|
|
proc $name {method args} [format {
|
|
upvar #0 %s object
|
|
uplevel [concat $object(__class):$method %s $args]
|
|
} $name $name]
|
|
return $name
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc object_define_creator {windowType name spec} {
|
|
object_class $name $spec
|
|
if {[info procs $name:create] == {}} {
|
|
error "widget \"$name\" must define a create method"
|
|
}
|
|
if {[info procs $name:reconfig] == {}} {
|
|
error "widget \"$name\" must define a reconfig method"
|
|
}
|
|
proc $name {window args} [format {
|
|
%s $window -class %s
|
|
rename $window object_window_of$window
|
|
upvar #0 $window object
|
|
set object(__window) $window
|
|
object_new %s $window
|
|
proc %s:frame {self args} \
|
|
"uplevel \[concat object_window_of$window \$args]"
|
|
uplevel [concat $window config $args]
|
|
$window create
|
|
set object(__created) 1
|
|
bind $window <Destroy> \
|
|
"if !\[string compare %%W $window\] { object_delete $window }"
|
|
$window reconfig
|
|
return $window
|
|
} $windowType \
|
|
[string toupper [string index $name 0]][string range $name 1 end] \
|
|
$name $name]
|
|
}
|
|
#------------------------------------------------------------------
|
|
proc object_config {self args} {
|
|
upvar #0 $self object
|
|
set len [llength $args]
|
|
if {$len == 0} {
|
|
upvar #0 $object(__class)_priv class
|
|
set result {}
|
|
foreach param $class(__params) {
|
|
set info $class(__param_info/$param)
|
|
lappend result \
|
|
[list -$param $param [lindex $info 1] [lindex $info 0] \
|
|
$object($param)]
|
|
}
|
|
if [info exists object(__window)] {
|
|
set result [concat $result [object_window_of$object(__window) config]]
|
|
}
|
|
return $result
|
|
}
|
|
if {$len == 1} {
|
|
upvar #0 $object(__class)_priv class
|
|
if {[string index $args 0] != "-"} {
|
|
error "param '$args' didn't start with dash"
|
|
}
|
|
set param [string range $args 1 end]
|
|
if {[set ndx [lsearch -exact $class(__params) $param]] == -1} {
|
|
if [info exists object(__window)] {
|
|
return [object_window_of$object(__window) config -$param]
|
|
}
|
|
error "no param '$args'"
|
|
}
|
|
set info $class(__param_info/$param)
|
|
return [list -$param $param [lindex $info 1] [lindex $info 0] \
|
|
$object($param)]
|
|
}
|
|
# accumulate commands and eval them later so that no changes will take
|
|
# place if we find an error
|
|
set cmds ""
|
|
while {$args != ""} {
|
|
set fieldId [lindex $args 0]
|
|
if {[string index $fieldId 0] != "-"} {
|
|
error "param '$fieldId' didn't start with dash"
|
|
}
|
|
set fieldId [string range $fieldId 1 end]
|
|
if ![info exists object($fieldId)] {
|
|
if {[info exists object(__window)]} {
|
|
if [catch [list object_window_of$object(__window) config -$fieldId]] {
|
|
error "tried to set param '$fieldId' which did not exist."
|
|
} else {
|
|
lappend cmds \
|
|
[list object_window_of$object(__window) config -$fieldId [lindex $args 1]]
|
|
set args [lrange $args 2 end]
|
|
continue
|
|
}
|
|
}
|
|
|
|
}
|
|
if {[llength $args] == 1} {
|
|
return $object($fieldId)
|
|
} else {
|
|
lappend cmds [list set object($fieldId) [lindex $args 1]]
|
|
if {[info procs $object(__class):config:$fieldId] != {}} {
|
|
lappend cmds [list $self config:$fieldId]
|
|
}
|
|
set args [lrange $args 2 end]
|
|
}
|
|
}
|
|
foreach cmd $cmds {
|
|
eval $cmd
|
|
}
|
|
if {[info exists object(__created)] && [info procs $object(__class):reconfig] != {}} {
|
|
$self reconfig
|
|
}
|
|
}
|
|
|
|
proc object_cget {self var} {
|
|
upvar #0 $self object
|
|
return [lindex [object_config $self $var] 4]
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc object_delete self {
|
|
upvar #0 $self object
|
|
if {[info exists object(__class)] && [info commands $object(__class):destroy] != ""} {
|
|
$object(__class):destroy $self
|
|
}
|
|
if [info exists object(__window)] {
|
|
if [string length [info commands object_window_of$self]] {
|
|
catch {rename $self {}}
|
|
rename object_window_of$self $self
|
|
}
|
|
destroy $self
|
|
}
|
|
catch {unset object}
|
|
}
|
|
#--------------------------------------------------------------------------
|
|
proc object_slotname slot {
|
|
upvar self self
|
|
return [set self]($slot)
|
|
}
|
|
#--------------------------------------------------------------------------
|
|
proc object_get_formals {proc} {
|
|
set formals {}
|
|
foreach arg [info args $proc] {
|
|
if [info default $proc $arg def] {
|
|
lappend formals [list $arg $def]
|
|
} else {
|
|
lappend formals $arg
|
|
}
|
|
}
|
|
return $formals
|
|
}
|