370 lines
12 KiB
Tcl
370 lines
12 KiB
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
|
|
# ------------------------------------------------------------------------------
|
|
|
|
# JDC: allow variable and ballon help at the same timees
|
|
|
|
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)}}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# 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
|
|
# ------------------------------------------------------------------------------
|
|
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
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Command DynamicHelp::_motion_balloon
|
|
# ------------------------------------------------------------------------------
|
|
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 ""
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Command DynamicHelp::_motion_info
|
|
# ------------------------------------------------------------------------------
|
|
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
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Command DynamicHelp::_leave_info
|
|
# ------------------------------------------------------------------------------
|
|
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 ""
|
|
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Command DynamicHelp::_menu_info
|
|
# Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
|
|
# under windows for menu.
|
|
# ------------------------------------------------------------------------------
|
|
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] ""
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Command DynamicHelp::_show_help
|
|
# ------------------------------------------------------------------------------
|
|
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
|
|
}
|
|
}
|
|
|
|
|