/usr/lib/exmh/textButton.tcl is in exmh 1:2.8.0-4.
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 | #
# $Id: textButton.tcl,v 1.3 2000/02/02 19:33:58 valdis Exp $
#
# A text widget button that acts like a Button widget.
# - John Robert LoVerso
#
proc TextButton_Init { {t {}} } {
global tkPriv
set tkPriv(seed) 0
if {[winfo depth .] > 4} {
Preferences_Resource tkPriv(background) c_uri thistle
Preferences_Resource tkPriv(foreground) c_uriFg black
Preferences_Resource tkPriv(activebackground) c_uriAbg white
Preferences_Resource tkPriv(activeforeground) c_uriAfg black
} else {
Preferences_Resource tkPriv(background) c_uri black
Preferences_Resource tkPriv(foreground) c_uriFg white
Preferences_Resource tkPriv(activebackground) c_uriAbg white
Preferences_Resource tkPriv(activeforeground) c_uriAfg black
}
if {$t != {}} {
# Hack - we know tags with names hdrlook=* are preserved.
# These tags just serve to pre-allocate our colors
$t tag configure hdrlook=TextButton1 -foreground $tkPriv(foreground) \
-background $tkPriv(background)
$t tag configure hdrlook=TextButton2 \
-foreground $tkPriv(activeforeground) \
-background $tkPriv(activebackground)
}
}
proc TextButton { w text cmd } {
$w insert insert { }
set start [$w index insert]
$w insert insert $text
set end [$w index insert]
$w insert insert { }
set tag [TextButtonRange $w $start $end $cmd]
}
proc TextButtonRange { w start end cmd } {
global tkPriv
incr tkPriv(seed)
set id tkPriv$tkPriv(seed)
$w tag add $id $start "$end +1 char"
$w tag bind $id <Any-Enter> [concat TextButtonEnter $w $id]
$w tag bind $id <Any-Leave> [concat TextButtonLeave $w $id]
$w tag bind $id <1> [concat TextButtonDown $w $id]
$w tag bind $id <ButtonRelease-1> [concat TextButtonUp $w $id [list $cmd]]
$w tag configure $id -relief raised -borderwidth 2 \
-background $tkPriv(background) -foreground $tkPriv(foreground)
return $id
}
#
#
# from button.tcl --
#
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
proc TextButtonEnter {w id} {
global tkPriv
$w tag configure $id -background $tkPriv(activebackground) \
-foreground $tkPriv(activeforeground)
$w configure -cursor cross
set tkPriv(window) $w
set tkPriv(id) $id
}
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to
# inactive.
proc TextButtonLeave {w id} {
global tkPriv
#puts "Leave"
$w tag configure $id -background $tkPriv(background) \
-foreground $tkPriv(foreground)
$w configure -cursor [option get $w cursor Text ]
set tkPriv(window) ""
set tkPriv(id) ""
set tkPriv(cmd) ""
}
# The procedure below is invoked when the mouse button is pressed in
# a button/radiobutton/checkbutton widget. It records information
# (a) to indicate that the mouse is in the button, and
# (b) to save the button's relief so it can be restored later.
proc TextButtonDown {w id} {
global tkPriv
set tkPriv(relief) [lindex [$w tag config $id -relief] 4]
set tkPriv(buttonWindow) $w
set tkPriv(buttonId) $id
$w tag configure $id -relief sunken
}
# The procedure below is invoked when the mouse button is released
# for a button/radiobutton/checkbutton widget. It restores the
# button's relief and invokes the command as long as the mouse
# hasn't left the button.
proc TextButtonUp {w id {cmd {}}} {
global tkPriv
#puts "Up"
if {$w == $tkPriv(buttonWindow) && $id == $tkPriv(buttonId)} {
$w tag config $id -relief $tkPriv(relief)
if {$w == $tkPriv(window) && $id == $tkPriv(id)} {
set tkPriv(cmd) $cmd
#puts "Primed"
after 1 TextButtonActivate $w $id
}
set tkPriv(buttonWindow) ""
set tkPriv(buttonId) ""
}
}
proc TextButtonActivate {w id} {
global tkPriv
#puts "Activate cmd=$tkPriv(cmd)"
eval $tkPriv(cmd)
}
|