/usr/share/tcltk/tcllib1.18/tool/option.tcl is in tcllib 1.18-dfsg-3.
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 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | ###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tool::define::option {name args} {
set class [current_class]
set dictargs {default: {}}
foreach {var val} [::oo::meta::args_to_dict {*}$args] {
dict set dictargs [string trimright [string trimleft $var -] :]: $val
}
set name [string trimleft $name -]
###
# Option Class handling
###
set optclass [dict getnull $dictargs class:]
if {$optclass ne {}} {
foreach {f v} [::oo::meta::info $class getnull option_class $optclass] {
if {![dict exists $dictargs $f]} {
dict set dictargs $f $v
}
}
}
::oo::meta::info $class branchset option $name $dictargs
}
###
# topic: 827a3a331a2e212a6e301f59c1eead59
# title: Define a class of options
# description:
# Option classes are a template of properties that other
# options can inherit.
###
proc ::tool::define::option_class {name args} {
set class [current_class]
set dictargs {default {}}
foreach {var val} [::oo::meta::args_to_dict {*}$args] {
dict set dictargs [string trimleft $var -] $val
}
set name [string trimleft $name -]
::oo::meta::info $class branchset option_class $name $dictargs
}
::tool::define ::tool::object {
property options_strict 0
variable organs {}
option_class organ {
widget label
set-command {my graft %field% %value%}
get-command {my organ %field%}
}
option_class variable {
widget entry
set-command {my variable %field% ; set %field% %value%}
get-command {my variable %field% ; set %field%}
}
dict_ensemble config config
method config::get {field args} {
my variable config option_canonical option_getcmd
set field [string trimleft $field -]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
if {[info exists option_getcmd($field)]} {
return [eval $option_getcmd($field)]
}
if {[dict exists $config $field]} {
return [dict get $config $field]
}
if {[llength $args]} {
return [linded $args 0]
}
return [my property $field]
}
method config::set args {
set dictargs [::oo::meta::args_to_options {*}$args]
set dat [my config merge $dictargs]
my config triggers $dat
}
###
# topic: 86a1b968cea8d439df87585afdbdaadb
###
method cget args {
return [my config get {*}$args]
}
###
# topic: 73e2566466b836cc4535f1a437c391b0
###
method configure args {
# Will be removed at the end of "configurelist_triggers"
set dictargs [::oo::meta::args_to_options {*}$args]
if {[llength $dictargs] == 1} {
return [my cget [lindex $dictargs 0]]
}
set dat [my config merge $dictargs]
my config triggers $dat
}
###
# topic: dc9fba12ec23a3ad000c66aea17135a5
###
method config::merge dictargs {
my variable config option_canonical
set rawlist $dictargs
set dictargs {}
set dat [my meta getnull option]
foreach {field val} $rawlist {
set field [string trimleft $field -]
set field [string trimright $field :]
if {[info exists option_canonical($field)]} {
set field $option_canonical($field)
}
dict set dictargs $field $val
}
###
# Validate all inputs
###
foreach {field val} $dictargs {
set script [dict getnull $dat $field validate-command:]
if {$script ne {}} {
dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
}
}
###
# Apply all inputs with special rules
###
foreach {field val} $dictargs {
set script [dict getnull $dat $field set-command:]
dict set config $field $val
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
return $dictargs
}
###
# topic: 543c936485189593f0b9ed79b5d5f2c0
###
method config::triggers dictargs {
set dat [my meta getnull option]
foreach {field val} $dictargs {
set script [dict getnull $dat $field post-command:]
if {$script ne {}} {
{*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
}
}
}
method Option_Default field {
set info [my meta getnull option $field]
set getcmd [dict getnull $info default-command:]
if {$getcmd ne {}} {
return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
} else {
return [dict getnull $info default:]
}
}
}
package provide tool::option 0.1
|