/usr/lib/grass64/bwidget/dynhelp.tcl is in grass-gui 6.4.3-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 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 | # ------------------------------------------------------------------------------
# dynhelp.tcl
# This file is part of Unifix BWidget Toolkit
# $Id: dynhelp.tcl 10192 2002-01-24 19:25:32Z radim $
# ------------------------------------------------------------------------------
# Index of commands:
# - DynamicHelp::configure
# - DynamicHelp::include
# - DynamicHelp::sethelp
# - DynamicHelp::register
# - DynamicHelp::_motion_balloon
# - DynamicHelp::_motion_info
# - DynamicHelp::_leave_info
# - DynamicHelp::_menu_info
# - DynamicHelp::_show_help
# - DynamicHelp::_init
# ------------------------------------------------------------------------------
namespace eval DynamicHelp {
Widget::declare DynamicHelp {
{-foreground TkResource black 0 label}
{-background TkResource "#FFFFC0" 0 label}
{-borderwidth TkResource 1 0 label}
{-justify TkResource left 0 label}
{-font TkResource "helvetica 8" 0 label}
{-delay Int 600 0 {=100 =2000}}
{-bd Synonym -borderwidth}
{-bg Synonym -background}
{-fg Synonym -foreground}
}
proc use {} {}
variable _registered
variable _top ".help_shell"
variable _id ""
variable _delay 600
variable _current ""
variable _saved
Widget::init DynamicHelp $_top {}
bind BwHelpBalloon <Enter> {DynamicHelp::_motion_balloon enter %W %X %Y}
bind BwHelpBalloon <Motion> {DynamicHelp::_motion_balloon motion %W %X %Y}
bind BwHelpBalloon <Leave> {DynamicHelp::_motion_balloon leave %W %X %Y}
bind BwHelpBalloon <Button> {DynamicHelp::_motion_balloon button %W %X %Y}
bind BwHelpBalloon <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
bind BwHelpVariable <Enter> {DynamicHelp::_motion_info %W}
bind BwHelpVariable <Motion> {DynamicHelp::_motion_info %W}
bind BwHelpVariable <Leave> {DynamicHelp::_leave_info %W}
bind BwHelpVariable <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
bind BwHelpMenu <Unmap> {DynamicHelp::_menu_info unmap %W}
bind BwHelpMenu <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::configure
# ------------------------------------------------------------------------------
proc DynamicHelp::configure { args } {
variable _top
variable _delay
set res [Widget::configure $_top $args]
if { [Widget::hasChanged $_top -delay val] } {
set _delay $val
}
return $res
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::include
# ------------------------------------------------------------------------------
proc DynamicHelp::include { class type } {
set helpoptions {
{-helptext String "" 0}
{-helpvar String "" 0}}
lappend helpoptions [list -helptype Enum $type 0 {balloon variable}]
Widget::declare $class $helpoptions
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::sethelp
# ------------------------------------------------------------------------------
proc DynamicHelp::sethelp { path subpath {force 0}} {
set ctype [Widget::hasChanged $path -helptype htype]
set ctext [Widget::hasChanged $path -helptext htext]
set cvar [Widget::hasChanged $path -helpvar hvar]
if { $force || $ctype || $ctext || $cvar } {
switch $htype {
balloon {
return [register $subpath balloon $htext]
}
variable {
return [register $subpath variable $hvar $htext]
}
}
return [register $subpath $htype]
}
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::register
# ------------------------------------------------------------------------------
proc DynamicHelp::register { path type args } {
variable _registered
if { [winfo exists $path] } {
set evt [bindtags $path]
set idx [lsearch $evt "BwHelp*"]
set evt [lreplace $evt $idx $idx]
switch $type {
balloon {
set text [lindex $args 0]
if { $text != "" } {
set _registered($path) $text
lappend evt BwHelpBalloon
} else {
catch {unset _registered($path)}
}
bindtags $path $evt
return 1
}
variable {
set var [lindex $args 0]
set text [lindex $args 1]
if { $text != "" && $var != "" } {
set _registered($path) [list $var $text]
lappend evt BwHelpVariable
} else {
catch {unset _registered($path)}
}
bindtags $path $evt
return 1
}
menu {
set cpath [BWidget::clonename $path]
if { [winfo exists $cpath] } {
set path $cpath
}
set var [lindex $args 0]
if { $var != "" } {
set _registered($path) [list $var]
lappend evt BwHelpMenu
} else {
catch {unset _registered($path)}
}
bindtags $path $evt
return 1
}
menuentry {
set cpath [BWidget::clonename $path]
if { [winfo exists $cpath] } {
set path $cpath
}
if { [info exists _registered($path)] } {
if { [set index [lindex $args 0]] != "" } {
set text [lindex $args 1]
set idx [lsearch $_registered($path) [list $index *]]
if { $text != "" } {
if { $idx == -1 } {
lappend _registered($path) [list $index $text]
} else {
set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
}
} else {
set _registered($path) [lreplace $_registered($path) $idx $idx]
}
}
return 1
}
return 0
}
}
catch {unset _registered($path)}
bindtags $path $evt
return 1
} else {
catch {unset _registered($path)}
return 0
}
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::_motion_balloon
# ------------------------------------------------------------------------------
proc DynamicHelp::_motion_balloon { type path x y } {
variable _top
variable _id
variable _delay
variable _current
if { $_current != $path && $type == "enter" } {
set _current $path
set type "motion"
destroy $_top
}
if { $_current == $path } {
if { $_id != "" } {
after cancel $_id
set _id ""
}
if { $type == "motion" } {
if { ![winfo exists $_top] } {
set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
}
} else {
destroy $_top
set _current ""
}
}
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::_motion_info
# ------------------------------------------------------------------------------
proc DynamicHelp::_motion_info { path } {
variable _registered
variable _current
variable _saved
if { $_current != $path && [info exists _registered($path)] } {
if { ![info exists _saved] } {
set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
}
GlobalVar::setvar [lindex $_registered($path) 0] [lindex $_registered($path) 1]
set _current $path
}
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::_leave_info
# ------------------------------------------------------------------------------
proc DynamicHelp::_leave_info { path } {
variable _registered
variable _current
variable _saved
if { [info exists _registered($path)] } {
GlobalVar::setvar [lindex $_registered($path) 0] $_saved
}
unset _saved
set _current ""
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::_menu_info
# Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
# under windows for menu.
# ------------------------------------------------------------------------------
proc DynamicHelp::_menu_info { event path } {
variable _registered
if { [info exists _registered($path)] } {
set index [$path index active]
if { [string compare $index "none"] &&
[set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
GlobalVar::setvar [lindex $_registered($path) 0] \
[lindex [lindex $_registered($path) $idx] 1]
} else {
GlobalVar::setvar [lindex $_registered($path) 0] ""
}
}
}
# ------------------------------------------------------------------------------
# Command DynamicHelp::_show_help
# ------------------------------------------------------------------------------
proc DynamicHelp::_show_help { path x y } {
variable _top
variable _registered
variable _id
variable _delay
if { [info exists _registered($path)] } {
destroy $_top
toplevel $_top -relief flat \
-bg [Widget::getoption $_top -foreground] \
-bd [Widget::getoption $_top -borderwidth]
wm overrideredirect $_top 1
wm transient $_top
wm withdraw $_top
label $_top.label -text $_registered($path) \
-relief flat -bd 0 -highlightthickness 0 \
-foreground [Widget::getoption $_top -foreground] \
-background [Widget::getoption $_top -background] \
-font [Widget::getoption $_top -font] \
-justify [Widget::getoption $_top -justify]
pack $_top.label -side left
update idletasks
set scrwidth [winfo vrootwidth .]
set scrheight [winfo vrootheight .]
set width [winfo reqwidth $_top]
set height [winfo reqheight $_top]
incr y 12
incr x 8
if { $x+$width > $scrwidth } {
set x [expr $scrwidth - $width]
}
if { $y+$height > $scrheight } {
set y [expr $y - 12 - $height]
}
wm geometry $_top "+$x+$y"
update idletasks
wm deiconify $_top
}
}
|