######## # # busy: show a watch face while performing a lengthy command. # # Cameron Laird. February 1996 (derived from sources # seen floating about the 'Net). # # The return value is that of [command]. # # Example usages: # busy my_proc # busy "exec some_command its_argument" # busy "proc_name \"This is a string.\"" # # busy does NOT "disable" the mouse pointer. It mutates # its appearance, to convey a bit of information to # those watching, but does NOT alter the way the # application tracks mouse movements, button clicks, # and so on. Tinkering with the event queue, or re- # binding all button-clicks to NOPs for the span of # "busy", as this seems to require, certainly appear # to be technically feasible, but I have had no # recent need to do so. # busy is "re-entrant", in the sense that it behaves # sensibly when it is called, perhaps with some levels # of nesting, by another instance of busy. When it de- # tects this, it simply takes no action having to do # with the cursor. # Notice that busy *does* "update idletasks". Some appli- # cations must manage updates for themselves; busy is # not appropriate for them. # ######## proc busy command { global errorInfo # already_busy is just for communication between # different invocations of busy. Perhaps I'll # mangle the name to make collisions even less # likely. # Maybe I'll use Karl's static. global already_busy if [catch {set already_busy}] { set cursor_mutation_required 1 set already_busy 1 } else { set cursor_mutation_required 0 } # This initialization is needed only when there are no # widgets. This should never arise in practice, but # sometimes it's a distraction in experiments. set busy_list {} # # # set busy {.app .root} # set list [winfo children .] # while {$list != ""} { # set next {} # foreach w $list { # set class [winfo class $w] # set cursor [lindex [$w config -cursor] 4] # if {[winfo toplevel $w] == $w || $cursor != ""} { # lappend busy [list $w $cursor] # } # set next [concat $next [winfo children $w]] # } # set list $next # } # # # if {$cursor_mutation_required} { foreach widget [winfo children .] { # Document the format. lappend busy_list [list $widget \ [lindex [$widget config -cursor] 4]] } foreach widget $busy_list { # I'll improve error-handling someday. # Even better (but only with recent Tk?) is "... -cursor busy". catch {[lindex $widget 0] config -cursor watch} } # Everyone catches up. update idletasks } set error [catch {uplevel eval [list $command]} result] set ei $errorInfo if {$cursor_mutation_required} { foreach widget $busy_list { catch {[lindex $widget 0] \ config -cursor [lindex $widget 1]} } unset already_busy } if {$error} { error [concat $result $ei] # error $result $ei } return $result }