# $Id: widgetip.tcl,v 2.18 2005/01/30 19:15:39 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} {
        catch {after cancel $($this,event)}
        if {!$switched::($this,-ephemeral)} {            ;# avoid infinite loop since ephemeral tip deletes self when first disabled
            disable $this
        }
        if {[info exists ($this,bindings)]} {                                                              ;# remove bindings if any
            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 -ephemeral 0 0]\
            [list -font $widget::option(entry,font) $widget::option(entry,font)]\
            [list -itemortag {} {}]\
            [list -path {} {}]\
            [list -rectangle {} {}]\
            [list -state normal normal]\
            [list -text {} {}]\
        ]
    }

    proc set-ephemeral {this value} {
        if {$switched::($this,complete)} {
            error {option -ephemeral cannot be set dynamically}
        }
    }

    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,-rectangle)] > 0} {
            error {-itemortag and -rectangle options are incompatible}
        }
        if {([string length $switched::($this,-path)] > 0) && [catch {$switched::($this,-path) type $value} 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 type $switched::($this,-itemortag)} message]} {
            error "$value is not a canvas, $switched::($this,-itemortag) not a valid item or tag, ...: $message"
        }
    }

    proc set-rectangle {this value} {
        if {[string length $switched::($this,-itemortag)] > 0} {
            error {-itemortag and -rectangle options are incompatible}
        }
        set error 0
        if {[llength $value] != 4} {
            set error 1
        } else {
            foreach item $value {
                if {![string is integer -strict $item]} {set error 1; break}
            }
        }
        if {$error} {
            error {-rectangle option must be a list of 4 integers}
        }
        foreach [list ($this,left) ($this,top) ($this,right) ($this,bottom)] $value {}
        setupBindings $this
        if {[string length $switched::($this,-path)] > 0} {                   ;# generate an artificial motion event for correctness
            set path $switched::($this,-path)
            after idle widgetTip::motion $this [expr {[winfo pointerx $path] - [winfo rootx $path]}]\
                [expr {[winfo pointery $path] - [winfo rooty $path]}]                 ;# wait after object is completely constructed
        }
    }

    proc set-state {this value} {
        switch $value {
            disabled {disable $this}
            normal {}
            default {error "bad state value \"$value\": must be normal or disabled"}
        }
    }

    proc setupBindings {this} {                                                                    ;# invoked right after completion
        if {[string length $switched::($this,-itemortag)] == 0} {
            if {![info exists ($this,bindings)]} {                    ;# may be invoked several times when setting -rectangle option
                set ($this,bindings) [new bindings $switched::($this,-path) 0]
            }
            if {[string length $switched::($this,-rectangle)] > 0} {
                bindings::set $($this,bindings) <Enter> {}                              ;# possibly reset existing binding for -path
                bindings::set $($this,bindings) <Leave> "widgetTip::disable $this; catch {unset widgetTip::($this,in)}"
                bindings::set $($this,bindings) <Motion> "widgetTip::motion $this %x %y"
            } else {
                bindings::set $($this,bindings) <Enter> "widgetTip::enable $this"
                bindings::set $($this,bindings) <Leave> "widgetTip::disable $this"
            }
        } 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 {[catch {classof $this}]} return                                                              ;# has been deleted already
        if {[string equal $switched::($this,-state) disabled] || ([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))} {
            catch {after cancel $($this,event)}
            show $this $x $y
        } else {
            set (xLast) $x
            set (yLast) $y
            set ($this,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 $($this,event)}
        catch {unset (active)}
        wm withdraw $(path)
        if {$switched::($this,-ephemeral)} {after idle "if {!\[catch {classof $this}\]} {delete $this}"}
    }

    proc motion {this x y} {
        if {[catch {classof $this}]} return                                                              ;# has been deleted already
        if {($x < $($this,left)) || ($y < $($this,top)) || ($x > $($this,right)) || ($y > $($this,bottom))} {    ;# out of rectangle
            if {[info exists ($this,in)]} {                                                         ;# just crossed rectangle border
                unset ($this,in)
                disable $this
            }
        } else {                                                                                                     ;# in rectangle
            if {![info exists ($this,in)]} {                                                        ;# just crossed rectangle border
                set ($this,in) {}
                enable $this
            }
        }
    }

}
