dynhelp.tcl

The BWidget Toolkit is a high-level Widget Set for Tcl/Tk built using native Tcl/Tk 8.x namespaces.

# ----------------------------------------------------------------------------
#  dynhelp.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: dynhelp.tcl,v 1.13 2003/10/20 21:23:52 damonc 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
# ----------------------------------------------------------------------------

# JDC: allow variable and ballon help at the same timees

namespace eval DynamicHelp {
    Widget::define DynamicHelp dynhelp -classonly

    Widget::declare DynamicHelp {
        {-foreground     TkResource black         0 label}
        {-topbackground  TkResource black         0 {label -foreground}}
        {-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"}
	{-state          Enum       "normal"      0 {normal disabled}}
        {-padx           TkResource 1             0 label}
        {-pady           TkResource 1             0 label}
        {-bd             Synonym    -borderwidth}
        {-bg             Synonym    -background}
        {-fg             Synonym    -foreground}
        {-topbg          Synonym    -topbackground}
    }

    proc use {} {}

    variable _registered
    variable _canvases

    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> {DynamicHelp::_unset_help %W}

    bind BwHelpVariable <Enter>   {DynamicHelp::_motion_info %W}
    bind BwHelpVariable <Motion>  {DynamicHelp::_motion_info %W}
    bind BwHelpVariable <Leave>   {DynamicHelp::_leave_info  %W}
    bind BwHelpVariable <Destroy> {DynamicHelp::_unset_help  %W}

    bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
    bind BwHelpMenu <Unmap>        {DynamicHelp::_menu_info unmap  %W}
    bind BwHelpMenu <Destroy>      {DynamicHelp::_unset_help %W}
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::configure
# ----------------------------------------------------------------------------
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
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::include
# ----------------------------------------------------------------------------
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
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::sethelp
# ----------------------------------------------------------------------------
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]
    }
}

# ----------------------------------------------------------------------------
#  Command DynamicHelp::register
#
#  DynamicHelp::register path balloon  ?itemOrTag? text
#  DynamicHelp::register path variable ?itemOrTag? text varName
#  DynamicHelp::register path menu varName
#  DynamicHelp::register path menuentry index text
# ----------------------------------------------------------------------------
proc DynamicHelp::register { path type args } {
    variable _registered

    set len [llength $args]
    if {$type == "balloon"  && $len > 1} { set type canvasBalloon  }
    if {$type == "variable" && $len > 2} { set type canvasVariable }

    if { ![winfo exists $path] } {
        _unset_help $path
        return 0
    }

    switch $type {
        balloon {
            set text [lindex $args 0]
	    if {$text == ""} {
		if {[info exists _registered($path,balloon)]} {
		    unset _registered($path,balloon)
		}
		return 0
	    }

	    _add_balloon $path $text
        }

        canvasBalloon {
            set tagOrItem  [lindex $args 0]
            set text       [lindex $args 1]
	    if {$text == ""} {
		if {[info exists _registered($path,$tagOrItem,balloon)]} {
		    unset _registered($path,$tagOrItem,balloon)
		}
		return 0
	    }

	    _add_canvas_balloon $path $text $tagOrItem
        }

        variable {
            set var  [lindex $args 0]
            set text [lindex $args 1]
	    if {$text == "" || $var == ""} {
		if {[info exists _registered($path,variable)]} {
		    unset _registered($path,variable)
		}
		return 0
	    }

	    _add_variable $path $text $var
        }

        canvasVariable {
            set tagOrItem  [lindex $args 0]
            set var        [lindex $args 1]
            set text       [lindex $args 2]
	    if {$text == "" || $var == ""} {
		if {[info exists _registered($path,$tagOrItem,variable)]} {
		    unset _registered($path,$tagOrItem,variable)
		}
		return 0
	    }

	    _add_canvas_variable $path $text $var $tagOrItem
        }

        menu {
            set var [lindex $args 0]
	    if {$var == ""} {
		set cpath [BWidget::clonename $path]
		if {[winfo exists $cpath]} { set path $cpath }
		if {[info exists _registered($path)]} {
		    unset _registered($path)
		}
		return 0
	    }

	    _add_menu $path $var
        }

        menuentry {
            set cpath [BWidget::clonename $path]
            if { [winfo exists $cpath] } { set path $cpath }
            if {![info exists _registered($path)]} { return 0 }

            set text  [lindex $args 1]
            set index [lindex $args 0]
	    if {$text == "" || $index == ""} {
		set idx [lsearch $_registed($path) [list $index *]]
		set _registered($path) [lreplace $_registered($path) $idx $idx]
		return 0
	    }

	    _add_menuentry $path $text $index
        }

        default {
            _unset_help $path
	    return 0
        }
    }

    return 1
}


proc DynamicHelp::add { path args } {
    variable _registered

    array set data {
        -type     balloon
        -text     ""
        -item     ""
        -index    -1
        -command  ""
        -variable ""
    }
    if {[winfo exists $path] && [winfo class $path] == "Menu"} {
	set data(-type) menu
    }
    array set data $args

    set item $path

    switch -- $data(-type) {
        "balloon" {
            if {$data(-item) != ""} {
                _add_canvas_balloon $path $data(-text) $data(-item)
                set item $path,$data(-item)
            } else {
                _add_balloon $path $data(-text)
            }

	    if {$data(-variable) != ""} {
		set _registered($item,balloonVar) $data(-variable)
	    }
        }

        "variable" {
            set var $data(-variable)
            if {$data(-item) != ""} {
                _add_canvas_variable $path $data(-text) $var $data(-item)
                set item $path,$data(-item)
            } else {
                _add_variable $path $data(-text) $var
            }
        }

        "menu" {
            if {$data(-index) != -1} {
                set cpath [BWidget::clonename $path]
                if { [winfo exists $cpath] } { set path $cpath }
                if {![info exists _registered($path)]} { return 0 }
                _add_menuentry $path $data(-text) $data(-index)
                set item $path,$data(-index)
            } else {
                _add_menu $path $data(-variable)
            }
        }

        default {
            return 0
        }
    }

    if {$data(-command) != ""} {set _registered($item,command) $data(-command)}

    return 1
}


proc DynamicHelp::delete { path } {
    _unset_help $path
}


proc DynamicHelp::_add_bind_tag { path tag } {
    set evt [bindtags $path]
    set idx [lsearch $evt $tag]
    set evt [lreplace $evt $idx $idx]