1# util-tk.tcl --
2#
3#	This file implements package ::Utility::tk, which  ...
4#
5# Copyright (c) 1997-8 Jeffrey Hobbs
6#
7# See the file "license.terms" for information on usage and
8# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9#
10
11package require Tk
12package require ::Utility
13package provide ::Utility::tk 1.0
14
15namespace eval ::Utility::tk {;
16
17namespace export -clear *
18
19## PROBLEM HERE
20##
21## Only uncomment one of the following namespace import lines
22##
23
24## This is what I theoretically need, but it causes the Abort in
25## regular wish.  This works for wish with TCL_MEM_DEBUG.
26#namespace import -force ::Utility::get_opts ::Utility::highlight
27
28## This works, but is essentially useless in my situation
29#namespace import -force ::Utility::expand::* ::Utility::dump::*
30
31## This works too, but is silly
32after idle [namespace code [list namespace import -force \
33	::Utility::highlight ::Utility::get_opts]]
34
35## This causes constant Bus Error on startup with regular wish
36## but the Abort with debugging wish.
37#namespace import -force ::Utility::*
38
39## The abort message mentioned above is:
40
41#DeleteImportedCmd: did not find cmd in real cmd's list of import references
42#Abort
43
44## If I try loading the above interactively as opposed to the tour at
45## command line, I get a seg fault instead of a bus error.
46
47##
48## YOU CAN IGNORE THE REST
49##
50
51# warn --
52#
53#   Simple warning alias to ease programming
54#
55# Arguments:
56#   msg		The warning message to display
57# Results:
58#   Returns nothing important.
59#
60proc warn {msg} {
61    bell
62    tk_dialog .__warning Warning $msg warning 0 OK
63}
64
65# place_window --
66#   place a toplevel at a particular position
67# Arguments:
68#   toplevel	name of toplevel window
69#   ?placement?	pointer ?center? ; places $w centered on the pointer
70#		widget widget_name ; centers $w over widget_name
71#		defaults to placing toplevel in the middle of the screen
72#   ?anchor?
73# Results:
74#   Returns nothing
75#
76proc place_window {w {placement ""} {anchor ""}} {
77    wm withdraw $w
78    update idletasks
79    switch -glob -- $placement {
80	p*	{ ## place at POINTER (centered is $anchor == center)
81	    if {[string match "c*" $anchor]} {
82		wm geometry $w +[expr \
83			{[winfo pointerx $w]-[winfo width $w]/2}]+[expr \
84			{[winfo pointery $w]-[winfo height $w]/2}]
85	    } else {
86		wm geometry $w +[winfo pointerx $w]+[winfo pointery $w]
87	    }
88	}
89	w*	{ ## center about WIDGET $anchor
90	    wm geometry $w +[expr {[winfo rootx $anchor]+([winfo width \
91		    $anchor]-[winfo width $w])/2}]+[expr {[winfo rooty \
92		    $anchor]+([winfo height $anchor]-[winfo height $w])/2}]
93	}
94	default	{
95	    wm geometry $w +[expr {([winfo screenwidth $w]-\
96		    [winfo reqwidth $w])/2}]+[expr \
97		    {([winfo screenheight $w]-[winfo reqheight $w])/2}]
98	}
99    }
100    wm deiconify $w
101}
102
103## Centers the canvas around points x & y
104##
105## Unoptimized, this looks like:
106##    set xtenth [expr .10 * [winfo width $w]]
107##    set ytenth [expr .10 * [winfo height $w]]
108##    set X [expr [winfo width $w] / 2]
109##    set Y [expr [winfo height $w] / 2]
110##    set x1 [expr round(($x-$X)/$xtenth)]
111##    set y1 [expr round(($y-$Y)/$ytenth)]
112##    $w xview scroll $x1 units
113##    $w yview scroll $y1 units
114##
115proc canvas_center {w x y} {
116    $w xview scroll [expr {round(10.0*$x/[winfo width $w]-5)}] units
117    $w yview scroll [expr {round(10.0*$y/[winfo height $w]-5)}] units
118}
119
120## "see" method alternative for canvas
121## Aligns the named item as best it can in the middle of the screen
122## Behavior depends on whether -scrollregion is set
123##
124## c    - a canvas widget
125## item - a canvas tagOrId
126proc canvas_see {c item} {
127    set box [$c bbox $item]
128    if {[string match {} $box]} return
129    if {[string match {} [$c cget -scrollregion]]} {
130	## People really should set -scrollregion you know...
131	foreach {x y x1 y1} $box {
132	    set x [expr {round(2.5*($x1+$x)/[winfo width $c])}]
133	    set y [expr {round(2.5*($y1+$y)/[winfo height $c])}]
134	}
135	$c xview moveto 0
136	$c yview moveto 0
137	$c xview scroll $x units
138	$c yview scroll $y units
139    } else {
140	## If -scrollregion is set properly, use this
141	foreach {x y x1 y1} $box {top btm} [$c yview] {left right} [$c xview] \
142		{p q xmax ymax} [$c cget -scrollregion] {
143	    set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}]
144	    set ypos [expr {(($y1+$y)/2.0)/$ymax - ($btm-$top)/2.0}]
145	}
146	$c xview moveto $xpos
147	$c yview moveto $ypos
148    }
149}
150
151## Set cursor of widget $w and its descendants to $cursor
152## Ignores {} cursors
153proc cursor_set {w cursor} {
154    variable CURSOR
155    if {[string compare {} [set CURSOR($w) [$w cget -cursor]]]} {
156	$w config -cursor $cursor
157    } else {
158	unset CURSOR($w)
159    }
160    foreach child [winfo children $w] { cursor_set $child $cursor }
161}
162
163## Restore cursor based on CURSOR($w) for $w and its descendants
164## $cursor is the default cursor (if none was cached)
165proc cursor_restore {w {cursor {}}} {
166    variable CURSOR
167    if {[info exists CURSOR($w)]} {
168	$w config -cursor $CURSOR($w)
169    } else {
170	$w config -cursor $cursor
171    }
172    foreach child [winfo children $w] { cursor_restore $child $cursor }
173}
174
175# highlight_dialog --
176#
177#   creates minimal dialog interface to highlight
178#
179# Arguments:
180#   w	text widget
181#   str	optional seed string for HIGHLIGHT(string)
182# Results:
183#   Returns null.
184#
185proc highlight_dialog {w {str {}}} {
186    variable HIGHLIGHT
187
188    set namesp [namespace current]
189    set var ${namesp}::HIGHLIGHT
190    set base $w.__highlight
191    if {![winfo exists $base]} {
192	toplevel $base
193	wm withdraw $base
194	wm title $base "Find String"
195
196	pack [frame $base.f] -fill x -expand 1
197	label $base.f.l -text "Find:"
198	entry $base.f.e -textvariable ${var}($w,string)
199	pack [frame $base.opt] -fill x
200	checkbutton $base.opt.c -text "Case Sensitive" \
201		-variable ${var}($w,nocase)
202	checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp)
203	pack $base.f.l -side left
204	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
205	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
206	pack [frame $base.btn] -fill both
207	button $base.btn.fnd -text "Find" -width 6
208	button $base.btn.clr -text "Clear" -width 6
209	button $base.btn.dis -text "Dismiss" -width 6
210	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
211		-side left -fill both
212
213	focus $base.f.e
214
215	bind $base.f.e <Return> [list $base.btn.fnd invoke]
216	bind $base.f.e <Escape> [list $base.btn.dis invoke]
217    }
218    ## FIX namespace
219    $base.btn.fnd config -command [namespace code \
220	    "highlight [list $w] \[set ${var}($w,string)\] \
221	    \[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \
222	    \[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \
223	    -tag __highlight -color [list yellow]"]
224    $base.btn.clr config -command \
225	    "[list $w] tag remove __highlight 1.0 end;\
226	    set [list ${var}($w,string)] {}"
227    $base.btn.dis config -command \
228	    "[list $w] tag remove __highlight 1.0 end;\
229	    wm withdraw [list $base]"
230    if {[string compare {} $str]} {
231	set ${var}($w,string) $str
232	$base.btn.fnd invoke
233    }
234
235    if {[string compare normal [wm state $base]]} {
236	wm deiconify $base
237    } else {
238	raise $base
239    }
240    $base.f.e select range 0 end
241}
242
243
244}; # end namespace ::Utility::Tk
245