- Implemented regresion tests for batch processing, scans,
histmem and peak optimization
This commit is contained in:
koennecke
305
test/object.tcl
Normal file
305
test/object.tcl
Normal file
@ -0,0 +1,305 @@
|
||||
#
|
||||
# $Id: object.tcl,v 1.1 2006/10/20 14:57:27 koennecke 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
|
||||
}
|
||||
Reference in New Issue
Block a user