/usr/share/tcltk/tcllib1.14/stooop/switched.tcl is in tcllib 1.14-dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | # The switched class (for the stooop object oriented extension)
#
# Copyright (c) 2001 by Jean-Luc Fontaine <jfontain@free.fr>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: switched.tcl,v 1.5 2006/09/19 23:36:18 andreas_kupries Exp $
package require stooop
package provide switched 2.2.1
::stooop::class switched {
proc switched {this args} { ;# arguments are option / value pairs
if {([llength $args]%2)!=0} {
error "value for \"[lindex $args end]\" missing"
}
set ($this,complete) 0
# delay arguments processing till completion as pure virtual procedure
# invocations do not work from base class constructor
set ($this,arguments) $args
}
proc ~switched {this} {}
# derived class implementation must return a list of
# {name "default value" "initial value"} lists
::stooop::virtual proc options {this}
# must be invoked once only at the end of derived class constructor so that
# configuration occurs once derived object is completely built:
proc complete {this} {
foreach description [options $this] {
set option [lindex $description 0]
# by default always set option to default value:
set ($this,$option) [set default [lindex $description 1]]
if {[llength $description]<3} {
# no initial value so force initialization with default value
set initialize($option) {}
} elseif {![string equal $default [lindex $description 2]]} {
set ($this,$option) [lindex $description 2]
# initial value different from default value so force
# initialization
set initialize($option) {}
}
}
# check validity of constructor options, which always take precedence
# for initialization
foreach {option value} $($this,arguments) {
if {[catch {string compare $($this,$option) $value} different]} {
error "$($this,_derived): unknown option \"$option\""
}
if {$different} {
set ($this,$option) $value
set initialize($option) {}
}
}
unset ($this,arguments)
# all option values are initialized before any of the set procedures are
# called
foreach option [array names initialize] {
$($this,_derived)::set$option $this $($this,$option)
}
set ($this,complete) 1
}
proc configure {this args} { ;# should not be invoked before completion
if {[llength $args]==0} {
return [descriptions $this]
}
foreach {option value} $args {
# check all options validity before doing anything else
if {![info exists ($this,$option)]} {
error "$($this,_derived): unknown option \"$option\""
}
}
if {[llength $args]==1} {
return [description $this [lindex $args 0]]
}
if {([llength $args]%2)!=0} {
error "value for \"[lindex $args end]\" missing"
}
# derived (dynamic virtual) procedure must either accept (or eventually
# adjust) the value or throw an error
# option data member is set prior to invoking the procedure in case
# other procedures are invoked and expect the new value
foreach {option value} $args {
if {![string equal $($this,$option) $value]} {
$($this,_derived)::set$option $this [set ($this,$option) $value]
}
}
}
proc cget {this option} {
if {[catch {set value $($this,$option)}]} {
error "$($this,_derived): unknown option \"$option\""
}
return $value ;# return specified option current value
}
proc description {this option} { ;# build specified option description list
foreach description [options $this] {
if {[string equal [lindex $description 0] $option]} {
if {[llength $description]<3} { ;# no initial value
lappend description $($this,$option) ;# append current value
return $description
} else {
# set current value:
return [lreplace $description 2 2 $($this,$option)]
}
}
}
}
# build option descriptions list for all supported options:
proc descriptions {this} {
set descriptions {}
foreach description [options $this] {
if {[llength $description]<3} { ;# no initial value
# append current value:
lappend description $($this,[lindex $description 0])
lappend descriptions $description
} else {
# set current value:
lappend descriptions [lreplace\
$description 2 2 $($this,[lindex $description 0])\
]
}
}
return $descriptions
}
}
|