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