Bwidget Source Code
Check-in [c991d05924]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:* dynhelp.tcl (DynamicHelp::_leave_info et al) issues: - menu help sometimes not cleared when clicking off-window (unix) - "-helpcmd" available also when dynamichelp is included in another widget. - given "-helpcmd" always called at global scope. - Protect against multiple calls of <Leave> event. [Patch 2820851] by Koen Danckaert
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: c991d05924aeade4c12371dcc46384010c089cdf
User & Date: oehhar 2009-07-14 15:24:14
Context
2009-07-15
16:50
* dynhelp.tcl (DynamicHelp) Typo from yesterday corrected [Patch 2820851] by Koen Danckaert check-in: 4ec5be8a22 user: oehhar tags: trunk
2009-07-14
15:24
* dynhelp.tcl (DynamicHelp::_leave_info et al) issues: - menu help sometimes not cleared when clicking off-window (unix) - "-helpcmd" available also when dynamichelp is included in another widget. - given "-helpcmd" always called at global scope. - Protect against multiple calls of <Leave> event. [Patch 2820851] by Koen Danckaert check-in: c991d05924 user: oehhar tags: trunk
2009-07-07
17:28
* combobox.tcl (ComboBox::_select) Do not export selection if -exportselection 0 [Patch 981545] by Jeffrey Hobbs check-in: a1671d7ee7 user: oehhar tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.











1
2
3
4
5
6
7









2009-07-07 Harald Oehlmann  <[email protected]>

	* combobox.tcl (ComboBox::_select) Do not export selection if
	-exportselection 0 [Patch 981545] by Jeffrey Hobbs

2009-07-02 Harald Oehlmann  <[email protected]>

>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
2009-07-14 Harald Oehlmann  <[email protected]>

	* dynhelp.tcl (DynamicHelp::_leave_info et al) issues:
	- menu help sometimes not cleared when clicking off-window (unix)
	- "-helpcmd" available also when dynamichelp is included in another
	  widget.
	- given "-helpcmd" always called at global scope.
	- Protect against multiple calls of <Leave> event.
	[Patch 2820851] by Koen Danckaert

2009-07-07 Harald Oehlmann  <[email protected]>

	* combobox.tcl (ComboBox::_select) Do not export selection if
	-exportselection 0 [Patch 981545] by Jeffrey Hobbs

2009-07-02 Harald Oehlmann  <[email protected]>

Changes to dynhelp.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
..
87
88
89
90
91
92
93

94
95
96
97
98
99
100
...
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
...
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581

582
583
584
585
586
587
588
589
590
591
592
593

594
595
596
597
598
599

600
601
602
603
604
605
606
607



608
609
610
611
612
613

614
615
616
617
618
619
620
621
622
623
624
625
...
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
...
722
723
724
725
726
727
728

729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
# ----------------------------------------------------------------------------
#  dynhelp.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: dynhelp.tcl,v 1.18 2009/07/01 14:41:30 oehhar Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - DynamicHelp::configure
#     - DynamicHelp::include
#     - DynamicHelp::sethelp
#     - DynamicHelp::register
#     - DynamicHelp::_motion_balloon
................................................................................
    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}
................................................................................
# ----------------------------------------------------------------------------
#  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
}


# ----------------------------------------------------------------------------
................................................................................
            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
        }

................................................................................
    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 [eval $_registered($path,command)]
        }
        GlobalVar::setvar $varName $string
        set _current_variable $path
    }
}


# ----------------------------------------------------------------------------
#  Command DynamicHelp::_leave_info

# ----------------------------------------------------------------------------
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 { [info exists _registered($path,variable)] } {
        set varName [lindex $_registered($path,variable) 0]
        GlobalVar::setvar $varName $_saved
    }
    catch {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]
        set varName [lindex $_registered($path) 0]

        if { ![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 [eval $_registered($path,$index,command)]
	    }
            GlobalVar::setvar $varName $string
        } else {
            GlobalVar::setvar $varName ""
        }
    }
}
................................................................................

	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 [eval $_registered($path,command)]
        }

	if {$string == ""} { return }

        toplevel $_top -relief flat \
            -bg [Widget::getoption $_top -topbackground] \
            -bd [Widget::getoption $_top -borderwidth] \
................................................................................
#  Command DynamicHelp::_unset_help
# ----------------------------------------------------------------------------
proc DynamicHelp::_unset_help { path } {
    variable _canvases
    variable _texts
    variable _registered
    variable _top


    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,*
    destroy $_top
}

# ----------------------------------------------------------------------------
#  Command DynamicHelp::_get_canvas_path
# ----------------------------------------------------------------------------
proc DynamicHelp::_get_canvas_path { path type {item ""} } {
    variable _registered


|







 







<







 







>







 







|







 







|









>












>
|


<
|
|
>





<
<

>
>
>






>
|



|







 







|







 







>









|







1
2
3
4
5
6
7
8
9
10
11
..
48
49
50
51
52
53
54

55
56
57
58
59
60
61
..
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
...
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
...
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598

599
600
601
602
603
604
605
606


607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
...
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
...
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
# ----------------------------------------------------------------------------
#  dynhelp.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: dynhelp.tcl,v 1.19 2009/07/14 15:24:14 oehhar Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - DynamicHelp::configure
#     - DynamicHelp::include
#     - DynamicHelp::sethelp
#     - DynamicHelp::register
#     - DynamicHelp::_motion_balloon
................................................................................
    variable _current_balloon ""
    variable _current_variable ""
    variable _saved

    Widget::init DynamicHelp $_top {}

    bind BwHelpBalloon <Enter>   {DynamicHelp::_motion_balloon enter  %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}
................................................................................
# ----------------------------------------------------------------------------
#  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
}


# ----------------------------------------------------------------------------
................................................................................
            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
        }

................................................................................
    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 ""
        }
    }
}
................................................................................

	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] \
................................................................................
#  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