#
# $Header: /home/rockware/cvs-main/operator/tcl/opBalloonHelp.tcl,v 1.7 1995/03/16 12:43:19 erez Exp $
# Written by: Erez Strauss (C) All Rights Reserved 1994, 1995.
#
# Future versions:
# v  Make sure that there is only one active balloon
# v  Add the feature from the tix package that waits 200ms before display.
# v  Try to do withdraw instead of destroy.
# v  No destroy just withdraw
#    be itcl class
#    should use non rectangle toplevel windows (should i add it into tk ?)
# From: kennykb@dssv01.crd.ge.com, on tcl newsgroup
# global variable OPBallonHelp().
# OPBallonHelp(active), OPBallonHelp(background), OPallonHelp(forground)
# 
proc opBalloonHelpInit {} {
    global OPBalloonHelp
    set OPBalloonHelp(active)       1
    set OPBalloonHelp(background)   gold   ;# was yellow
    set OPBalloonHelp(foreground)   black
    set OPBalloonHelp(widget)       {}
    set OPBalloonHelp(time)         300         ;# time in mili seconds before popup
}

opBalloonHelpInit
# if menubar entries can have ballonHelp then the binding should check
#  specificaly the <B1-Enter> <B1-Leave> Events.

proc opBalloonHelp {widget {message {}}} {

    if {$widget == {} || $message == {}} return

    set binding [bind $widget <Any-Enter>]
    if {$binding == {}} {
        set binding [bind [winfo class $widget] <Any-Enter>]
    }
    bind $widget <Any-Enter> "[list opBalloonHelpEngage $widget $message]; $binding"

    set binding [bind $widget <Any-Motion>]
    if {$binding == {}} {
        set binding [bind [winfo class $widget] <Any-Motion>]
    }
    bind $widget <Any-Motion> "[list opBalloonHelpMotion $widget $message]; $binding"

    set binding [bind $widget <Any-Leave>]
    if {$binding == {}} {
        set binding [bind [winfo class $widget] <Any-Leave>]
    }
    bind $widget <Any-Leave> "opBalloonHelpOff $widget; $binding"

    set binding [bind $widget <Destroy>]
    if {$binding == {}} {
        set binding [bind [winfo class $widget] <Destroy>]
    }
    bind $widget <Destroy> "opBalloonHelpOff $widget; $binding"
}

proc opBalloonHelpEngage {widget message} {
    global OPBalloonHelp
    if $OPBalloonHelp(active) {
        set OPBalloonHelp($widget,c) 0
        # set OPBalloonHelp($widget,in) 1
        after $OPBalloonHelp(time) [list opBalloonHelpOn $widget $message]
    }
}

proc opBalloonHelpMotion {widget message} {
    global OPBalloonHelp
    if $OPBalloonHelp(active) {
        if [winfo ismapped $widget] return
        incr OPBalloonHelp($widget,c)
        after $OPBalloonHelp(time) [list opBalloonHelpOn $widget $message]
    }
}

proc opBalloonHelpOff widget {
    global OPBalloonHelp
    if {$OPBalloonHelp(widget) != {}} {
        set w $OPBalloonHelp(widget)
        set OPBalloonHelp(widget) {}
        opBalloonHelpOff $w
    }
    # set OPBalloonHelp($widget,in) 0
    set OPBalloonHelp($widget,c) -1
    catch "wm withdraw $widget.balloon"
}

proc opBalloonHelpOn {widget message} {
    global OPBalloonHelp
    if {!$OPBalloonHelp(active) || ![winfo exists $widget]} return
    if {$OPBalloonHelp(widget) != {} && $OPBalloonHelp(widget) != "$widget"} {
        opBalloonHelpOff $OPBalloonHelp(widget)
    }
    # if {!$OPBalloonHelp($widget,in) || $OPBalloonHelp($widget,c) < 0} 
    if {$OPBalloonHelp($widget,c) < 0} {
    opBalloonHelpOff $widget
        return
    }
    if {$OPBalloonHelp($widget,c) > 0} {
        incr OPBalloonHelp($widget,c) -1
        return
    }
    set OPBalloonHelp(widget) $widget
    set x [expr [winfo rootx $widget] + [winfo width $widget]]
    set y [expr [winfo rooty $widget] + [winfo height $widget] / 2]
    catch {
        if ![winfo exists $widget.balloon] {
            toplevel $widget.balloon -relief raised -borderwidth 2
            wm overrideredirect $widget.balloon 1
            pack [message $widget.balloon.message -text $message -aspect 2000 \
                      -back $OPBalloonHelp(background) -fore $OPBalloonHelp(foreground)]
            wm geometry $widget.balloon +${x}+${y}
        } {
            $widget.balloon.message config -text $message \
                -back $OPBalloonHelp(background) -fore $OPBalloonHelp(foreground)
            raise $widget.balloon $widget
            wm deiconify $widget.balloon
            wm geometry $widget.balloon +${x}+${y}
        }
        tkwait visibility $widget.balloon
    }
}
# End of OpBalloonHelp.tcl.
