#----------------------------------------------------------------------
#
# psballoon.tcl,
# Procedures to create help message balloons or display balloons for
# listboxes and labels that can't display all of their contents.
#
# Copyright (c) 2003, Peter Spjuth (peter.spjuth@gmail.com)
#
# Permission is granted to use this code under the same terms as
# for the Tcl core code.
#
#----------------------------------------------------------------------
# $Revision: 1.1 $
#----------------------------------------------------------------------
package provide psballoon 1.2
namespace eval psballoon {
variable balloon
variable config
set config(-useframe) 0
set balloon(W) ""
set balloon(pending) 0
set balloon(created) 0
set balloon(id) ""
namespace export addBalloon
}
# -useframe <bool>
proc psballoon::configure {args} {
variable config
foreach {arg val} $args {
set config($arg) $val
}
}
# Do some simple formatting, to be able to have cleaner text in source
proc psballoon::Fmt {msg} {
# Remove any newlines.
set msg [regsub -all "\n" $msg " "]
# Remove multiple whitespace
set msg [regsub -all {\s+} $msg " "]
set msg [string trim $msg]
# Any explicitly requested newlines?
set msg [regsub -all {\\n\s*} $msg "\n"]
# Further line breaks by length?
set lines {}
foreach line [split $msg \n] {
while {[string length $line] > 80} {
# There should be no path through this loop that does not
# shorten $line
set ix [string last " " $line 80]
if {$ix < 0} {
set ix [string first " " $line]
if {$ix < 0} {
# Just cut at 80
set ix 80
}
}
if {$ix == 0} {
set line [string trim $line]
} else {
lappend lines [string range $line 0 $ix-1]
set line [string range $line $ix+1 end]
}
}
lappend lines $line
}
set msg [join $lines \n]
return $msg
}
# addBalloon widget ?widgets...? ?-fmt? ?msg?
# If message is not given, it is extracted from widget. This is used to show
# e.g. labels where text might not be fully visible.
# Message may contain callbacks in [] for dynamic text.
proc psballoon::addBalloon {W args} {
variable balloon
# Last argument is message
set msg [lindex $args end]
set Wlist [list $W]
foreach arg [lrange $args 0 end-1] {
# Request for formatting
if {$arg eq "-fmt"} {
if {$msg ne ""} {
set msg [Fmt $msg]
}
} else {
lappend Wlist $arg
}
}
foreach W $Wlist {
AddBalloon2 $W $msg
}
}
proc psballoon::AddBalloon2 {W msg} {
variable balloon
set c [winfo class $W]
if {$msg == "" && $c != "Listbox" && $c != "Label"} {
error "Missing message to balloon for $W ($c)"
}
set balloon(msg,$W) $msg
bind $W <Enter> {
set ::psballoon::balloon(pending) 1
set ::psballoon::balloon(created) 0
set ::psballoon::balloon(lastX) %X
set ::psballoon::balloon(lastY) %Y
set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
}
bind $W <Button> {
psballoon::killBalloon
}
bind $W <Leave> {
psballoon::killBalloon
}
bind $W <Motion> {
psballoon::motionBalloon %W %X %Y %x %y
}
}
proc psballoon::motionBalloon {W X Y x y} {
if {$::psballoon::balloon(pending) == 1} {
after cancel $::psballoon::balloon(id)
}
if {$::psballoon::balloon(created) == 1} {
if {$::psballoon::balloon(lastX) == $X && \
$::psballoon::balloon(lastY) == $Y} {
# Sometimes when the balloon is created, a motion event with
# the same coordinates arrive. Ignore that to avoid killing the
# new balloon.
return
}
psballoon::killBalloon
}
set ::psballoon::balloon(lastX) $X
set ::psballoon::balloon(lastY) $Y
set ::psballoon::balloon(id) [after 500 "psballoon::createBalloon $W $x $y"]
set ::psballoon::balloon(pending) 1
}
proc psballoon::killBalloon {} {
variable balloon
if {$balloon(pending) == 1} {
after cancel $balloon(id)
}
if {[winfo exists $balloon(W)]} {
destroy $balloon(W)
}
set balloon(created) 0
set balloon(pending) 0
}
# Measure display width needed for a text with line breaks
proc psballoon::Measure {font txt} {
set len 0
foreach line [split $txt \n] {
set lw [font measure $font $line]
if {$lw > $len} {
set len $lw
}
}
return $len
}
# Returns a list of minX maxX for each screen.
# maxX are exclusive and normally equal to the next minX
proc psballoon::FigureOutScreenWidths {W} {
set screens {}
# Range of X over multiple windows
set minX [winfo vrootx $W]
set maxX [expr {$minX + [winfo vrootwidth $W]}]
set sW [winfo screenwidth $W]
# Guess: If minX is negative, there is a screen from minX to 0
if {$minX < 0} {
lappend screens $minX 0
}
# Guess: Main screen is in the middle if three
# Main screen is 0 to screenWidth
lappend screens 0 $sW
# Guess: If maxX is larger than screen width (main screen), there
# is one more screen to the right
if {$maxX > $sW} {
lappend screens $sW $maxX
}
return $screens
}
proc psballoon::createBalloon {W mouseX mouseY} {
variable balloon
variable config
if { ! [winfo exists $W]} {
return
}
if {$balloon(created)} {
return
}
# Figure out widget's font
if {[catch {set font [$W cget -font]}]} {
set font [ttk::style lookup [winfo class $W] -font]
}
# Fallback to something reasonable if font fails.
if {$font eq ""} {
set font TkDefaultFont
}
set wWidth [winfo width $W]
set wHeight [winfo height $W]
if {[winfo class $W] in {TLabelframe Labelframe}} {
# Put it below the label, not the entire widget.
# 1.5 font heights is a reasonable guess
set fontHeight [font metrics $font -linespace]
set wHeight [expr {$fontHeight * 3 /2 }]
# Below cursor at least
if {$wHeight <= $mouseY} {
set wHeight [expr {$mouseY + 5}]
}
}
set ix 0
set iy 0
set create 1
set msg $balloon(msg,$W)
if {$msg == ""} {
# Extract text from widget
switch [winfo class $W] {
Listbox {
set i [$W index @$mouseX,$mouseY]
set msg [$W get $i]
foreach {ix iy iw wHeight} [$W bbox $i] {break}
}
Label {
set msg [$W cget -text]
set iw [Measure $font $msg]
}
}
# Don't create a balloon if the text is fully visible.
set create [expr {$iw > $wWidth - 8}]
} else {
if {[string index $msg 0] eq "\["} {
set msg [subst -novariables -nobackslashes $msg]
}
set iw [Measure $font $msg]
}
if {$create} {
# Preferred position of the balloon
set rootX [expr {[winfo rootx $W] + $ix}]
set rootY [expr {[winfo rooty $W] + $iy + $wHeight + 2}]
if {$config(-useframe)} {
set top [winfo toplevel $W]
set posX [expr {$rootX - [winfo rootx $top]}]
set posY [expr {$rootY - [winfo rooty $top]}]
set minX 6
set maxX [expr {[winfo width $top] - 6}]
} else {
set posX $rootX
set posY $rootY
# Limits of current screen.
foreach {minX maxX} [FigureOutScreenWidths $W] {
if {$minX <= $rootX && $rootX < $maxX} break
}
}
# Move it to the left as needed to fit on screen
if {$posX + $iw + 8 > $maxX} {
set posX [expr {$maxX - $iw - 8}]
}
if {$config(-useframe)} {
if {$top eq "."} {
set B .balloon
} else {
set B $top.balloon
}
frame $B -borderwidth 1 -relief solid
} else {
set B .balloon
toplevel $B -bg black
wm overrideredirect $B 1
}
label $B.l \
-text $msg -relief flat -font $font -justify left \
-bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
pack $B.l -side left -padx 1 -pady 1
if {$config(-useframe)} {
place $B -x $posX -y $posY -anchor nw
} else {
wm geometry .balloon +${posX}+${posY}
}
set balloon(W) $B
set balloon(created) 1
}
}