/usr/share/tcltk/tklib0.5/widget/widget.tcl is in tklib 0.5-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 | # -*- tcl -*-
#
# widget.tcl --
#
# megawidget package that uses snit as the object system (snidgets)
#
# Copyright (c) 2005 Jeffrey Hobbs
#
# RCS: @(#) $Id: widget.tcl,v 1.5 2006/09/29 16:25:07 hobbs Exp $
#
package require Tk 8.4
package require snit
#package provide Widget 3.0 ; # at end
namespace eval ::widget {
if 0 {
variable HaveMarlett \
[expr {[lsearch -exact [font families] "Marlett"] != -1}]
snit::macro widget::HaveMarlett {} [list return $::widget::HaveMarlett]
}
}
# widget::propagate -- (snit macro)
#
# Propagates an option to multiple components
#
# Arguments:
# option option definition
# args
# Results:
# Create method Propagate$option
#
snit::macro widget::propagate {option args} {
# propagate option $optDefn ?-default ...? to $components ?as $realopt?
set idx [lsearch -exact $args "to"]
set cmd [linsert [lrange $args 0 [expr {$idx - 1}]] 0 option $option]
foreach {components as what} [lrange $args [expr {$idx + 1}] end] {
break
}
# ensure we have just the option name
set option [lindex $option 0]
set realopt [expr {$what eq "" ? $option : $what}]
lappend cmd -configuremethod Propagate$option
eval $cmd
set body "\n"
foreach comp $components {
append body "\$[list $comp] configure [list $realopt] \$value\n"
}
append body "set [list options($option)] \$value\n"
method Propagate$option {option value} $body
}
if {0} {
# Currently not feasible due to snit's compiler-as-slave-interp
snit::macro widget::tkoption {option args} {
# XXX should support this
# tkoption {-opt opt Opt} ?-default ""? from /wclass/ ?as $wopt?
}
snit::macro widget::tkresource {wclass wopt} {
# XXX should support this
# tkresource $wclass $wopt
set w ".#widget#$wclass"
if {![winfo exists $w]} {
set w [$wclass $w]
}
set value [$w cget $wopt]
after idle [list destroy $w]
return $value
}
}
# widget::tkresource --
#
# Get the default option value from a widget class
#
# Arguments:
# wclass widget class
# wopt widget option
# Results:
# Returns default value of $wclass $wopt value
#
proc widget::tkresource {wclass wopt} {
# XXX should support this
# tkresource $wclass $wopt
set w ".#widget#$wclass"
if {![winfo exists $w]} {
set w [$wclass $w]
}
set value [$w cget $wopt]
after idle [list destroy $w]
return $value
}
# ::widget::validate --
#
# Used by widgets for option validate - *private* spec may change
#
# Arguments:
# as type to compare as
# range range/data info specific to $as
# option option name
# value value being validated
#
# Results:
# Returns error or empty
#
proc ::widget::isa {as args} {
foreach {range option value} $args { break }
if {$as eq "list"} {
if {[lsearch -exact $range $value] == -1} {
return -code error "invalid $option option \"$value\",\
must be one of [join $range {, }]"
}
} elseif {$as eq "boolean" || $as eq "bool"} {
foreach {option value} $args { break }
if {![string is boolean -strict $value]} {
return -code error "$option requires a boolean value"
}
} elseif {$as eq "integer" || $as eq "int"} {
foreach {min max} $range { break }
if {![string is integer -strict $value]
|| ($value < $min) || ($value > $max)} {
return -code error "$option requires an integer in the\
range \[$min .. $max\]"
}
} elseif {$as eq "listofinteger" || $as eq "listofint"} {
if {$range eq ""} { set range [expr {1<<16}] }
set i 0
foreach val $value {
if {![string is integer -strict $val] || ([incr i] > $range)} {
return -code error "$option requires an list of integers"
}
}
} elseif {$as eq "double"} {
foreach {min max} $range { break }
if {![string is double -strict $value]
|| ($value < $min) || ($value > $max)} {
return -code error "$option requires a double in the\
range \[$min .. $max\]"
}
} elseif {$as eq "window"} {
foreach {option value} $args { break }
if {$value eq ""} { return }
if {![winfo exists $value]} {
return -code error "invalid window \"$value\""
}
} else {
return -code error "unknown validate type \"$as\""
}
return
}
package provide widget 3.0
|