dynhelp.tcl

dynhelp.tcl
This file is part of Unifix BWidget Toolkit
$Id: dynhelp.tcl,v 1.9 2002/10/14 20:54:23 hobbs Exp $
Index of commands:
- DynamicHelp::configure
- DynamicHelp::include
- DynamicHelp::sethelp
- DynamicHelp::register
- DynamicHelp::_motion_balloon
- DynamicHelp::_motion_info
- DynamicHelp::_leave_info
- DynamicHelp::_menu_info
- DynamicHelp::_show_help
- DynamicHelp::_init


DynamicHelp
Comments JDC: allow variable and ballon help at the same timees
Arguments  
Used by  
Uses  
namespace eval DynamicHelp {
    Widget::declare DynamicHelp {
        {-foreground  TkResource black         0 label}
        {-background  TkResource "#FFFFC0"     0 label}
        {-borderwidth TkResource 1             0 label}
        {-justify     TkResource left          0 label}
        {-font        TkResource "helvetica 8" 0 label}
        {-delay       Int        600           0 "%d >= 100 & %d <= 2000"}
        {-bd          Synonym    -borderwidth}
        {-bg          Synonym    -background}
        {-fg          Synonym    -foreground}
    }

    proc use {} {}

    variable _registered

    variable _top     ".help_shell"
    variable _id      ""
    variable _delay   600
    variable _current_balloon ""
    variable _current_variable ""
    variable _saved

    Widget::init DynamicHelp $_top {}

    bind BwHelpBalloon <Enter>   {DynamicHelp::_motion_balloon enter  %W %X %Y}
    bind BwHelpBalloon <Motion>  {DynamicHelp::_motion_balloon motion %W %X %Y}
    bind BwHelpBalloon <Leave>   {DynamicHelp::_motion_balloon leave  %W %X %Y}
    bind BwHelpBalloon <Button>  {DynamicHelp::_motion_balloon button %W %X %Y}
    bind BwHelpBalloon <Destroy> {if {[info exists DynamicHelp::_registered(%W,balloon)]} {unset DynamicHelp::_registered(%W,balloon)}}

    bind BwHelpVariable <Enter>   {DynamicHelp::_motion_info %W}
    bind BwHelpVariable <Motion>  {DynamicHelp::_motion_info %W}
    bind BwHelpVariable <Leave>   {DynamicHelp::_leave_info  %W}
    bind BwHelpVariable <Destroy> {if {[info exists DynamicHelp::_registered(%W,variable)]} {unset DynamicHelp::_registered(%W,variable)}}

    bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
    bind BwHelpMenu <Unmap>        {DynamicHelp::_menu_info unmap  %W}
    bind BwHelpMenu <Destroy>      {if {[info exists DynamicHelp::_registered(%W)]} {unset DynamicHelp::_registered(%W)}}
}


DynamicHelp::_leave_info
Comments Command DynamicHelp::_leave_info
Arguments path
Used by  
Uses GlobalVar::setvar
proc DynamicHelp::_leave_info { path } {
    variable _registered
    variable _current_variable
    variable _saved

    if { [info exists _registered($path,variable)] } {
        GlobalVar::setvar [lindex $_registered($path,variable) 0] $_saved
    }
    unset _saved
    set _current_variable ""
    
}


DynamicHelp::_menu_info
Comments Command DynamicHelp::_menu_info
Version of R1v1 restored, due to lack of [winfo ismapped] and
under windows for menu.
Arguments event
path
Used by  
Uses GlobalVar::setvar
proc DynamicHelp::_menu_info { event path } {
    variable _registered

    if { [info exists _registered($path)] } {
        set index [$path index active]
        if { [string compare $index "none"] &&
             [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
            GlobalVar::setvar [lindex $_registered($path) 0] \
                [lindex [lindex $_registered($path) $idx] 1]
        } else {
            GlobalVar::setvar [lindex $_registered($path) 0] ""
        }
    }
}


DynamicHelp::_motion_balloon
Comments Command DynamicHelp::_motion_balloon
Arguments type
path
x
y
Used by  
Uses  
proc DynamicHelp::_motion_balloon { type path x y } {
    variable _top
    variable _id
    variable _delay
    variable _current_balloon

    if { $_current_balloon != $path && $type == "enter" } {
        set _current_balloon $path
        set type "motion"
        destroy $_top
    }
    if { $_current_balloon == $path } {
        if { $_id != "" } {
            after cancel $_id
            set _id ""
        }
        if { $type == "motion" } {
            if { ![winfo exists $_top] } {
                set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
            }
        } else {
            destroy $_top
            set _current_balloon ""
        }
    }
}


DynamicHelp::_motion_info
Comments Command DynamicHelp::_motion_info
Arguments path
Used by  
Uses GlobalVar::setvar
GlobalVar::getvar
proc DynamicHelp::_motion_info { path } {
    variable _registered
    variable _current_variable
    variable _saved

    if { $_current_variable != $path && [info exists _registered($path,variable)] } {
        if { ![info exists _saved] } {
            set _saved [GlobalVar::getvar [lindex $_registered($path,variable) 0]]
        }
        GlobalVar::setvar [lindex $_registered($path,variable) 0] [lindex $_registered($path,variable) 1]
        set _current_variable $path
    }
}


DynamicHelp::_show_help
Comments Command DynamicHelp::_show_help
Arguments path
x
y
Used by  
Uses Widget::getoption
proc DynamicHelp::_show_help { path x y } {
    variable _top
    variable _registered
    variable _id
    variable _delay

    if { [info exists _registered($path,balloon)] } {
        destroy  $_top
        toplevel $_top -relief flat \
            -bg [Widget::getoption $_top -foreground] \
            -bd [Widget::getoption $_top -borderwidth] \
            -screen [winfo screen $path]

        wm overrideredirect $_top 1
        wm transient $_top
        wm withdraw $_top

        label $_top.label -text $_registered($path,balloon) \
            -relief flat -bd 0 -highlightthickness 0 \
            -foreground [Widget::getoption $_top -foreground] \
            -background [Widget::getoption $_top -background] \
            -font       [Widget::getoption $_top -font] \
            -justify    [Widget::getoption $_top -justify]


        pack $_top.label -side left
        update idletasks

    if {![winfo exists $_top]} {return}

        set  scrwidth  [winfo vrootwidth  .]
        set  scrheight [winfo vrootheight .]
        set  width     [winfo reqwidth  $_top]
        set  height    [winfo reqheight $_top]
        incr y 12
        incr x 8

        if { $x+$width > $scrwidth } {
            set x [expr {$scrwidth - $width}]
        }
        if { $y+$height > $scrheight } {
            set y [expr {$y - 12 - $height}]
        }

        wm geometry  $_top "+$x+$y"
        update idletasks

    if {![winfo exists $_top]} {return}
        wm deiconify $_top
    }
}


DynamicHelp::configure
Comments Command DynamicHelp::configure
Arguments args
Used by  
Uses Widget::configure
Widget::hasChanged
proc DynamicHelp::configure { args } {
    variable _top
    variable _delay

    set res [Widget::configure $_top $args]
    if { [Widget::hasChanged $_top -delay val] } {
        set _delay $val
    }

    return $res
}


DynamicHelp::include
Comments Command DynamicHelp::include
Arguments class
type
Used by  
Uses Widget::declare
proc DynamicHelp::include { class type } {
    set helpoptions [list \
        [list -helptext String "" 0] \
        [list -helpvar  String "" 0] \
        [list -helptype Enum $type 0 [list balloon variable]] \
        ]
    Widget::declare $class $helpoptions
}


DynamicHelp::register
Comments Command DynamicHelp::register
Arguments path
type
args
Used by MainFrame::_create_entries
Uses BWidget::clonename
proc DynamicHelp::register { path type args } {
    variable _registered

    if { [winfo exists $path] } {
        set evt  [bindtags $path]
        switch $type {
            balloon {
        set idx  [lsearch $evt "BwHelpBalloon"]
        set evt  [lreplace $evt $idx $idx]
                set text [lindex $args 0]
                if { $text != "" } {
                    set _registered($path,balloon) $text
                    lappend evt BwHelpBalloon
                } else {
                    if {[info exists _registered($path,balloon)]} {
                        unset _registered($path,balloon)
                    }
                }
                bindtags $path $evt
                return 1
            }

            variable {
        set idx  [lsearch $evt "BwHelpVariable"]
        set evt  [lreplace $evt $idx $idx]
                set var  [lindex $args 0]
                set text [lindex $args 1]
                if { $text != "" && $var != "" } {
                    set _registered($path,variable) [list $var $text]
                    lappend evt BwHelpVariable
                } else {
                    if {[info exists _registered($path,variable)]} {
                        unset _registered($path,variable)
                    }
                }
                bindtags $path $evt
                return 1
            }

            menu {
                set cpath [BWidget::clonename $path]
                if { [winfo exists $cpath] } {
                    set path $cpath
                }
                set var [lindex $args 0]
                if { $var != "" } {
                    set _registered($path) [list $var]
                    lappend evt BwHelpMenu
                } else {
                    if {[info exists _registered($path)]} {
                        unset _registered($path)
                    }
                }
                bindtags $path $evt
                return 1
            }

            menuentry {
                set cpath [BWidget::clonename $path]
                if { [winfo exists $cpath] } {
                    set path $cpath
                }
                if { [info exists _registered($path)] } {
                    if { [set index [lindex $args 0]] != "" } {
                        set text  [lindex $args 1]
                        set idx   [lsearch $_registered($path) [list $index *]]
                        if { $text != "" } {
                            if { $idx == -1 } {
                                lappend _registered($path) [list $index $text]
                            } else {
                                set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
                            }
                        } else {
                            set _registered($path) [lreplace $_registered($path) $idx $idx]
                        }
                    }
                    return 1
                }
                return 0
            }
        }
        if {[info exists _registered($path,balloon)]} {
            unset _registered($path,balloon)
        }
        if {[info exists _registered($path,variable)]} {
            unset _registered($path,variable)
        }
        if {[info exists _registered($path)]} {
            unset _registered($path)
        }
        bindtags $path $evt
        return 1
    } else {
        if {[info exists _registered($path,balloon)]} {
            unset _registered($path,balloon)
        }
    if {[info exists _registered($path,variable)]} {
            unset _registered($path,variable)
        }
        if {[info exists _registered($path)]} {
            unset _registered($path)
        }
        return 0
    }
}


DynamicHelp::sethelp
Comments Command DynamicHelp::sethelp
Arguments path
subpath
force
Used by ArrowButton::create
Entry::create
Button::create
ArrowButton::configure
BWLabel::create
Button::configure
BWLabel::configure
Entry::configure
Uses Widget::hasChangedX
Widget::cget
proc DynamicHelp::sethelp { path subpath {force 0}} {
    foreach {ctype ctext cvar} [Widget::hasChangedX $path \
        -helptype -helptext -helpvar] break
    if { $force || $ctype || $ctext || $cvar } {
    set htype [Widget::cget $path -helptype]
        switch $htype {
            balloon {
                return [register $subpath balloon \
            [Widget::cget $path -helptext]]
            }
            variable {
                return [register $subpath variable \
            [Widget::cget $path -helpvar] \
            [Widget::cget $path -helptext]]
            }
        }
        return [register $subpath $htype]
    }
}
generated by zdoc.tcl on 2003-03-06 00:21:54