source: trunk/BWidget-1.2.1/dynhelp.tcl

Last change on this file was 931, checked in by toby, 11 years ago

include rest of files

File size: 11.0 KB
Line 
1# ------------------------------------------------------------------------------
2#  dynhelp.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: dynhelp.tcl,v 1.3 1999/07/09 08:09:38 eric Exp $
5# ------------------------------------------------------------------------------
6#  Index of commands:
7#     - DynamicHelp::configure
8#     - DynamicHelp::include
9#     - DynamicHelp::sethelp
10#     - DynamicHelp::register
11#     - DynamicHelp::_motion_balloon
12#     - DynamicHelp::_motion_info
13#     - DynamicHelp::_leave_info
14#     - DynamicHelp::_menu_info
15#     - DynamicHelp::_show_help
16#     - DynamicHelp::_init
17# ------------------------------------------------------------------------------
18
19namespace eval DynamicHelp {
20    Widget::declare DynamicHelp {
21        {-foreground  TkResource black         0 label}
22        {-background  TkResource "#FFFFC0"     0 label}
23        {-borderwidth TkResource 1             0 label}
24        {-justify     TkResource left          0 label}
25        {-font        TkResource "helvetica 8" 0 label}
26        {-delay       Int        600           0 {=100 =2000}}
27        {-bd          Synonym    -borderwidth}
28        {-bg          Synonym    -background}
29        {-fg          Synonym    -foreground}
30    }
31
32    proc use {} {}
33
34    variable _registered
35
36    variable _top     ".help_shell"
37    variable _id      "" 
38    variable _delay   600
39    variable _current ""
40    variable _saved
41
42    Widget::init DynamicHelp $_top {}
43
44    bind BwHelpBalloon <Enter>   {DynamicHelp::_motion_balloon enter  %W %X %Y}
45    bind BwHelpBalloon <Motion>  {DynamicHelp::_motion_balloon motion %W %X %Y}
46    bind BwHelpBalloon <Leave>   {DynamicHelp::_motion_balloon leave  %W %X %Y}
47    bind BwHelpBalloon <Button>  {DynamicHelp::_motion_balloon button %W %X %Y}
48    bind BwHelpBalloon <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
49
50    bind BwHelpVariable <Enter>   {DynamicHelp::_motion_info %W}
51    bind BwHelpVariable <Motion>  {DynamicHelp::_motion_info %W}
52    bind BwHelpVariable <Leave>   {DynamicHelp::_leave_info  %W}
53    bind BwHelpVariable <Destroy> {catch {unset DynamicHelp::_registered(%W)}}
54
55    bind BwHelpMenu <<MenuSelect>> {DynamicHelp::_menu_info select %W}
56    bind BwHelpMenu <Unmap>        {DynamicHelp::_menu_info unmap  %W}
57    bind BwHelpMenu <Destroy>      {catch {unset DynamicHelp::_registered(%W)}}
58}
59
60
61# ------------------------------------------------------------------------------
62#  Command DynamicHelp::configure
63# ------------------------------------------------------------------------------
64proc DynamicHelp::configure { args } {
65    variable _top
66    variable _delay
67
68    set res [Widget::configure $_top $args]
69    if { [Widget::hasChanged $_top -delay val] } {
70        set _delay $val
71    }
72
73    return $res
74}
75
76
77# ------------------------------------------------------------------------------
78#  Command DynamicHelp::include
79# ------------------------------------------------------------------------------
80proc DynamicHelp::include { class type } {
81    set helpoptions {
82        {-helptext String "" 0}
83        {-helpvar  String "" 0}}
84    lappend helpoptions [list -helptype Enum $type 0 {balloon variable}]
85    Widget::declare $class $helpoptions
86}
87
88
89# ------------------------------------------------------------------------------
90#  Command DynamicHelp::sethelp
91# ------------------------------------------------------------------------------
92proc DynamicHelp::sethelp { path subpath {force 0}} {
93    set ctype [Widget::hasChanged $path -helptype htype]
94    set ctext [Widget::hasChanged $path -helptext htext]
95    set cvar  [Widget::hasChanged $path -helpvar  hvar]
96    if { $force || $ctype || $ctext || $cvar } {
97        switch $htype {
98            balloon {
99                return [register $subpath balloon $htext]
100            }
101            variable {
102                return [register $subpath variable $hvar $htext]
103            }
104        }
105        return [register $subpath $htype]
106    }
107}
108
109
110# ------------------------------------------------------------------------------
111#  Command DynamicHelp::register
112# ------------------------------------------------------------------------------
113proc DynamicHelp::register { path type args } {
114    variable _registered
115
116    if { [winfo exists $path] } {
117        set evt  [bindtags $path]
118        set idx  [lsearch $evt "BwHelp*"]
119        set evt  [lreplace $evt $idx $idx]
120        switch $type {
121            balloon {
122                set text [lindex $args 0]
123                if { $text != "" } {
124                    set _registered($path) $text
125                    lappend evt BwHelpBalloon
126                } else {
127                    catch {unset _registered($path)}
128                }
129                bindtags $path $evt
130                return 1
131            }
132
133            variable {
134                set var  [lindex $args 0]
135                set text [lindex $args 1]
136                if { $text != "" && $var != "" } {
137                    set _registered($path) [list $var $text]
138                    lappend evt BwHelpVariable
139                } else {
140                    catch {unset _registered($path)}
141                }
142                bindtags $path $evt
143                return 1
144            }
145
146            menu {
147                set cpath [BWidget::clonename $path]
148                if { [winfo exists $cpath] } {
149                    set path $cpath
150                }
151                set var [lindex $args 0]
152                if { $var != "" } {
153                    set _registered($path) [list $var]
154                    lappend evt BwHelpMenu
155                } else {
156                    catch {unset _registered($path)}
157                }
158                bindtags $path $evt
159                return 1
160            }
161
162            menuentry {
163                set cpath [BWidget::clonename $path]
164                if { [winfo exists $cpath] } {
165                    set path $cpath
166                }
167                if { [info exists _registered($path)] } {
168                    if { [set index [lindex $args 0]] != "" } {
169                        set text  [lindex $args 1]
170                        set idx   [lsearch $_registered($path) [list $index *]]
171                        if { $text != "" } {
172                            if { $idx == -1 } {
173                                lappend _registered($path) [list $index $text]
174                            } else {
175                                set _registered($path) [lreplace $_registered($path) $idx $idx [list $index $text]]
176                            }
177                        } else {
178                            set _registered($path) [lreplace $_registered($path) $idx $idx]
179                        }
180                    }
181                    return 1
182                }
183                return 0
184            }
185        }
186        catch {unset _registered($path)}
187        bindtags $path $evt
188        return 1
189    } else {
190        catch {unset _registered($path)}
191        return 0
192    }
193}
194
195
196# ------------------------------------------------------------------------------
197#  Command DynamicHelp::_motion_balloon
198# ------------------------------------------------------------------------------
199proc DynamicHelp::_motion_balloon { type path x y } {
200    variable _top
201    variable _id
202    variable _delay
203    variable _current
204
205    if { $_current != $path && $type == "enter" } {
206        set _current $path
207        set type "motion"
208        destroy $_top
209    }
210    if { $_current == $path } {
211        if { $_id != "" } {
212            after cancel $_id
213            set _id ""
214        }
215        if { $type == "motion" } {
216            if { ![winfo exists $_top] } {
217                set _id [after $_delay "DynamicHelp::_show_help $path $x $y"]
218            }
219        } else {
220            destroy $_top
221            set _current ""
222        }
223    }
224}
225
226
227# ------------------------------------------------------------------------------
228#  Command DynamicHelp::_motion_info
229# ------------------------------------------------------------------------------
230proc DynamicHelp::_motion_info { path } {
231    variable _registered
232    variable _current
233    variable _saved
234
235    if { $_current != $path && [info exists _registered($path)] } {
236        if { ![info exists _saved] } {
237            set _saved [GlobalVar::getvar [lindex $_registered($path) 0]]
238        }
239        GlobalVar::setvar [lindex $_registered($path) 0] [lindex $_registered($path) 1]
240        set _current $path
241    }
242}
243
244
245# ------------------------------------------------------------------------------
246#  Command DynamicHelp::_leave_info
247# ------------------------------------------------------------------------------
248proc DynamicHelp::_leave_info { path } {
249    variable _registered
250    variable _current
251    variable _saved
252
253    if { [info exists _registered($path)] } {
254        GlobalVar::setvar [lindex $_registered($path) 0] $_saved
255    }
256    unset _saved
257    set _current ""
258   
259}
260
261
262# ------------------------------------------------------------------------------
263#  Command DynamicHelp::_menu_info
264#    Version of R1v1 restored, due to lack of [winfo ismapped] and <Unmap>
265#    under windows for menu.
266# ------------------------------------------------------------------------------
267proc DynamicHelp::_menu_info { event path } {
268    variable _registered
269 
270    if { [info exists _registered($path)] } {
271        set index [$path index active]
272        if { [string compare $index "none"] &&
273             [set idx [lsearch $_registered($path) [list $index *]]] != -1 } {
274            GlobalVar::setvar [lindex $_registered($path) 0] \
275                [lindex [lindex $_registered($path) $idx] 1]
276        } else {
277            GlobalVar::setvar [lindex $_registered($path) 0] ""
278        }
279    }
280}
281
282
283# ------------------------------------------------------------------------------
284#  Command DynamicHelp::_show_help
285# ------------------------------------------------------------------------------
286proc DynamicHelp::_show_help { path x y } {
287    variable _top
288    variable _registered
289    variable _id
290    variable _delay
291
292    if { [info exists _registered($path)] } {
293        destroy  $_top
294        toplevel $_top -relief flat \
295            -bg [Widget::getoption $_top -foreground] \
296            -bd [Widget::getoption $_top -borderwidth]
297        wm overrideredirect $_top 1
298        wm transient $_top
299        wm withdraw $_top
300
301        label $_top.label -text $_registered($path) \
302            -relief flat -bd 0 -highlightthickness 0 \
303            -foreground [Widget::getoption $_top -foreground] \
304            -background [Widget::getoption $_top -background] \
305            -font       [Widget::getoption $_top -font] \
306            -justify    [Widget::getoption $_top -justify]
307
308
309        pack $_top.label -side left
310        update idletasks
311
312        set  scrwidth  [winfo vrootwidth  .]
313        set  scrheight [winfo vrootheight .]
314        set  width     [winfo reqwidth  $_top]
315        set  height    [winfo reqheight $_top]
316        incr y 12
317        incr x 8
318
319        if { $x+$width > $scrwidth } {
320            set x [expr $scrwidth - $width]
321        }
322        if { $y+$height > $scrheight } {
323            set y [expr $y - 12 - $height]
324        }
325
326        wm geometry  $_top "+$x+$y"
327        update idletasks
328        wm deiconify $_top
329    }
330}
331
332
Note: See TracBrowser for help on using the repository browser.