306 lines
10 KiB
Tcl
306 lines
10 KiB
Tcl
#
|
|
# $Id$
|
|
#
|
|
# 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
|
|
}
|