/usr/lib/exmh/busy.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 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 | #
# busy.tcl
#
# Busy feedback.
#
# Copyright (c) 1993 Xerox Corporation.
# Use and copying of this software and preparation of derivative works based
# upon this software are permitted. Any distribution of this software or
# derivative works must comply with all applicable United States export
# control laws. This software is made available AS IS, and Xerox Corporation
# makes no warranty about the software, its performance or its conformity to
# any specification.
proc Busy_Init {} {
global busy exmh
Preferences_Add "Busy Indicator" \
"These items affect how exmh indicates it is busy." \
[list \
{busy(style) busyStyle {CHOICE cursor icon cursorAll none} {How to indicate busy}
"icon - show a bitmap in the faces display.
cursor - change the cursor to a busy indicator.
cursorAll - Like cursor, but hits all widgets and takes longer.
none - do nothing."} \
[list busy(cursor) busyCursor watch {Cursor for busy indicator} \
"This is a TK specification for a cursor. You can use a standard
X cursor, like \"watch\", or provide your own bitmaps and mask
with \"@filename\". You can optionally provide foreground and
background colors. (See Tk_GetCursor for complete details).
A final twist is that relative pathnames are munged to be
absolute pathnames under $exmh(bitmaps)
Examples include:
watch - standard watch
watch blue - a clear and blue watch
watch blue white - a white and blue watch
@timer.bitmap black - 16x16 timer/watch (need fg color!)
@hourglass1.bitmap black - Standard wish hourglass
@hourglass2.bitmap blue - Large 32x32 hourglass, in blue
@hourglass2.bitmap hourglass2.mask red black - (need two colors!)
@/usr/foo/exmh/bar.mask /usr/foo/exmh/bar.bitmap black yellow
"] \
[list busy(bitmap) busyBitmap @hourglass2.bitmap {Bitmap for busy indicator} \
"This is a TK specification for a bitmap. There are only a few
boring built-in bitmaps, so mostly you specify these with the
@pathname syntax. A relative pathname is munged to be an
absolute pathname under $exmh(bitmaps)
Examples include:
@hourglass1.bitmap - Standard wish hourglass
@hourglass1.bitmap blue - Blue wish hourglass
@/usr/foo/exmh/bar.bitmap
"] \
]
set busy(color) black
trace variable busy(cursor) w BusyFixupCursor
BusyFixupCursor
trace variable busy(bitmap) w BusyFixupBitmap
BusyFixupBitmap
}
proc BusyFixupCursor { args } {
global busy exmh
# busy(cursor) could be
# @foo.cursor bar.cursor color color
# Here we insert the exmh bitmap library
switch -regexp $busy(cursor) {
{^@[^/]} {
regsub @(.*) $busy(cursor) $exmh(bitmaps)/\\1 newfile
if ![file exists [lindex $newfile 0]] {
Exmh_Status "Invalid file [lindex $newfile 0]"
return
}
if {[llength $newfile] > 2} {
regsub {([^ ]*) (.*)} $newfile "\\1 $exmh(bitmaps)/\\2" newfile
}
set busy(Xcursor) @$newfile
}
.* {
set busy(Xcursor) $busy(cursor)
}
}
}
proc BusyFixupBitmap { args } {
global busy exmh
# busy(bitmap) could be
# @foo.bitmap bar.bitmap color color
# Here we insert the exmh bitmap library
switch -regexp $busy(bitmap) {
{^@[^/]} {
regsub @(.*) $busy(bitmap) $exmh(bitmaps)/\\1 newfile
set color [lindex $newfile 1]
set newfile [lindex $newfile 0]
if [file exists $newfile] {
set busy(Xbitmap) @$newfile
} else {
Exmh_Status "Invalid file $newfile"
return
}
}
.* {
set busy(Xbitmap) [lindex $busy(bitmap) 0]
set color [lindex $busy(bitmap) 1]
}
}
if {[string length $color]} {
set busy(color) $color
} else {
set busy(color) black
}
}
proc busy { args } {
global busy
switch $busy(style) {
icon {busyIcon $args}
cursorAll {busyCursor $args}
cursor {busyCursorHack $args}
default {eval $args}
}
}
proc busyIcon { cmd } {
global errorInfo busy
set parent [Face_BusyParent]
# Recreate the widget every time so that display works properly
if [catch {
set label \
[label $parent.busy -foreground $busy(color) -bitmap $busy(Xbitmap)]
Face_BusyPlace $label
} err] {
Exmh_Debug "busyIcon" $err
}
set error [catch {uplevel #0 $cmd} result]
set ei $errorInfo
if [info exists label] {
Face_BusyDestroy $label
}
if $error {
error $result $ei
} else {
return $result
}
}
proc busyCursorInner { cmd widgets } {
global errorInfo busy
foreach w $widgets {
catch {[lindex $w 0] config -cursor $busy(Xcursor)}
}
update idletasks
set error [catch {uplevel #0 $cmd} result]
set ei $errorInfo
foreach w $widgets {
catch {[lindex $w 0] config -cursor [lindex $w 1]}
}
if $error {
error $result $ei
} else {
return $result
}
}
proc busyCursorHack {cmd} {
set widgets {}
catch {
#Fdisp_Busy
global fdisp
foreach can {canvas cache} {
if [info exists fdisp($can)] {
set w $fdisp($can)
set cursor [lindex [$w config -cursor] 4]
lappend widgets [list $w $cursor]
}
}
#Exwin_Busy
global exwin
foreach w [list $exwin(mtext) $exwin(ftext)] {
set cursor [lindex [$w config -cursor] 4]
lappend widgets [list $w $cursor]
}
#Sedit_Busy
global sedit
foreach w $sedit(allids) {
set cursor [lindex [$w config -cursor] 4]
lappend widgets [list $w $cursor]
}
#Label_Busy
global label
foreach w [list $label(main) $label(folder) $label(message) $exwin(status)] {
set cursor [lindex [$w config -cursor] 4]
lappend widgets [list $w $cursor]
}
}
return [busyCursorInner $cmd $widgets]
}
proc busyCursor {cmd} {
set widgets {.app .root}
set list [winfo children .]
while {$list != ""} {
set next {}
foreach w $list {
set cursor [lindex [$w config -cursor] 4]
lappend widgets [list $w $cursor]
set next [concat $next [winfo children $w]]
}
set list $next
}
return [busyCursorInner $cmd $widgets]
}
|