Eskil

2021-02-28
 Ballonhelp within frame.

2020-12-10
 Working towards runtime plugins.

2020-10-30
 Correct parent in dialogs.

2020-09-28

#  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 " "]

        }
        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> {

}

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} {

    # 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
    }
}