0byt3m1n1
Path:
C:
/
Program Files
/
R
/
R-4.4.1
/
Tcl
/
lib
/
BWidget
/
[
Home
]
File: dynhelp.tcl
# ---------------------------------------------------------------------------- # dynhelp.tcl # This file is part of Unifix BWidget Toolkit # $Id: dynhelp.tcl,v 1.20.2.1 2009/08/12 07:20:21 oehhar 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 # ---------------------------------------------------------------------------- namespace eval DynamicHelp { Widget::define DynamicHelp dynhelp -classonly if {$::tcl_version >= 8.5} { set fontdefault TkTooltipFont } elseif {$Widget::_aqua} { set fontdefault {helvetica 11} } else { set fontdefault {helvetica 8} } Widget::declare DynamicHelp [list\ {-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}\ [list -font TkResource $fontdefault 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 _texts 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 <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 -helpcmd 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} { switch -exact -- [winfo class $path] { "Canvas" { set type canvasBalloon } "Text" - "Ctext" { set type textBalloon } } } if {$type == "variable" && $len > 2} { switch -exact -- [winfo class $path] { "Canvas" { set type canvasVariable } "Text" - "Ctext" { set type textVariable } } } 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 } textBalloon { 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_text_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 } textVariable { 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_text_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 $_registered($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) != ""} { switch -exact -- [winfo class $path] { "Canvas" { _add_canvas_balloon $path $data(-text) $data(-item) set item $path,$data(-item) } "Text" - "Ctext" { _add_text_balloon $path $data(-text) $data(-item) set item $path,$data(-item) } default { _add_balloon $path $data(-text) } } } else { _add_balloon $path $data(-text) } if {$data(-variable) != ""} { set _registered($item,balloonVar) $data(-variable) } } "variable" { set var $data(-variable) if {$data(-item) != ""} { switch -exact -- [winfo class $path] { "Canvas" { _add_canvas_variable $path $data(-text) $var $data(-item) set item $path,$data(-item) } "Text" - "Ctext" { _add_text_variable $path $data(-text) $var $data(-item) set item $path,$data(-item) } default { _add_variable $path $data(-text) $var } } } 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] lappend evt $tag bindtags $path $evt } proc DynamicHelp::_add_balloon { path text } { variable _registered set _registered($path,balloon) $text _add_bind_tag $path BwHelpBalloon } proc DynamicHelp::_add_canvas_balloon { path text tagOrItem } { variable _canvases variable _registered set _registered($path,$tagOrItem,balloon) $text if {![info exists _canvases($path,balloon)]} { ## This canvas doesn't have the bindings yet. _add_bind_tag $path BwHelpBalloon $path bind BwHelpBalloon <Enter> \ {DynamicHelp::_motion_balloon enter %W %X %Y 1} $path bind BwHelpBalloon <Motion> \ {DynamicHelp::_motion_balloon motion %W %X %Y 1} $path bind BwHelpBalloon <Leave> \ {DynamicHelp::_motion_balloon leave %W %X %Y 1} $path bind BwHelpBalloon <Button> \ {DynamicHelp::_motion_balloon button %W %X %Y 1} set _canvases($path,balloon) 1 } $path addtag BwHelpBalloon withtag $tagOrItem } proc DynamicHelp::_add_text_balloon { path text tagOrItem } { variable _texts variable _registered set _registered($path,$tagOrItem,balloon) $text if { ![info exists _texts($path,$tagOrItem,balloon)] } { $path tag bind $tagOrItem <Enter> \ [list DynamicHelp::_motion_balloon enter $path %X %Y 0 1] $path tag bind $tagOrItem <Motion> \ [list DynamicHelp::_motion_balloon motion $path %X %Y 0 1] $path tag bind $tagOrItem <Leave> \ [list DynamicHelp::_motion_balloon leave $path %X %Y 0 1] $path tag bind $tagOrItem <Button> \ [list DynamicHelp::_motion_balloon button $path %X %Y 0 1] set _texts($path,$tagOrItem,balloon) 1 } } proc DynamicHelp::_add_variable { path text varName } { variable _registered set _registered($path,variable) [list $varName $text] _add_bind_tag $path BwHelpVariable } proc DynamicHelp::_add_canvas_variable { path text varName tagOrItem } { variable _canvases variable _registered set _registered($path,$tagOrItem,variable) [list $varName $text] if {![info exists _canvases($path,variable)]} { ## This canvas doesn't have the bindings yet. _add_bind_tag $path BwHelpVariable $path bind BwHelpVariable <Enter> \ {DynamicHelp::_motion_info %W 1} $path bind BwHelpVariable <Motion> \ {DynamicHelp::_motion_info %W 1} $path bind BwHelpVariable <Leave> \ {DynamicHelp::_leave_info %W 1} set _canvases($path,variable) 1 } $path addtag BwHelpVariable withtag $tagOrItem } proc DynamicHelp::_add_text_variable { path text varName tagOrItem } { variable _texts variable _registered set _registered($path,$tagOrItem,variable) [list $varName $text] if {![info exists _texts($path,$tagOrItem,variable)]} { $path tag bind $tagOrItem <Enter> \ [list DynamicHelp::_motion_info $path 0 1] $path tag bind $tagOrItem <Motion> \ [list DynamicHelp::_motion_info $path 0 1] $path tag bind $tagOrItem <Leave> \ [list DynamicHelp::_leave_info $path 0 1] set _texts($path,$tagOrItem,variable) 1 } } proc DynamicHelp::_add_menu { path varName } { variable _registered set cpath [BWidget::clonename $path] if { [winfo exists $cpath] } { set path $cpath } set _registered($path) [list $varName] _add_bind_tag $path BwHelpMenu } proc DynamicHelp::_add_menuentry { path text index } { variable _registered set idx [lsearch $_registered($path) [list $index *]] set list [list $index $text] if { $idx == -1 } { lappend _registered($path) $list } else { set _registered($path) \ [lreplace $_registered($path) $idx $idx $list] } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_motion_balloon # ---------------------------------------------------------------------------- proc DynamicHelp::_motion_balloon { type path x y {isCanvasItem 0} {isTextItem 0} } { variable _top variable _id variable _delay variable _current_balloon set w $path if {$isCanvasItem} { set path [_get_canvas_path $path balloon] } elseif {$isTextItem} { set path [_get_text_path $path 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 cmd [list DynamicHelp::_show_help $path $w $x $y] set _id [after $_delay $cmd] } # Bug 923942 proposes to destroy on motion to remove dynhelp on motion. # this might be an optional behaviour in future versions } else { destroy $_top set _current_balloon "" } } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_motion_info # ---------------------------------------------------------------------------- proc DynamicHelp::_motion_info { path {isCanvasItem 0} {isTextItem 0} } { variable _saved variable _registered variable _current_variable if {$isCanvasItem} { set path [_get_canvas_path $path variable] } elseif {$isTextItem} { set path [_get_text_path $path variable] } if { $_current_variable != $path && [info exists _registered($path,variable)] } { set varName [lindex $_registered($path,variable) 0] if {![info exists _saved]} { set _saved [GlobalVar::getvar $varName] } set string [lindex $_registered($path,variable) 1] if {[info exists _registered($path,command)]} { set string [uplevel #0 $_registered($path,command)] } GlobalVar::setvar $varName $string set _current_variable $path } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_leave_info # Leave event may be called twice (in case of pointer grab) # ---------------------------------------------------------------------------- proc DynamicHelp::_leave_info { path {isCanvasItem 0} {isTextItem 0} } { variable _saved variable _registered variable _current_variable if {$isCanvasItem} { set path [_get_canvas_path $path variable] } elseif {$isTextItem} { set path [_get_text_path $path variable] } if { [string equal $_current_variable $path] \ && [info exists _registered($path,variable)] } { set varName [lindex $_registered($path,variable) 0] GlobalVar::setvar $varName $_saved unset _saved set _current_variable "" } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_menu_info # ---------------------------------------------------------------------------- # We have to check for unmap event on Unix. On Windows, unmap # is not delivered, but <<MenuSelect>> is triggered appropriately when menu # is unmapped. proc DynamicHelp::_menu_info { event path } { variable _registered if { [info exists _registered($path)] } { set index [$path index active] set varName [lindex $_registered($path) 0] if { ![string equal $event "unmap"] && ![string equal $index "none"] && [set idx [lsearch $_registered($path) [list $index *]]] != -1 } { set string [lindex [lindex $_registered($path) $idx] 1] if {[info exists _registered($path,$index,command)]} { set string [uplevel #0 $_registered($path,$index,command)] } GlobalVar::setvar $varName $string } else { GlobalVar::setvar $varName "" } } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_show_help # ---------------------------------------------------------------------------- proc DynamicHelp::_show_help { path w x y } { variable _top variable _registered variable _id variable _delay if { [Widget::getoption $_top -state] == "disabled" } { return } if { [info exists _registered($path,balloon)] } { destroy $_top set string $_registered($path,balloon) if {[info exists _registered($path,balloonVar)]} { upvar #0 $_registered($path,balloonVar) var if {[info exists var]} { set string $var } } if {[info exists _registered($path,command)]} { set string [uplevel #0 $_registered($path,command)] } if {$string == ""} { return } toplevel $_top -relief flat \ -bg [Widget::getoption $_top -topbackground] \ -bd [Widget::getoption $_top -borderwidth] \ -screen [winfo screen $w] wm withdraw $_top if { $Widget::_aqua } { ::tk::unsupported::MacWindowStyle style $_top help none } else { wm overrideredirect $_top 1 } catch { wm attributes $_top -topmost 1 } label $_top.label -text $string \ -relief flat -bd 0 -highlightthickness 0 \ -padx [Widget::getoption $_top -padx] \ -pady [Widget::getoption $_top -pady] \ -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] # On windows multi screen configurations, the virtual screen may start # at negative positions. set scrrootx [winfo vrootx .] set scrrooty [winfo vrooty .] # Increment the required size by the deplacement from the passed point incr width 8 incr height 12 # Put at the right border if going over it if { $x+$width > $scrrootx+$scrwidth } { set x [expr {$scrwidth + $scrrootx - $width + 8}] } else { incr x 8 } # Put above widget if below is no space if { $y+$height > $scrrooty+$scrheight } { set y [expr {$y - $height}] } else { incr y 12 } wm geometry $_top "+$x+$y" update idletasks if {![winfo exists $_top]} { return } wm deiconify $_top raise $_top # Sometimes the tooltip does not occur under # gnome/metacity on ubuntu. after 5; } } # ---------------------------------------------------------------------------- # Command DynamicHelp::_unset_help # ---------------------------------------------------------------------------- proc DynamicHelp::_unset_help { path } { variable _canvases variable _texts variable _registered variable _top variable _current_balloon if {[info exists _registered($path)]} { unset _registered($path) } if {[winfo exists $path]} { set cpath [BWidget::clonename $path] if {[info exists _registered($cpath)]} { unset _registered($cpath) } } array unset _canvases $path,* array unset _texts $path,* array unset _registered $path,* if {[string equal $path $_current_balloon]} {destroy $_top} } # ---------------------------------------------------------------------------- # Command DynamicHelp::_get_canvas_path # ---------------------------------------------------------------------------- proc DynamicHelp::_get_canvas_path { path type {item ""} } { variable _registered if {$item == ""} { set item [$path find withtag current] } ## Check the tags related to this item for the one that ## represents our text. If we have text specific to this ## item or for 'all' items, they override any other tags. eval [list lappend tags $item all] [$path itemcget $item -tags] foreach tag $tags { set check $path,$tag if {![info exists _registered($check,$type)]} { continue } return $check } return $path } # ---------------------------------------------------------------------------- # Command DynamicHelp::_get_text_path # ---------------------------------------------------------------------------- proc DynamicHelp::_get_text_path { path type {item ""} } { variable _registered if {$item == ""} { set item [$path tag names current] } ## Check the tags related to this item for the one that ## represents our text. If we have text specific to this ## item or for 'all' items, they override any other tags. eval [list lappend tags $item all] $item foreach tag $tags { set check $path,$tag if {![info exists _registered($check,$type)]} { continue } return $check } return $path }