245 lines
7.0 KiB
Tcl
245 lines
7.0 KiB
Tcl
|
# util-tk.tcl --
|
||
|
|
#
|
||
|
|
# This file implements package ::Utility::tk, which ...
|
||
|
|
#
|
||
|
|
# Copyright (c) 1997-8 Jeffrey Hobbs
|
||
|
|
#
|
||
|
|
# See the file "license.terms" for information on usage and
|
||
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
|
|
#
|
||
|
|
|
||
|
|
package require Tk
|
||
|
|
package require ::Utility
|
||
|
|
package provide ::Utility::tk 1.0
|
||
|
|
|
||
|
|
namespace eval ::Utility::tk {;
|
||
|
|
|
||
|
|
namespace export -clear *
|
||
|
|
|
||
|
|
## PROBLEM HERE
|
||
|
|
##
|
||
|
|
## Only uncomment one of the following namespace import lines
|
||
|
|
##
|
||
|
|
|
||
|
|
## This is what I theoretically need, but it causes the Abort in
|
||
|
|
## regular wish. This works for wish with TCL_MEM_DEBUG.
|
||
|
|
#namespace import -force ::Utility::get_opts ::Utility::highlight
|
||
|
|
|
||
|
|
## This works, but is essentially useless in my situation
|
||
|
|
#namespace import -force ::Utility::expand::* ::Utility::dump::*
|
||
|
|
|
||
|
|
## This works too, but is silly
|
||
|
|
after idle [namespace code [list namespace import -force \
|
||
|
|
::Utility::highlight ::Utility::get_opts]]
|
||
|
|
|
||
|
|
## This causes constant Bus Error on startup with regular wish
|
||
|
|
## but the Abort with debugging wish.
|
||
|
|
#namespace import -force ::Utility::*
|
||
|
|
|
||
|
|
## The abort message mentioned above is:
|
||
|
|
|
||
|
|
#DeleteImportedCmd: did not find cmd in real cmd's list of import references
|
||
|
|
#Abort
|
||
|
|
|
||
|
|
## If I try loading the above interactively as opposed to the tour at
|
||
|
|
## command line, I get a seg fault instead of a bus error.
|
||
|
|
|
||
|
|
##
|
||
|
|
## YOU CAN IGNORE THE REST
|
||
|
|
##
|
||
|
|
|
||
|
|
# warn --
|
||
|
|
#
|
||
|
|
# Simple warning alias to ease programming
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# msg The warning message to display
|
||
|
|
# Results:
|
||
|
|
# Returns nothing important.
|
||
|
|
#
|
||
|
|
proc warn {msg} {
|
||
|
|
bell
|
||
|
|
tk_dialog .__warning Warning $msg warning 0 OK
|
||
|
|
}
|
||
|
|
|
||
|
|
# place_window --
|
||
|
|
# place a toplevel at a particular position
|
||
|
|
# Arguments:
|
||
|
|
# toplevel name of toplevel window
|
||
|
|
# ?placement? pointer ?center? ; places $w centered on the pointer
|
||
|
|
# widget widget_name ; centers $w over widget_name
|
||
|
|
# defaults to placing toplevel in the middle of the screen
|
||
|
|
# ?anchor?
|
||
|
|
# Results:
|
||
|
|
# Returns nothing
|
||
|
|
#
|
||
|
|
proc place_window {w {placement ""} {anchor ""}} {
|
||
|
|
wm withdraw $w
|
||
|
|
update idletasks
|
||
|
|
switch -glob -- $placement {
|
||
|
|
p* { ## place at POINTER (centered is $anchor == center)
|
||
|
|
if {[string match "c*" $anchor]} {
|
||
|
|
wm geometry $w +[expr \
|
||
|
|
{[winfo pointerx $w]-[winfo width $w]/2}]+[expr \
|
||
|
|
{[winfo pointery $w]-[winfo height $w]/2}]
|
||
|
|
} else {
|
||
|
|
wm geometry $w +[winfo pointerx $w]+[winfo pointery $w]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
w* { ## center about WIDGET $anchor
|
||
|
|
wm geometry $w +[expr {[winfo rootx $anchor]+([winfo width \
|
||
|
|
$anchor]-[winfo width $w])/2}]+[expr {[winfo rooty \
|
||
|
|
$anchor]+([winfo height $anchor]-[winfo height $w])/2}]
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
wm geometry $w +[expr {([winfo screenwidth $w]-\
|
||
|
|
[winfo reqwidth $w])/2}]+[expr \
|
||
|
|
{([winfo screenheight $w]-[winfo reqheight $w])/2}]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
wm deiconify $w
|
||
|
|
}
|
||
|
|
|
||
|
|
## Centers the canvas around points x & y
|
||
|
|
##
|
||
|
|
## Unoptimized, this looks like:
|
||
|
|
## set xtenth [expr .10 * [winfo width $w]]
|
||
|
|
## set ytenth [expr .10 * [winfo height $w]]
|
||
|
|
## set X [expr [winfo width $w] / 2]
|
||
|
|
## set Y [expr [winfo height $w] / 2]
|
||
|
|
## set x1 [expr round(($x-$X)/$xtenth)]
|
||
|
|
## set y1 [expr round(($y-$Y)/$ytenth)]
|
||
|
|
## $w xview scroll $x1 units
|
||
|
|
## $w yview scroll $y1 units
|
||
|
|
##
|
||
|
|
proc canvas_center {w x y} {
|
||
|
|
$w xview scroll [expr {round(10.0*$x/[winfo width $w]-5)}] units
|
||
|
|
$w yview scroll [expr {round(10.0*$y/[winfo height $w]-5)}] units
|
||
|
|
}
|
||
|
|
|
||
|
|
## "see" method alternative for canvas
|
||
|
|
## Aligns the named item as best it can in the middle of the screen
|
||
|
|
## Behavior depends on whether -scrollregion is set
|
||
|
|
##
|
||
|
|
## c - a canvas widget
|
||
|
|
## item - a canvas tagOrId
|
||
|
|
proc canvas_see {c item} {
|
||
|
|
set box [$c bbox $item]
|
||
|
|
if {[string match {} $box]} return
|
||
|
|
if {[string match {} [$c cget -scrollregion]]} {
|
||
|
|
## People really should set -scrollregion you know...
|
||
|
|
foreach {x y x1 y1} $box {
|
||
|
|
set x [expr {round(2.5*($x1+$x)/[winfo width $c])}]
|
||
|
|
set y [expr {round(2.5*($y1+$y)/[winfo height $c])}]
|
||
|
|
}
|
||
|
|
$c xview moveto 0
|
||
|
|
$c yview moveto 0
|
||
|
|
$c xview scroll $x units
|
||
|
|
$c yview scroll $y units
|
||
|
|
} else {
|
||
|
|
## If -scrollregion is set properly, use this
|
||
|
|
foreach {x y x1 y1} $box {top btm} [$c yview] {left right} [$c xview] \
|
||
|
|
{p q xmax ymax} [$c cget -scrollregion] {
|
||
|
|
set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}]
|
||
|
|
set ypos [expr {(($y1+$y)/2.0)/$ymax - ($btm-$top)/2.0}]
|
||
|
|
}
|
||
|
|
$c xview moveto $xpos
|
||
|
|
$c yview moveto $ypos
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
## Set cursor of widget $w and its descendants to $cursor
|
||
|
|
## Ignores {} cursors
|
||
|
|
proc cursor_set {w cursor} {
|
||
|
|
variable CURSOR
|
||
|
|
if {[string compare {} [set CURSOR($w) [$w cget -cursor]]]} {
|
||
|
|
$w config -cursor $cursor
|
||
|
|
} else {
|
||
|
|
unset CURSOR($w)
|
||
|
|
}
|
||
|
|
foreach child [winfo children $w] { cursor_set $child $cursor }
|
||
|
|
}
|
||
|
|
|
||
|
|
## Restore cursor based on CURSOR($w) for $w and its descendants
|
||
|
|
## $cursor is the default cursor (if none was cached)
|
||
|
|
proc cursor_restore {w {cursor {}}} {
|
||
|
|
variable CURSOR
|
||
|
|
if {[info exists CURSOR($w)]} {
|
||
|
|
$w config -cursor $CURSOR($w)
|
||
|
|
} else {
|
||
|
|
$w config -cursor $cursor
|
||
|
|
}
|
||
|
|
foreach child [winfo children $w] { cursor_restore $child $cursor }
|
||
|
|
}
|
||
|
|
|
||
|
|
# highlight_dialog --
|
||
|
|
#
|
||
|
|
# creates minimal dialog interface to highlight
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# w text widget
|
||
|
|
# str optional seed string for HIGHLIGHT(string)
|
||
|
|
# Results:
|
||
|
|
# Returns null.
|
||
|
|
#
|
||
|
|
proc highlight_dialog {w {str {}}} {
|
||
|
|
variable HIGHLIGHT
|
||
|
|
|
||
|
|
set namesp [namespace current]
|
||
|
|
set var ${namesp}::HIGHLIGHT
|
||
|
|
set base $w.__highlight
|
||
|
|
if {![winfo exists $base]} {
|
||
|
|
toplevel $base
|
||
|
|
wm withdraw $base
|
||
|
|
wm title $base "Find String"
|
||
|
|
|
||
|
|
pack [frame $base.f] -fill x -expand 1
|
||
|
|
label $base.f.l -text "Find:"
|
||
|
|
entry $base.f.e -textvariable ${var}($w,string)
|
||
|
|
pack [frame $base.opt] -fill x
|
||
|
|
checkbutton $base.opt.c -text "Case Sensitive" \
|
||
|
|
-variable ${var}($w,nocase)
|
||
|
|
checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp)
|
||
|
|
pack $base.f.l -side left
|
||
|
|
pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
|
||
|
|
pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
|
||
|
|
pack [frame $base.btn] -fill both
|
||
|
|
button $base.btn.fnd -text "Find" -width 6
|
||
|
|
button $base.btn.clr -text "Clear" -width 6
|
||
|
|
button $base.btn.dis -text "Dismiss" -width 6
|
||
|
|
eval pack [winfo children $base.btn] -padx 4 -pady 2 \
|
||
|
|
-side left -fill both
|
||
|
|
|
||
|
|
focus $base.f.e
|
||
|
|
|
||
|
|
bind $base.f.e <Return> [list $base.btn.fnd invoke]
|
||
|
|
bind $base.f.e <Escape> [list $base.btn.dis invoke]
|
||
|
|
}
|
||
|
|
## FIX namespace
|
||
|
|
$base.btn.fnd config -command [namespace code \
|
||
|
|
"highlight [list $w] \[set ${var}($w,string)\] \
|
||
|
|
\[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \
|
||
|
|
\[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \
|
||
|
|
-tag __highlight -color [list yellow]"]
|
||
|
|
$base.btn.clr config -command \
|
||
|
|
"[list $w] tag remove __highlight 1.0 end;\
|
||
|
|
set [list ${var}($w,string)] {}"
|
||
|
|
$base.btn.dis config -command \
|
||
|
|
"[list $w] tag remove __highlight 1.0 end;\
|
||
|
|
wm withdraw [list $base]"
|
||
|
|
if {[string compare {} $str]} {
|
||
|
|
set ${var}($w,string) $str
|
||
|
|
$base.btn.fnd invoke
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[string compare normal [wm state $base]]} {
|
||
|
|
wm deiconify $base
|
||
|
|
} else {
|
||
|
|
raise $base
|
||
|
|
}
|
||
|
|
$base.f.e select range 0 end
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
}; # end namespace ::Utility::Tk
|