1# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
2#
3#	$Id: Utils.tcl,v 1.4 2004/03/28 02:44:57 hobbs Exp $
4#
5# Util.tcl --
6#
7#	The Tix utility commands. Some of these commands are
8#	replacement of or extensions to the existing TK
9#	commands. Occasionaly, you have to use the commands inside
10#	this file instead of thestandard TK commands to make your
11#	applicatiion work better with Tix. Please read the
12#	documentations (programmer's guide, man pages) for information
13#	about these utility commands.
14#
15# Copyright (c) 1993-1999 Ioi Kim Lam.
16# Copyright (c) 2000-2001 Tix Project Group.
17# Copyright (c) 2004 ActiveState
18#
19# See the file "license.terms" for information on usage and redistribution
20# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
21#
22
23
24#
25# kludge: should be able to handle all kinds of flags
26#         now only handles "-flag value" pairs.
27#
28proc tixHandleArgv {p_argv p_options validFlags} {
29    upvar $p_options opt
30    upvar $p_argv    argv
31
32    set old_argv $argv
33    set argv ""
34
35    foreac {flag value} $old_argv {
36	if {[lsearch $validFlags $flag] != -1} {
37	    # The caller will handle this option exclusively
38	    # It won't be added back to the original arglist
39	    #
40	    eval $opt($flag,action) $value
41	} else {
42	    # The caller does not handle this option
43	    #
44	    lappend argv $flag
45	    lappend argv $value
46	}
47    }
48}
49
50#-----------------------------------------------------------------------
51# tixDisableAll -
52#
53# 	Disable all members in a sub widget tree
54#
55proc tixDisableAll {w} {
56    foreach x [tixDescendants $w] {
57	catch {$x config -state disabled}
58    }
59}
60
61#----------------------------------------------------------------------
62# tixEnableAll -
63#
64# 	enable all members in a sub widget tree
65#
66proc tixEnableAll {w} {
67    foreach x [tixDescendants $w] {
68	catch {$x config -state normal}
69    }
70}
71
72#----------------------------------------------------------------------
73# tixDescendants -
74#
75#	Return a list of all the member of a widget subtree, including
76# the tree's root widget.
77#
78proc tixDescendants {parent} {
79    set des ""
80    lappend des $parent
81
82    foreach w [winfo children $parent] {
83	foreach x [tixDescendants $w] {
84	    lappend des $x
85	}
86    }
87    return $des
88}
89
90#----------------------------------------------------------------------
91# tixTopLevel -
92#
93#	Create a toplevel widget and unmap it immediately. This will ensure
94# that this toplevel widgets will not be popped up prematurely when you
95# create Tix widgets inside it.
96#
97#	"tixTopLevel" also provide options for you to specify the appearance
98# and behavior of this toplevel.
99#
100#
101#
102proc tixTopLevel {w args} {
103    set opt (-geometry) ""
104    set opt (-minsize)  ""
105    set opt (-maxsize)  ""
106    set opt (-width)    ""
107    set opt (-height)   ""
108
109    eval [linsert $args 0 toplevel $w]
110    wm withdraw $w
111}
112
113# This is a big kludge
114#
115#	Substitutes all [...] and $.. in the string in $args
116#
117proc tixInt_Expand {args} {
118    return $args
119}
120
121# Print out all the config options of a widget
122#
123proc tixPConfig {w} {
124    puts [join [lsort [$w config]] \n]
125}
126
127proc tixAppendBindTag {w tag} {
128    bindtags $w [concat [bindtags $w] $tag]
129}
130
131proc tixAddBindTag {w tag} {
132    bindtags $w [concat $tag [bindtags $w] ]
133}
134
135proc tixSubwidgetRef {sub} {
136    return $::tixSRef($sub)
137}
138
139proc tixSubwidgetRetCreate {sub ref} {
140    set ::tixSRef($sub) $ref
141}
142
143proc tixSubwidgetRetDelete {sub} {
144    catch {unset ::tixSRef($sub)}
145}
146
147proc tixListboxGetCurrent {listbox} {
148    return [tixEvent flag V]
149}
150
151
152# tixSetMegaWidget --
153#
154#	Associate a subwidget with its mega widget "owner". This is mainly
155#	used when we add a new bindtag to a subwidget and we need to find out
156#	the name of the mega widget inside the binding.
157#
158proc tixSetMegaWidget {w mega {type any}} {
159    set ::tixMega($type,$w) $mega
160}
161
162proc tixGetMegaWidget {w {type any}} {
163    return $::tixMega($type,$w)
164}
165
166proc tixUnsetMegaWidget {w} {
167    if {[info exists ::tixMega($w)]} { unset ::tixMega($w) }
168}
169
170# tixBusy : display busy cursors on a window
171#
172#
173# Should flush the event queue (but not do any idle tasks) before blocking
174# the target window (I am not sure if it is aready doing so )
175#
176# ToDo: should take some additional windows to raise
177#
178proc tixBusy {w flag {focuswin ""}} {
179
180    if {[info command tixInputOnly] == ""} {
181	return
182    }
183
184    global tixBusy
185    set toplevel [winfo toplevel $w]
186
187    if {![info exists tixBusy(cursor)]} {
188	set tixBusy(cursor) watch
189#	set tixBusy(cursor) "[tix getbitmap hourglass] \
190#	    [string range [tix getbitmap hourglass.mask] 1 end]\
191# 	    black white"
192    }
193
194    if {$toplevel eq "."} {
195	set inputonly0 .__tix__busy0
196	set inputonly1 .__tix__busy1
197	set inputonly2 .__tix__busy2
198	set inputonly3 .__tix__busy3
199    } else {
200	set inputonly0 $toplevel.__tix__busy0
201	set inputonly1 $toplevel.__tix__busy1
202	set inputonly2 $toplevel.__tix__busy2
203	set inputonly3 $toplevel.__tix__busy3
204    }
205
206    if {![winfo exists $inputonly0]} {
207	for {set i 0} {$i < 4} {incr i} {
208	    tixInputOnly [set inputonly$i] -cursor $tixBusy(cursor)
209	}
210    }
211
212    if {$flag eq "on"} {
213	if {$focuswin != "" && [winfo id $focuswin] != 0} {
214	    if {[info exists tixBusy($focuswin,oldcursor)]} {
215		return
216	    }
217	    set tixBusy($focuswin,oldcursor) [$focuswin cget -cursor]
218	    $focuswin config -cursor $tixBusy(cursor)
219
220	    set x1 [expr {[winfo rootx $focuswin]-[winfo rootx $toplevel]}]
221	    set y1 [expr {[winfo rooty $focuswin]-[winfo rooty $toplevel]}]
222
223	    set W  [winfo width $focuswin]
224	    set H  [winfo height $focuswin]
225	    set x2 [expr {$x1 + $W}]
226	    set y2 [expr {$y1 + $H}]
227
228
229	    if {$y1 > 0} {
230		tixMoveResizeWindow $inputonly0 0   0   10000 $y1
231	    }
232	    if {$x1 > 0} {
233		tixMoveResizeWindow $inputonly1 0   0   $x1   10000
234	    }
235	    tixMoveResizeWindow $inputonly2 0   $y2 10000 10000
236	    tixMoveResizeWindow $inputonly3 $x2 0   10000 10000
237
238	    for {set i 0} {$i < 4} {incr i} {
239		tixMapWindow [set inputonly$i]
240		tixRaiseWindow [set inputonly$i]
241	    }
242	    tixFlushX $w
243	} else {
244	    tixMoveResizeWindow $inputonly0 0 0 10000 10000
245	    tixMapWindow $inputonly0
246	    tixRaiseWindow $inputonly0
247	}
248    } else {
249	tixUnmapWindow $inputonly0
250	tixUnmapWindow $inputonly1
251	tixUnmapWindow $inputonly2
252	tixUnmapWindow $inputonly3
253
254	if {$focuswin != "" && [winfo id $focuswin] != 0} {
255	    if {[info exists tixBusy($focuswin,oldcursor)]} {
256		$focuswin config -cursor $tixBusy($focuswin,oldcursor)
257		if {[info exists tixBusy($focuswin,oldcursor)]} {
258		    unset tixBusy($focuswin,oldcursor)
259		}
260	    }
261	}
262    }
263}
264
265proc tixOptionName {w} {
266    return [string range $w 1 end]
267}
268
269proc tixSetSilent {chooser value} {
270    $chooser config -disablecallback true
271    $chooser config -value $value
272    $chooser config -disablecallback false
273}
274
275# This command is useful if you want to ingore the arguments
276# passed by the -command or -browsecmd options of the Tix widgets. E.g
277#
278# tixFileSelectDialog .c -command "puts foo; tixBreak"
279#
280#
281proc tixBreak {args} {}
282
283#----------------------------------------------------------------------
284# tixDestroy -- deletes a Tix class object (not widget classes)
285#----------------------------------------------------------------------
286proc tixDestroy {w} {
287    upvar #0 $w data
288
289    set destructor ""
290    if {[info exists data(className)]} {
291	catch {
292	    set destructor [tixGetMethod $w $data(className) Destructor]
293	}
294    }
295    if {$destructor != ""} {
296	$destructor $w
297    }
298    catch {rename $w ""}
299    catch {unset data}
300    return ""
301}
302
303proc tixPushGrab {args} {
304    global tix_priv
305
306    if {![info exists tix_priv(grab-list)]} {
307	set tix_priv(grab-list)    ""
308	set tix_priv(grab-mode)    ""
309	set tix_priv(grab-nopush) ""
310    }
311
312    set len [llength $args]
313    if {$len == 1} {
314	set opt ""
315	set w [lindex $args 0]
316    } elseif {$len == 2} {
317	set opt [lindex $args 0]
318	set w [lindex $args 1]
319    } else {
320	error "wrong # of arguments: tixPushGrab ?-global? window"
321    }
322
323    # Not everyone will call tixPushGrab. If someone else has a grab already
324    # save that one as well, so that we can restore that later
325    #
326    set last [lindex $tix_priv(grab-list) end]
327    set current [grab current $w]
328
329    if {$current ne "" && $current ne $last} {
330	# Someone called "grab" directly
331	#
332	lappend tix_priv(grab-list)   $current
333	lappend tix_priv(grab-mode)   [grab status $current]
334	lappend tix_priv(grab-nopush) 1
335    }
336
337    # Now push myself into the stack
338    #
339    lappend tix_priv(grab-list)   $w
340    lappend tix_priv(grab-mode)   $opt
341    lappend tix_priv(grab-nopush) 0
342
343    if {$opt eq "-global"} {
344	grab -global $w
345    } else {
346	grab $w
347    }
348}
349
350proc tixPopGrab {} {
351    global tix_priv
352
353    if {![info exists tix_priv(grab-list)]} {
354	set tix_priv(grab-list)   ""
355	set tix_priv(grab-mode)   ""
356	set tix_priv(grab-nopush) ""
357    }
358
359    set len [llength $tix_priv(grab-list)]
360    if {$len <= 0} {
361	error "no window is grabbed by tixGrab"
362    }
363
364    set w [lindex $tix_priv(grab-list) end]
365    grab release $w
366
367    if {$len > 1} {
368	set tix_priv(grab-list)   [lrange $tix_priv(grab-list) 0 end-1]
369	set tix_priv(grab-mode)   [lrange $tix_priv(grab-mode) 0 end-1]
370	set tix_priv(grab-nopush) [lrange $tix_priv(grab-nopush) 0 end-1]
371
372	set w  [lindex $tix_priv(grab-list) end]
373	set m  [lindex $tix_priv(grab-list) end]
374	set np [lindex $tix_priv(grab-nopush) end]
375
376	if {$np == 1} {
377	    # We have a grab set by "grab"
378	    #
379	    set len [llength $tix_priv(grab-list)]
380
381	    if {$len > 1} {
382		set tix_priv(grab-list)   [lrange $tix_priv(grab-list) 0 end-1]
383		set tix_priv(grab-mode)   [lrange $tix_priv(grab-mode) 0 end-1]
384		set tix_priv(grab-nopush) \
385		    [lrange $tix_priv(grab-nopush) 0 end-1]
386	    } else {
387		set tix_priv(grab-list)   ""
388		set tix_priv(grab-mode)   ""
389		set tix_priv(grab-nopush) ""
390	    }
391	}
392
393	if {$m == "-global"} {
394	    grab -global $w
395	} else {
396	    grab $w
397	}
398    } else {
399  	set tix_priv(grab-list)   ""
400	set tix_priv(grab-mode)   ""
401	set tix_priv(grab-nopush) ""
402    }
403}
404
405proc tixWithinWindow {wid rootX rootY} {
406    set wc  [winfo containing $rootX $rootY]
407    if {$wid eq $wc} { return 1 }
408
409    # no see if it is an enclosing parent
410    set rx1 [winfo rootx $wid]
411    set ry1 [winfo rooty $wid]
412    set rw  [winfo width  $wid]
413    set rh  [winfo height $wid]
414    set rx2 [expr {$rx1+$rw}]
415    set ry2 [expr {$ry1+$rh}]
416
417    if {$rootX >= $rx1 && $rootX < $rx2 && $rootY >= $ry1 && $rootY < $ry2} {
418	return 1
419    } else {
420	return 0
421    }
422}
423
424proc tixWinWidth {w} {
425    set W [winfo width $w]
426    set bd [expr {[$w cget -bd] + [$w cget -highlightthickness]}]
427
428    return [expr {$W - 2*$bd}]
429}
430
431proc tixWinHeight {w} {
432    set H [winfo height $w]
433    set bd [expr {[$w cget -bd] + [$w cget -highlightthickness]}]
434
435    return [expr {$H - 2*$bd}]
436}
437
438# junk?
439#
440proc tixWinCmd {w} {
441    return [winfo command $w]
442}
443