Bwidget Source Code
Check-in [e3d15ada17]
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:*** code consolidation + refracturing related to BWSlim.Toolbutton style, attempt to improve Button behavior when ttk is used (still not perfect thought)
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e3d15ada173f315c8965077eb260ffe081c2441b
User & Date: oberdorfer 2009-11-01 20:20:16
Context
2009-11-01
20:46
*** bug fixed - related to ttk behaviour # without this function, an error occures # when operating under tile control proc Button::instate { path args } { return [expr { [$path cget -state] == "normal" ? 1 : 0}] } check-in: f64f8938dc user: oberdorfer tags: trunk, tcllib-1-12
20:20
*** code consolidation + refracturing related to BWSlim.Toolbutton style, attempt to improve Button behavior when ttk is used (still not perfect thought) check-in: e3d15ada17 user: oberdorfer tags: trunk
2009-10-27
22:14
* continuous developement, minor changes check-in: afb47531db user: oberdorfer tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to button.tcl.

1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
..
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
...
158
159
160
161
162
163
164
165
166
167
168
169





170
171
172
173
174
175
176
177
178
...
217
218
219
220
221
222
223

224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
...
275
276
277
278
279
280
281







282
283
284
285
286
287
288
...
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
...
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
...
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
...
406
407
408
409
410
411
412

413
414
415
416
417
418
419
420
421
422
423
424
# ----------------------------------------------------------------------------
#  button.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: button.tcl,v 1.14 2009/09/11 16:04:14 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#   Public commands
#     - Button::create
#     - Button::configure
#     - Button::cget
#     - Button::invoke

#   Private commands (event bindings)
#     - Button::_destroy
#     - Button::_enter
#     - Button::_leave
#     - Button::_press
#     - Button::_release
#     - Button::_repeat

# ----------------------------------------------------------------------------

namespace eval Button {

    Widget::define Button button DynamicHelp

    set remove [list -command -relief -text -textvariable -underline -state]
    if {[info tclversion] > 8.3} {
	lappend remove -repeatdelay -repeatinterval
    }
    
    # if { [BWidget::using ttk] } { lappend remove -borderwidth }

    Widget::tkinclude Button button :cmd remove $remove

    Widget::declare Button {
        {-name            String "" 0}
        {-text            String "" 0}
        {-textvariable    String "" 0}
................................................................................
    variable _ttkunsupported
    set _ttkunsupported_opt \
           { -font -fg -foreground -background
	     -highlightthickness -bd -borderwidth
	     -padx -pady -anchor }
}


proc Button::createButtonStyles {} {
    variable _styles_created
 
    if { [info exists _styles_created] && $_styles_created != 0 } {
        return
    } 
    if { ![BWidget::using ttk] } { return }

    # create a new element for each available theme...
    foreach themeName [ttk::style theme names] {

       # temporarily sets the current theme to themeName,
       # evaluate script, then restore the previous theme.

        ttk::style theme settings $themeName {
  
            # emulate tk behavior, referenced later on such like:
            #    -style "${relief}BW.TButton"

            ::ttk::style configure raisedBW.TButton -relief raised
            ::ttk::style configure sunkenBW.TButton -relief sunken
            ::ttk::style configure flatBW.TButton   -relief flat
            ::ttk::style configure solidBW.TButton  -relief solid
            ::ttk::style configure grooveBW.TButton -relief groove
            ::ttk::style configure linkBW.TButton   -relief flat -bd 2
        }
    }

    set _styles_created 1
}



# ----------------------------------------------------------------------------
#  Command Button::create
# ----------------------------------------------------------------------------
proc Button::create { path args } {
    variable _ttkunsupported_opt

    if { [BWidget::using ttk] } {
        createButtonStyles

        # remove unsupported tk options
	# (hope that's all we need to take care about)
	foreach opt $_ttkunsupported_opt {
            set args [Widget::getArgument $args $opt tmp]
	}
        set args [Widget::getArgument $args "-relief" relief]
................................................................................
    } else {
        set args [Widget::getArgument $args "-style" tmp]
    }

    array set maps [list Button {} :cmd {}]
    array set maps [Widget::parseArgs Button $args]

    if {[BWidget::using ttk]} {
         eval [concat [list ttk::button $path] $maps(:cmd)]
    } else {
         eval [concat [list button $path] $maps(:cmd)]
    }  

    Widget::initFromODB Button $path $maps(Button)

    # Do some extra configuration on the button
    set relief [Widget::getMegawidgetOption $path -relief]

    if { [string equal $relief "link"] } {
        set relief "flat"
    }
    set var [Widget::getMegawidgetOption $path -textvariable]
    set st  [Widget::getMegawidgetOption $path -state]
    if {  ![string length $var] } {
        set desc [BWidget::getname [Widget::getMegawidgetOption $path -name]]
        if { [llength $desc] } {
................................................................................
        }
    } else {
        set under -1
        set text  ""
        Widget::configure $path [list -underline $under]
    }


    if { [BWidget::using ttk] } {
         $path configure -text $text -underline $under \
                         -textvariable $var -state $st






	 if { [$path cget -style] != "BWSlim.Toolbutton" } {
             $path configure -style "${relief}BW.TButton"
	 }
    } else {
         $path configure -relief $relief -text $text -underline $under \
	       -textvariable $var -state $st
    }

    bindtags $path [list $path BwButton [winfo toplevel $path] all]
................................................................................

    # Extract all the modified bits we're interested in
    foreach {cr cs cv cn ct cu} [Widget::hasChangedX $path \
	    -relief -state -textvariable -name -text -underline] break
    if { $cr || $cs } {
	set relief [Widget::cget $path -relief]
	set state  [Widget::cget $path -state]

        if { [string equal $relief "link"] } {
            if { [string equal $state "active"] } {
                set relief "raised"
            } else {
                set relief "flat"
            }
        }

        if { [BWidget::using ttk] } {
            $path:cmd configure -state $state
            if { [string compare [$path:cmd cget -style] "BWSlim.Toolbutton"] != 0 } {
 	        $path:cmd configure -style "${relief}BW.TButton"
	    }
        } else {
            $path:cmd configure -relief $relief -state $state
        }
    }

    if { $cv || $cn || $ct || $cu } {
	set var		[Widget::cget $path -textvariable]
	set text	[Widget::cget $path -text]
	set under	[Widget::cget $path -underline]
        if {  ![string length $var] } {
            set desc [BWidget::getname [Widget::cget $path -name]]
            if { [llength $desc] } {
                set text  [lindex $desc 0]
                set under [lindex $desc 1]
            }
        } else {
................................................................................
# ----------------------------------------------------------------------------
#  Command Button::cget
# ----------------------------------------------------------------------------
proc Button::cget { path option } {
    Widget::cget $path $option
}









# ----------------------------------------------------------------------------
#  Command Button::invoke
# ----------------------------------------------------------------------------
proc Button::invoke { path } {
    if { ![string equal [$path:cmd cget -state] "disabled"] } {

................................................................................
	update idletasks
	set cmd [Widget::getMegawidgetOption $path -armcommand]
        if { $cmd != "" } {
            uplevel \#0 $cmd
        }
	after 100
        set relief [Widget::getMegawidgetOption $path -relief]
        if { [string equal $relief "link"] } {
            set relief flat
        }

        set state [Widget::getMegawidgetOption $path -state]

        _styleconfigure $path $relief

................................................................................
    variable _current
    variable _pressed

    set _current $path
    if { ![string equal [$path:cmd cget -state] "disabled"] } {
        $path:cmd configure -state active
        if { $_pressed == $path } {

            _styleconfigure $path sunken

        } elseif { [string equal [Widget::cget $path -relief] "link"] } {

            _styleconfigure $path raised
        }
    }
}


proc Button::_styleconfigure { path relief_or_style } {

    if { [BWidget::using ttk] } {
        # do not override the toolbutton style:
        if { [$path:cmd cget -style] != "BWSlim.Toolbutton" } {
            $path:cmd configure -style "${relief_or_style}BW.TButton"
	}
    } else {
        $path:cmd configure -relief $relief_or_style
    }
}


................................................................................
# ----------------------------------------------------------------------------
proc Button::_press { path } {
    variable _pressed

    if { ![string equal [$path:cmd cget -state] "disabled"] } {
        set _pressed $path

        _styleconfigure $path sunken
	
	set cmd [Widget::getMegawidgetOption $path -armcommand]
        if { $cmd != "" } {
            uplevel \#0 $cmd
	    set repeatdelay [Widget::getMegawidgetOption $path -repeatdelay]
	    set repeatint [Widget::getMegawidgetOption $path -repeatinterval]
            if { $repeatdelay > 0 } {
................................................................................
    variable _current
    variable _pressed

    if { $_pressed == $path } {
        set _pressed ""
        set relief [Widget::getMegawidgetOption $path -relief]
	after cancel "Button::_repeat $path"

        if { [string equal $relief "link"] } {
            set relief raised
        }

        _styleconfigure $path $relief

	set cmd [Widget::getMegawidgetOption $path -disarmcommand]
        if { $cmd != "" } {
            uplevel \#0 $cmd
        }
        if { $_current == $path &&
             ![string equal [$path:cmd cget -state] "disabled"] && \


|







>







>











|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








<







 







|
|
<
|
<



|


|







 







<




>
>
>
>
>
|
|







 







>
|

|
<
|
<





|







|
|
|







 







>
>
>
>
>
>
>







 







|







 







<

<

<











|







 







|







 







>




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
70
71
72
73
74
75
76

































77
78
79
80
81
82
83
84

85
86
87
88
89
90
91
..
93
94
95
96
97
98
99
100
101

102

103
104
105
106
107
108
109
110
111
112
113
114
115
116
...
124
125
126
127
128
129
130

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
...
187
188
189
190
191
192
193
194
195
196
197

198

199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
...
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
...
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
...
298
299
300
301
302
303
304

305

306

307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
...
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
...
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
# ----------------------------------------------------------------------------
#  button.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: button.tcl,v 1.15 2009/11/01 20:20:50 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#   Public commands
#     - Button::create
#     - Button::configure
#     - Button::cget
#     - Button::invoke
#     - Button::getSlimButtonStyle
#   Private commands (event bindings)
#     - Button::_destroy
#     - Button::_enter
#     - Button::_leave
#     - Button::_press
#     - Button::_release
#     - Button::_repeat
#     - Button::_styleconfigure
# ----------------------------------------------------------------------------

namespace eval Button {

    Widget::define Button button DynamicHelp

    set remove [list -command -relief -text -textvariable -underline -state]
    if {[info tclversion] > 8.3} {
	lappend remove -repeatdelay -repeatinterval
    }
    
    if { [BWidget::using ttk] } { lappend remove -borderwidth }

    Widget::tkinclude Button button :cmd remove $remove

    Widget::declare Button {
        {-name            String "" 0}
        {-text            String "" 0}
        {-textvariable    String "" 0}
................................................................................
    variable _ttkunsupported
    set _ttkunsupported_opt \
           { -font -fg -foreground -background
	     -highlightthickness -bd -borderwidth
	     -padx -pady -anchor }
}



































# ----------------------------------------------------------------------------
#  Command Button::create
# ----------------------------------------------------------------------------
proc Button::create { path args } {
    variable _ttkunsupported_opt

    if { [BWidget::using ttk] } {


        # remove unsupported tk options
	# (hope that's all we need to take care about)
	foreach opt $_ttkunsupported_opt {
            set args [Widget::getArgument $args $opt tmp]
	}
        set args [Widget::getArgument $args "-relief" relief]
................................................................................
    } else {
        set args [Widget::getArgument $args "-style" tmp]
    }

    array set maps [list Button {} :cmd {}]
    array set maps [Widget::parseArgs Button $args]

    if { [BWidget::using ttk] } {
             eval [concat [list ttk::button $path] $maps(:cmd)]

    } else { eval [concat [list      button $path] $maps(:cmd)] }  


    Widget::initFromODB Button $path $maps(Button)

    # do some extra configuration on the button
    set relief [Widget::getMegawidgetOption $path -relief]

    if { ![BWidget::using ttk] && [string equal $relief "link"] } {
        set relief "flat"
    }
    set var [Widget::getMegawidgetOption $path -textvariable]
    set st  [Widget::getMegawidgetOption $path -state]
    if {  ![string length $var] } {
        set desc [BWidget::getname [Widget::getMegawidgetOption $path -name]]
        if { [llength $desc] } {
................................................................................
        }
    } else {
        set under -1
        set text  ""
        Widget::configure $path [list -underline $under]
    }


    if { [BWidget::using ttk] } {
         $path configure -text $text -underline $under \
                         -textvariable $var -state $st

         # distinguish between a standard button (raised) which sould appear
	 # as declared in the celated style and button with user defined arg's
	 # where the style 'll be overwritten to emulate existing behavior   
	 
	 if { $relief != "raised" &&
	      [$path cget -style] != "BWSlim.Toolbutton" } {
             $path configure -style "BW${relief}.Toolbutton"
	 }
    } else {
         $path configure -relief $relief -text $text -underline $under \
	       -textvariable $var -state $st
    }

    bindtags $path [list $path BwButton [winfo toplevel $path] all]
................................................................................

    # Extract all the modified bits we're interested in
    foreach {cr cs cv cn ct cu} [Widget::hasChangedX $path \
	    -relief -state -textvariable -name -text -underline] break
    if { $cr || $cs } {
	set relief [Widget::cget $path -relief]
	set state  [Widget::cget $path -state]
	
        if { ![BWidget::using ttk] && [string equal $relief "link"] } {
            if { [string equal $state "active"] } {
                     set relief "raised"

            } else { set relief "flat" }

        }

        if { [BWidget::using ttk] } {
            $path:cmd configure -state $state
            if { [string compare [$path:cmd cget -style] "BWSlim.Toolbutton"] != 0 } {
 	        $path:cmd configure -style "BW${relief}.Toolbutton"
	    }
        } else {
            $path:cmd configure -relief $relief -state $state
        }
    }

    if { $cv || $cn || $ct || $cu } {
	set var	  [Widget::cget $path -textvariable]
	set text  [Widget::cget $path -text]
	set under [Widget::cget $path -underline]
        if {  ![string length $var] } {
            set desc [BWidget::getname [Widget::cget $path -name]]
            if { [llength $desc] } {
                set text  [lindex $desc 0]
                set under [lindex $desc 1]
            }
        } else {
................................................................................
# ----------------------------------------------------------------------------
#  Command Button::cget
# ----------------------------------------------------------------------------
proc Button::cget { path option } {
    Widget::cget $path $option
}


proc Button::getSlimButtonStyle {} {
    if { [BWidget::using ttk] } {
       return "BWSlim.Toolbutton"
    }
    return ""
}

# ----------------------------------------------------------------------------
#  Command Button::invoke
# ----------------------------------------------------------------------------
proc Button::invoke { path } {
    if { ![string equal [$path:cmd cget -state] "disabled"] } {

................................................................................
	update idletasks
	set cmd [Widget::getMegawidgetOption $path -armcommand]
        if { $cmd != "" } {
            uplevel \#0 $cmd
        }
	after 100
        set relief [Widget::getMegawidgetOption $path -relief]
        if { ![BWidget::using ttk] && [string equal $relief "link"] } {
            set relief flat
        }

        set state [Widget::getMegawidgetOption $path -state]

        _styleconfigure $path $relief

................................................................................
    variable _current
    variable _pressed

    set _current $path
    if { ![string equal [$path:cmd cget -state] "disabled"] } {
        $path:cmd configure -state active
        if { $_pressed == $path } {

            _styleconfigure $path sunken

        } elseif { [string equal [Widget::cget $path -relief] "link"] } {

            _styleconfigure $path raised
        }
    }
}


proc Button::_styleconfigure { path relief_or_style } {

    if { [BWidget::using ttk] } {
        # do not override the toolbutton style:
        if { [$path:cmd cget -style] != "BWSlim.Toolbutton" } {
            $path:cmd configure -style "BW${relief_or_style}.Toolbutton"
	}
    } else {
        $path:cmd configure -relief $relief_or_style
    }
}


................................................................................
# ----------------------------------------------------------------------------
proc Button::_press { path } {
    variable _pressed

    if { ![string equal [$path:cmd cget -state] "disabled"] } {
        set _pressed $path

        if { ![BWidget::using ttk] } { _styleconfigure $path sunken }
	
	set cmd [Widget::getMegawidgetOption $path -armcommand]
        if { $cmd != "" } {
            uplevel \#0 $cmd
	    set repeatdelay [Widget::getMegawidgetOption $path -repeatdelay]
	    set repeatint [Widget::getMegawidgetOption $path -repeatinterval]
            if { $repeatdelay > 0 } {
................................................................................
    variable _current
    variable _pressed

    if { $_pressed == $path } {
        set _pressed ""
        set relief [Widget::getMegawidgetOption $path -relief]
	after cancel "Button::_repeat $path"

        if { [string equal $relief "link"] } {
            set relief raised
        }

        if { ![BWidget::using ttk] } { _styleconfigure $path $relief }

	set cmd [Widget::getMegawidgetOption $path -disarmcommand]
        if { $cmd != "" } {
            uplevel \#0 $cmd
        }
        if { $_current == $path &&
             ![string equal [$path:cmd cget -state] "disabled"] && \

Changes to buttonbox.tcl.

1
2
3
4
5
6
7
8
9
10
11
...
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
# ----------------------------------------------------------------------------
#  buttonbox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: buttonbox.tcl,v 1.14 2009/09/06 21:03:48 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - ButtonBox::create
#     - ButtonBox::configure
#     - ButtonBox::cget
#     - ButtonBox::add
#     - ButtonBox::itemconfigure
................................................................................
	      -background [Widget::getoption $path -background]\
	      -padx       [Widget::getoption $path -padx] \
	      -pady       [Widget::getoption $path -pady]] \
        $args [list -default $style]

    # a button box button - by default - is flat!
    if { [BWidget::using ttk] } {
       $but configure -style "BWSlim.Toolbutton"
    }

    # [email protected]:  set up tags, just like the menu items
    foreach tag $tags {
	lappend data(tags,$tag) $but
	if { ![info exists data(tagstate,$tag)] } {
	    set data(tagstate,$tag) 0


|







 







|







1
2
3
4
5
6
7
8
9
10
11
...
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
# ----------------------------------------------------------------------------
#  buttonbox.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: buttonbox.tcl,v 1.15 2009/11/01 20:20:50 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - ButtonBox::create
#     - ButtonBox::configure
#     - ButtonBox::cget
#     - ButtonBox::add
#     - ButtonBox::itemconfigure
................................................................................
	      -background [Widget::getoption $path -background]\
	      -padx       [Widget::getoption $path -padx] \
	      -pady       [Widget::getoption $path -pady]] \
        $args [list -default $style]

    # a button box button - by default - is flat!
    if { [BWidget::using ttk] } {
       $but configure -style [Button::getSlimButtonStyle]
    }

    # [email protected]:  set up tags, just like the menu items
    foreach tag $tags {
	lappend data(tags,$tag) $but
	if { ![info exists data(tagstate,$tag)] } {
	    set data(tagstate,$tag) 0

Changes to font.tcl.

1
2
3
4
5
6
7
8
9
10
11
...
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
# ----------------------------------------------------------------------------
#  font.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: font.tcl,v 1.17 2009/09/06 21:14:46 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - SelectFont::create
#     - SelectFont::configure
#     - SelectFont::cget
#     - SelectFont::_draw
#     - SelectFont::_destroy
................................................................................
        pack $lbs -side left -anchor w -padx 4
        foreach st $_styles {
	    if { [BWidget::using ttk] } {
		ttk::checkbutton $path.$st -takefocus 0 \
		    -image [Bitmap::get $st] \
		    -variable SelectFont::${path}($st) \
		    -command [list SelectFont::_update $path] \
		    -style "BWSlimCB.Toolbutton"
	    } else {
		button $path.$st \
		    -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 \
		    -background $bg \
		    -image [Bitmap::get $st] \
		    -command [list SelectFont::_modstyle $path $st]
	    }


|







 







|







1
2
3
4
5
6
7
8
9
10
11
...
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
# ----------------------------------------------------------------------------
#  font.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: font.tcl,v 1.18 2009/11/01 20:20:50 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - SelectFont::create
#     - SelectFont::configure
#     - SelectFont::cget
#     - SelectFont::_draw
#     - SelectFont::_destroy
................................................................................
        pack $lbs -side left -anchor w -padx 4
        foreach st $_styles {
	    if { [BWidget::using ttk] } {
		ttk::checkbutton $path.$st -takefocus 0 \
		    -image [Bitmap::get $st] \
		    -variable SelectFont::${path}($st) \
		    -command [list SelectFont::_update $path] \
		    -style [Button::getSlimButtonStyle]
	    } else {
		button $path.$st \
		    -highlightthickness 0 -takefocus 0 -padx 0 -pady 0 \
		    -background $bg \
		    -image [Bitmap::get $st] \
		    -command [list SelectFont::_modstyle $path $st]
	    }

Changes to themeutils.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
...
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
...
235
236
237
238
239
240
241






242
243
244

245
246
247
248
249
250
251
...
398
399
400
401
402
403
404

































405
406
407
408
409
410
411
...
470
471
472
473
474
475
476


477
478
479
480
481
482
483
# themeutils.tcl ---
# ----------------------------------------------------------------------------
# Purpose:
#      This file is a contribution to the Unifix BWidget Toolkit.
#      An approach to re-vitalize the package and to take advantage of tile!
#      Author: Johann dot Oberdorfer at Googlemail dot com
#
#  $Id: themeutils.tcl,v 1.3 2009/10/27 22:15:09 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - BWidget::use
#     - BWidget::using
#     - BWidget::wrap
#     - BWidget::set_themedefaults
#     - BWidget::getAvailableThemes
................................................................................
	    
	        # attempt to load tile package (with the required version)
	        #   if { [catch {package present tile 0.8}] != 0 } {
                #       return -code error "Tile 0.8 is not available!"
		#   }

                if { [catch {uplevel "#0" package require tile 0.8}] != 0 } {
                    set _properties($package) 0
		} else {

                    # create a new element for each available theme...
                    foreach themeName [ttk::style theme names] {
                        # temporarily sets the current theme to themeName,
                        # evaluate script, then restore the previous theme.
                        ttk::style theme settings $themeName {
                            ttk::style configure BWSlimCB.Toolbutton -relief flat -bd 2
                            ttk::style map BWSlimCB.Toolbutton \
	                               -relief [list {selected !disabled} sunken]
		        }
		    }
                    set _properties($package) 1
		}
            }
	    default {
	        return -code error \
		  "[namespace current] bad option: '$package'"
	    }
        }
    }
................................................................................
    return 0
}


# a simple wrapper to distinguish between tk and ttk
proc ::BWidget::wrap {wtype wpath args} {







    if { [using ttk] } {
        # filter out (ttk-)unsupported (tk-)options:
	foreach opt {-background -bd -borderwith -highlightthickness} {

            set args [Widget::getArgument $args $opt tmp]
	}

        return [eval ttk::${wtype} $wpath $args]
    } else {
        return [eval $wtype $wpath $args]
    }
................................................................................
	  }
      }
    }

    return $cargs
}



































# Purpose:
#   Sets the current style + default ttk (tyled) theme,
#   ensure, color related array: "BWidget::colors" is updated as well
#
#   This procedure is called under the following conditions:
#      - When initializing the package, to make sure, that the default
................................................................................
    foreach {opt val} [BWidget::_read_ttkstylecolors] {
      switch -- $opt {
          "-foreground"  { set colors(SystemWindowText)  $val }
          "-background"  { set colors(SystemWindowFrame) $val }
          "-troughcolor" { set colors(SystemScrollbar)   $val }
      }
    }


}


proc ::BWidget::_themechanged {} {
  variable _properties

    set_themedefaults






|







 







|
<
<
<
<
<
<
<
<
<
<
<
<
|
<







 







>
>
>
>
>
>


<
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
...
153
154
155
156
157
158
159
160












161

162
163
164
165
166
167
168
...
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236

237
238
239
240
241
242
243
244
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
...
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
# themeutils.tcl ---
# ----------------------------------------------------------------------------
# Purpose:
#      This file is a contribution to the Unifix BWidget Toolkit.
#      An approach to re-vitalize the package and to take advantage of tile!
#      Author: Johann dot Oberdorfer at Googlemail dot com
#
#  $Id: themeutils.tcl,v 1.4 2009/11/01 20:20:50 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - BWidget::use
#     - BWidget::using
#     - BWidget::wrap
#     - BWidget::set_themedefaults
#     - BWidget::getAvailableThemes
................................................................................
	    
	        # attempt to load tile package (with the required version)
	        #   if { [catch {package present tile 0.8}] != 0 } {
                #       return -code error "Tile 0.8 is not available!"
		#   }

                if { [catch {uplevel "#0" package require tile 0.8}] != 0 } {
                         set _properties($package) 0












		} else { set _properties($package) 1 }

            }
	    default {
	        return -code error \
		  "[namespace current] bad option: '$package'"
	    }
        }
    }
................................................................................
    return 0
}


# a simple wrapper to distinguish between tk and ttk
proc ::BWidget::wrap {wtype wpath args} {

    set _ttkunsupported_opt \
           { -font -fg -foreground -background
	     -highlightthickness -bd -borderwidth
	     -padx -pady -anchor
             -relief -selectforeground -selectbackground }

    if { [using ttk] } {
        # filter out (ttk-)unsupported (tk-)options:

	foreach opt $$_ttkunsupported_opt {
            set args [Widget::getArgument $args $opt tmp]
	}

        return [eval ttk::${wtype} $wpath $args]
    } else {
        return [eval $wtype $wpath $args]
    }
................................................................................
	  }
      }
    }

    return $cargs
}


proc ::BWidget::_createOrUpdateButtonStyles {} {

    if { ![using ttk] } { return }

    # create a new element for each available theme...
    foreach themeName [ttk::style theme names] {

       # temporarily sets the current theme to themeName,
       # evaluate script, then restore the previous theme.

        ttk::style theme settings $themeName {
  
            # emulate tk behavior, referenced later on such like:
            #    -style "${relief}BW.Toolbutton"

            ::ttk::style configure BWraised.Toolbutton -relief raised
            ::ttk::style configure BWsunken.Toolbutton -relief sunken
            ::ttk::style configure BWflat.Toolbutton   -relief flat
            ::ttk::style configure BWsolid.Toolbutton  -relief solid
            ::ttk::style configure BWgroove.Toolbutton -relief groove
            ::ttk::style configure BWlink.Toolbutton   -relief flat -bd 2
	    
	    ::ttk::style map BWlink.Toolbutton \
	        -relief [list {selected !disabled} sunken]

	    ::ttk::style configure BWSlim.Toolbutton -relief flat -bd 2
            ::ttk::style map BWSlim.Toolbutton \
	        -relief [list {selected !disabled} sunken]
        }
    }
}


# Purpose:
#   Sets the current style + default ttk (tyled) theme,
#   ensure, color related array: "BWidget::colors" is updated as well
#
#   This procedure is called under the following conditions:
#      - When initializing the package, to make sure, that the default
................................................................................
    foreach {opt val} [BWidget::_read_ttkstylecolors] {
      switch -- $opt {
          "-foreground"  { set colors(SystemWindowText)  $val }
          "-background"  { set colors(SystemWindowFrame) $val }
          "-troughcolor" { set colors(SystemScrollbar)   $val }
      }
    }
    
    _createOrUpdateButtonStyles
}


proc ::BWidget::_themechanged {} {
  variable _properties

    set_themedefaults

Changes to widget.tcl.

1
2
3
4
5
6
7
8
9
10
11
....
1610
1611
1612
1613
1614
1615
1616

1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636

1637
1638
1639
1640
1641
1642
1643
# ----------------------------------------------------------------------------
#  widget.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: widget.tcl,v 1.36 2009/09/06 20:45:43 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - Widget::tkinclude
#     - Widget::bwinclude
#     - Widget::declare
#     - Widget::addmap
#     - Widget::init
................................................................................


proc Widget::exists { path } {
    variable _class
    return [info exists _class($path)]
}


proc Widget::theme {{bool {}}} {
    # Private, *experimental* API that may change at any time - JH
    variable _theme
    if {[llength [info level 0]] == 2} {
	# set theme-ability
	if {[catch {package require Tk 8.5a6}]
	    && [catch {package require tile 0.6}]
	    && [catch {package require tile 1}]} {
	    return -code error "BWidget's theming requires tile 0.6+"
	} else {
	    catch {
	      ttk::style configure BWSlimCB.Toolbutton -relief flat -bd 2
              ttk::style map BWSlimCB.Toolbutton \
	                 -relief [list {selected !disabled} sunken]
	    }
	}
	set _theme [string is true -strict $bool]
    }
    return $_theme
}


#------------------------------------------------------------------------------
# remove {keystr value} sub list from args
# arg contains the associated value of keystr, or an empty string
# while loop ensures to remove all matches of keystr 
#------------------------------------------------------------------------------
proc Widget::getArgument {args keystr arg} {


|







 







>





|
|
<
|
<
<
<
<
<
<





>







1
2
3
4
5
6
7
8
9
10
11
....
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624

1625






1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
# ----------------------------------------------------------------------------
#  widget.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: widget.tcl,v 1.37 2009/11/01 20:20:16 oberdorfer Exp $
# ----------------------------------------------------------------------------
#  Index of commands:
#     - Widget::tkinclude
#     - Widget::bwinclude
#     - Widget::declare
#     - Widget::addmap
#     - Widget::init
................................................................................


proc Widget::exists { path } {
    variable _class
    return [info exists _class($path)]
}

# deprecated, use "BWidget::use" instead!
proc Widget::theme {{bool {}}} {
    # Private, *experimental* API that may change at any time - JH
    variable _theme
    if {[llength [info level 0]] == 2} {
	# set theme-ability
	if {   [catch {package require Tk 8.4.7}]
	    && [catch {package require tile 0.8}] } {

	    return -code error "BWidget's theming requires tile 0.8+"






	}
	set _theme [string is true -strict $bool]
    }
    return $_theme
}


#------------------------------------------------------------------------------
# remove {keystr value} sub list from args
# arg contains the associated value of keystr, or an empty string
# while loop ensures to remove all matches of keystr 
#------------------------------------------------------------------------------
proc Widget::getArgument {args keystr arg} {