# $Id: widgetip.tcl,v 2.11 2002/06/30 20:35:23 jfontain Exp $


class widgetTip {

    variable screenWidth [winfo screenwidth .]
    variable screenHeight [winfo screenheight .]
    variable xOffset 7
    variable yOffset 10

    class topLabel {

        proc topLabel {this parentPath args} composite {
            [new toplevel $parentPath -highlightbackground black -highlightthickness 1] $args
        } {
            composite::manage $this [new label $widget::($this,path) -justify left] label
            composite::complete $this
            pack $composite::($this,label,path)
            wm overrideredirect $widget::($this,path) 1                                             ;# no window manager decorations
        }

        proc ~topLabel {this} {}

        proc options {this} {
            return [list\
                [list -bordercolor Black Black]\
                [list -borderwidth 1 1]\
                [list -background $widget::option(button,background) $widget::option(button,background)]\
                [list -font $widget::option(button,font) $widget::option(button,font)]\
                [list -foreground $widget::option(button,foreground) $widget::option(button,foreground)]\
                [list -text {} {}]\
                [list -wraplength 400]\
            ]
        }

        foreach option {-background -font -foreground -text -wraplength} {
            proc set$option {this value} "\$composite::(\$this,label,path) configure $option \$value"
        }

        proc set-bordercolor {this value} {
            $widget::($this,path) configure -highlightbackground $value
        }

        proc set-borderwidth {this value} {
            $widget::($this,path) configure -highlightthickness $value
        }

    }

    if {![info exists (label)]} {
        set (label) [new topLabel . -font $widget::option(entry,font) -background #FFFFDF]
        set (path) $widget::($(label),path)
        wm withdraw $(path)
        # handle button and key presses as global events for some child widgets (such as entries) do not pass them to their parent
        bind all <ButtonPress> {widgetTip::globalEvent %W}
        bind all <KeyPress> {widgetTip::globalEvent %W}
        set (xLast) -1
        set (yLast) -1
    }

    proc widgetTip {this args} switched {$args} {
        switched::complete $this
        setupBindings $this
    }

    proc ~widgetTip {this} {
        disable $this
        if {[info exists ($this,bindings)]} {                                                          ;# eventually remove bindings
            delete $($this,bindings)
        }
        set path $switched::($this,-path)
        set tag $switched::($this,-itemortag)
        if {([string length $path]>0)&&([string length $tag]>0)} {                                         ;# remove canvas bindings
            array set match [list <Enter> "widgetTip::enable $this" <Leave> "widgetTip::disable $this"]
            foreach sequence [array names match] {
                set script {}
                foreach line [split [$path bind $tag $sequence] \n] {
                    if {![string equal [string trim $line] $match($sequence)]} {
                        if {[string length $script]>0} {append script \n}
                        append script $line
                    }
                }
                $path bind $tag $sequence $script                                                 ;# restore original binding script
            }
        }
    }

    proc options {this} {
        return [list\
            [list -font $widget::option(entry,font) $widget::option(entry,font)]\
            [list -itemortag {} {}]\
            [list -path {} {}]\
            [list -text {} {}]\
        ]
    }

    proc set-itemortag {this value} {                     ;# implies that tip cannot be deleted before the canvas that it applies to
        if {$switched::($this,complete)} {
            error {option -itemortag cannot be set dynamically}
        }
        if {([string length $switched::($this,-path)]>0)&&[catch {$switched::($this,-path) index $value 0} message]} {
            error "$switched::($this,-path) is not a canvas, $value not a valid item or tag, ...: $message"
        }
    }

    proc set-path {this value} {
        if {$switched::($this,complete)} {
            error {option -path cannot be set dynamically}
        }
        if {![winfo exists $value]} {
            error "invalid widget: \"$value\""
        }
        if {([string length $switched::($this,-itemortag)]>0)&&[catch {$value index $switched::($this,-itemortag) 0} message]} {
            error "$value is not a canvas, $switched::($this,-itemortag) not a valid item or tag, ...: $message"
        }
    }

    proc setupBindings {this} {                                                                    ;# invoked right after completion
        if {[string length $switched::($this,-itemortag)]==0} {
            set bindings [new bindings $switched::($this,-path) 0]
            bindings::set $bindings <Enter> "widgetTip::enable $this"
            bindings::set $bindings <Leave> "widgetTip::disable $this"
            set ($this,bindings) $bindings
        } else {
            $switched::($this,-path) bind $switched::($this,-itemortag) <Enter> "+ widgetTip::enable $this"
            $switched::($this,-path) bind $switched::($this,-itemortag) <Leave> "+ widgetTip::disable $this"
        }
    }

    proc set-font {this value} {}                                                  ;# nothing to do, data is saved at switched level
    proc set-text {this value} {
        if {[info exists (active)]&&($(active)==$this)} {
            widget::configure $(label) -text $value                                                              ;# update tip label
        }
    }

    proc globalEvent {widget} {
        if {![catch {string first $switched::($(active),-path) $widget} value]&&($value==0)} {
            disable $(active)                        ;# hide if active widget exists and is a descendant of the active target widget
        }
    }

    proc show {this x y} {                                                                             ;# pointer screen coordinates
        variable screenWidth
        variable screenHeight
        variable xOffset
        variable yOffset

        set path $(path)
        widget::configure $(label) -font $switched::($this,-font) -text $switched::($this,-text)                 ;# update tip label
        update idletasks                                                                              ;# make sure sizes are correct
        set size [winfo reqwidth $path]
        set delta [expr {$screenWidth-$x-$xOffset-$size}]
        if {$delta<0} {                    ;# widget tip right edge would be pass screen: position widget right edge left of pointer
            incr x -$xOffset
            incr x -$size
        } else {
            incr x $xOffset
        }
        set size [winfo reqheight $path]
        set delta [expr {$screenHeight-$y-$yOffset-$size}]
        if {$delta<0} {                    ;# widget tip bottom edge would be pass screen: position widget bottom edge above pointer
            incr y -$yOffset
            incr y -$size
        } else {
            incr y $yOffset
        }
        showTopLevel $path +$x+$y
        update idletasks
        raise $path
    }

    proc enable {this} {
        if {[string length $switched::($this,-text)]==0} return                                                ;# nothing to display
        set x [winfo pointerx $(path)]
        set y [winfo pointery $(path)]
        if {($x==$(xLast))&&($y==$(yLast))} {
            show $this $x $y
        } else {
            set (xLast) $x
            set (yLast) $y
            set (event) [after 300 "widgetTip::enable $this"]                                                                ;# poll
        }
        set (active) $this                                                                                 ;# remember active object
    }

    proc disable {this} {
        # event and active tip may no longer exist when the pointer leaves after a click (for example)
        catch {after cancel $(event)}
        catch {unset (active)}
        wm withdraw $(path)
    }

}
