arcadia 0.13.1 → 1.0.0
This diff represents the content of publicly available package versions that have been released to one of the supported registries. The information contained in this diff is provided for informational purposes only and reflects changes between package versions as they appear in their respective public registries.
- checksums.yaml +4 -4
- data/{README → README.md} +60 -53
- data/conf/LC/en-UK.LANG +10 -4
- data/conf/arcadia.conf +221 -83
- data/conf/arcadia.res.rb +165 -175
- data/conf/theme-dark.conf +1 -1
- data/conf/theme-dark.res.rb +0 -123
- data/ext/ae-breakpoints/ae-breakpoints.rb +4 -3
- data/ext/ae-dir-projects/ae-dir-projects.conf +27 -1
- data/ext/ae-dir-projects/ae-dir-projects.rb +120 -70
- data/ext/ae-editor/ae-editor.conf +2 -2
- data/ext/ae-editor/ae-editor.rb +610 -303
- data/ext/ae-file-history/ae-file-history.rb +60 -39
- data/ext/ae-output/ae-output.rb +52 -27
- data/ext/ae-ruby-debug/ae-ruby-debug.conf +3 -1
- data/ext/ae-ruby-debug/ae-ruby-debug.rb +18 -11
- data/ext/ae-search-in-files/ae-search-in-files.conf +2 -2
- data/ext/ae-search-in-files/ae-search-in-files.rb +124 -77
- data/ext/ae-shell/ae-shell.conf +1 -1
- data/ext/ae-shell/ae-shell.rb +18 -81
- data/ext/ae-subprocess-inspector/ae-subprocess-inspector.rb +78 -81
- data/ext/ae-term/ae-term.rb +9 -7
- data/lib/a-commons.rb +125 -17
- data/lib/a-contracts.rb +6 -2
- data/lib/a-core.rb +441 -405
- data/lib/a-tkcommons.rb +1237 -45
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ArrowButton.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/BWidget.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Button.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ButtonBox.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ComboBox.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Dialog.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/DragSite.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/DropSite.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/DynamicHelp.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Entry.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Label.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/LabelEntry.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/LabelFrame.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ListBox.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/MainFrame.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/MessageDlg.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/NoteBook.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PagesManager.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PanedWindow.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PanelFrame.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PasswdDlg.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ProgressBar.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ProgressDlg.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ScrollView.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ScrollableFrame.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ScrolledWindow.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/SelectColor.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/SelectFont.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Separator.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/SpinBox.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/StatusBar.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/TitleFrame.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Tree.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Widget.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/contents.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/index.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/navtree.html +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/options.htm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/CHANGES.txt +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/ChangeLog +65 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/LICENSE.txt +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/README.txt +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/arrow.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/bitmap.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/button.tcl +0 -2
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/buttonbox.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/color.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/combobox.tcl +40 -16
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/basic.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/bwidget.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/demo.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/dnd.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/manager.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/select.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/tmpldlg.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/tree.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/x1.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dialog.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dragsite.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dropsite.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dynhelp.tcl +3 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/entry.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/font.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/bold.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/copy.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/cut.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/dragfile.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/dragicon.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/error.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/file.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/folder.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/hourglass.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/info.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/italic.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/minus.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/new.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/opcopy.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/open.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/openfold.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/oplink.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/opmove.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/overstrike.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/palette.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/passwd.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/paste.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/plus.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/print.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/question.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/redo.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/save.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/target.xbm +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/underline.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/undo.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/warning.gif +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/init.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/label.tcl +0 -2
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/labelentry.tcl +0 -3
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/labelframe.tcl +0 -2
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/da.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/de.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/en.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/es.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/fr.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/hu.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/nl.rc +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/no.rc +59 -58
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/pl.rc +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/listbox.tcl +17 -4
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/mainframe.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/messagedlg.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/notebook.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/pagesmgr.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/panedw.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/panelframe.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/passwddlg.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/pkgIndex.tcl +2 -2
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/progressbar.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/progressdlg.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/scrollframe.tcl +6 -6
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/scrollview.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/scrollw.tcl +1 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/separator.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/spinbox.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/statusbar.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/tests/entry.test +2 -2
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/titleframe.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/tree.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/utils.tcl +0 -0
- data/tcl/bwidget-1.9.8/widget-old.tcl +1651 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/widget.tcl +64 -36
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/wizard.tcl +0 -0
- data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/xpm2image.tcl +0 -0
- metadata +196 -195
@@ -1,58 +1,59 @@
|
|
1
|
-
! ------------------------------------------------------------------------------
|
2
|
-
! no.rc
|
3
|
-
! This file is part of Unifix BWidget Toolkit
|
4
|
-
! Definition of norwegian resources
|
5
|
-
! ------------------------------------------------------------------------------
|
6
|
-
|
7
|
-
|
8
|
-
! --- symbolic names of buttons ------------------------------------------------
|
9
|
-
|
10
|
-
*abortName: &Om
|
11
|
-
*retryName: &Pr�v igjen
|
12
|
-
*ignoreName: &Ignore
|
13
|
-
*okName: &OK
|
14
|
-
*cancelName: &Avbryt
|
15
|
-
*yesName: &Ja
|
16
|
-
*noName: &Nei
|
17
|
-
|
18
|
-
|
19
|
-
! --- symbolic names of label of SelectFont dialog ----------------------------
|
20
|
-
|
21
|
-
*boldName: Halvfet
|
22
|
-
*italicName: Kursiv
|
23
|
-
*underlineName: Understreking
|
24
|
-
*overstrikeName: Overstryke
|
25
|
-
*fontName: &Skrift
|
26
|
-
*sizeName: &St�rrelse
|
27
|
-
*styleName: St&il
|
28
|
-
*colorPickerName: &Color...
|
29
|
-
|
30
|
-
|
31
|
-
! --- symbolic names of label of PasswdDlg dialog -----------------------------
|
32
|
-
|
33
|
-
*loginName: &Logg inn
|
34
|
-
*passwordName: &Passord
|
35
|
-
|
36
|
-
|
37
|
-
! --- resource for SelectFont dialog ------------------------------------------
|
38
|
-
|
39
|
-
*SelectFont.title: Skriftvalg
|
40
|
-
*SelectFont.sampletext: Pr�ve tekst
|
41
|
-
|
42
|
-
|
43
|
-
! --- resource for MessageDlg dialog ------------------------------------------
|
44
|
-
|
45
|
-
*MessageDlg.noneTitle: Melding
|
46
|
-
*MessageDlg.infoTitle: Informasjon
|
47
|
-
*MessageDlg.questionTitle: Sp�rsm�l
|
48
|
-
*MessageDlg.warningTitle: Advarsel
|
49
|
-
*MessageDlg.errorTitle: Feil
|
50
|
-
|
51
|
-
! --- resource for PasswdDlg dialog -------------------------------------------
|
52
|
-
|
53
|
-
*PasswdDlg.title: Skriv inn logginn og passord
|
54
|
-
|
55
|
-
! --- symbolic names of label of SelectColor dialog ----------------------------
|
56
|
-
|
57
|
-
*baseColorsName: Base colors
|
58
|
-
*userColorsName: User colors
|
1
|
+
! ------------------------------------------------------------------------------
|
2
|
+
! no.rc
|
3
|
+
! This file is part of Unifix BWidget Toolkit
|
4
|
+
! Definition of norwegian resources
|
5
|
+
! ------------------------------------------------------------------------------
|
6
|
+
|
7
|
+
|
8
|
+
! --- symbolic names of buttons ------------------------------------------------
|
9
|
+
|
10
|
+
*abortName: &Om
|
11
|
+
*retryName: &Pr�v igjen
|
12
|
+
*ignoreName: &Ignore
|
13
|
+
*okName: &OK
|
14
|
+
*cancelName: &Avbryt
|
15
|
+
*yesName: &Ja
|
16
|
+
*noName: &Nei
|
17
|
+
|
18
|
+
|
19
|
+
! --- symbolic names of label of SelectFont dialog ----------------------------
|
20
|
+
|
21
|
+
*boldName: Halvfet
|
22
|
+
*italicName: Kursiv
|
23
|
+
*underlineName: Understreking
|
24
|
+
*overstrikeName: Overstryke
|
25
|
+
*fontName: &Skrift
|
26
|
+
*sizeName: &St�rrelse
|
27
|
+
*styleName: St&il
|
28
|
+
*colorPickerName: &Color...
|
29
|
+
|
30
|
+
|
31
|
+
! --- symbolic names of label of PasswdDlg dialog -----------------------------
|
32
|
+
|
33
|
+
*loginName: &Logg inn
|
34
|
+
*passwordName: &Passord
|
35
|
+
|
36
|
+
|
37
|
+
! --- resource for SelectFont dialog ------------------------------------------
|
38
|
+
|
39
|
+
*SelectFont.title: Skriftvalg
|
40
|
+
*SelectFont.sampletext: Pr�ve tekst
|
41
|
+
|
42
|
+
|
43
|
+
! --- resource for MessageDlg dialog ------------------------------------------
|
44
|
+
|
45
|
+
*MessageDlg.noneTitle: Melding
|
46
|
+
*MessageDlg.infoTitle: Informasjon
|
47
|
+
*MessageDlg.questionTitle: Sp�rsm�l
|
48
|
+
*MessageDlg.warningTitle: Advarsel
|
49
|
+
*MessageDlg.errorTitle: Feil
|
50
|
+
|
51
|
+
! --- resource for PasswdDlg dialog -------------------------------------------
|
52
|
+
|
53
|
+
*PasswdDlg.title: Skriv inn logginn og passord
|
54
|
+
|
55
|
+
! --- symbolic names of label of SelectColor dialog ----------------------------
|
56
|
+
|
57
|
+
*baseColorsName: Base colors
|
58
|
+
*userColorsName: User colors
|
59
|
+
|
File without changes
|
@@ -240,7 +240,8 @@ proc ListBox::configure { path args } {
|
|
240
240
|
_configureSelectmode $path $selectmode $selectmodePrevious
|
241
241
|
}
|
242
242
|
|
243
|
-
set
|
243
|
+
set ch0 [expr {[Widget::hasChanged $path -deltay dy]}]
|
244
|
+
set ch1 [expr {$ch0 |
|
244
245
|
[Widget::hasChanged $path -padx val] |
|
245
246
|
[Widget::hasChanged $path -multicolumn val]}]
|
246
247
|
|
@@ -248,9 +249,11 @@ proc ListBox::configure { path args } {
|
|
248
249
|
[Widget::hasChanged $path -selectforeground val]}]
|
249
250
|
|
250
251
|
set redraw 0
|
251
|
-
if { [Widget::hasChanged $path -height h] } {
|
252
|
+
if { [Widget::hasChanged $path -height h] || $ch0 } {
|
252
253
|
$path.c configure -height [expr {$h*$dy}]
|
253
|
-
|
254
|
+
if {!$ch0} {
|
255
|
+
set redraw 1
|
256
|
+
}
|
254
257
|
}
|
255
258
|
if { [Widget::hasChanged $path -width w] } {
|
256
259
|
$path.c configure -width [expr {$w*8}]
|
@@ -1046,7 +1049,8 @@ proc ListBox::_redraw_items { path } {
|
|
1046
1049
|
set dy [Widget::getoption $path -deltay]
|
1047
1050
|
set padx [Widget::getoption $path -padx]
|
1048
1051
|
set y0 [expr {$dy/2}]
|
1049
|
-
|
1052
|
+
# Changed from 4 to 2 to make highlight work and look nice for listbox with image as well
|
1053
|
+
set x0 2
|
1050
1054
|
set x1 [expr {$x0+$padx}]
|
1051
1055
|
set nitem 0
|
1052
1056
|
set width 0
|
@@ -1127,6 +1131,15 @@ proc ListBox::_redraw_selection { path } {
|
|
1127
1131
|
foreach item $data(selitems) {
|
1128
1132
|
set bbox [$path.c bbox "n:$item"]
|
1129
1133
|
if { [llength $bbox] } {
|
1134
|
+
set imgbox [$path.c bbox i:$item]
|
1135
|
+
lassign $bbox x0 y0 x1 y1;
|
1136
|
+
if {[string compare "" $imgbox]} {
|
1137
|
+
# image may exist and may be heigher than text!
|
1138
|
+
lassign $imgbox ix0 iy0 ix1 iy1;
|
1139
|
+
set bbox [list $x0 [expr {min($iy0,$y0)}] $x1 [expr {max($iy1,$y1)}]];
|
1140
|
+
} else {
|
1141
|
+
set bbox [list $x0 [lindex $bbox 1] $x1 [lindex $bbox 3]]
|
1142
|
+
}
|
1130
1143
|
if { $selfill && !$multi } {
|
1131
1144
|
# With -selectfill, make box occupy full width of widget
|
1132
1145
|
set bbox [list 0 [lindex $bbox 1] $width [lindex $bbox 3]]
|
File without changes
|
File without changes
|
File without changes
|
File without changes
|
File without changes
|
File without changes
|
File without changes
|
@@ -1,7 +1,7 @@
|
|
1
1
|
if {[catch {package require Tcl}]} return
|
2
|
-
package ifneeded BWidget 1.9.
|
2
|
+
package ifneeded BWidget 1.9.8 "\
|
3
3
|
package require Tk 8.1.1;\
|
4
|
-
[list tclPkgSetup $dir BWidget 1.9.
|
4
|
+
[list tclPkgSetup $dir BWidget 1.9.8 {
|
5
5
|
{arrow.tcl source {ArrowButton ArrowButton::create ArrowButton::use}}
|
6
6
|
{labelframe.tcl source {LabelFrame LabelFrame::create LabelFrame::use}}
|
7
7
|
{labelentry.tcl source {LabelEntry LabelEntry::create LabelEntry::use}}
|
File without changes
|
File without changes
|
@@ -116,20 +116,20 @@ proc ScrollableFrame::configure { path args } {
|
|
116
116
|
set modcw [Widget::hasChanged $path -constrainedwidth cw]
|
117
117
|
set modw [Widget::hasChanged $path -areawidth w]
|
118
118
|
if { $modcw || (!$cw && $modw) } {
|
119
|
-
if { $cw } {
|
120
|
-
set w [winfo width $path]
|
121
|
-
}
|
122
119
|
set upd 1
|
123
120
|
}
|
121
|
+
if { $cw } {
|
122
|
+
set w [winfo width $path]
|
123
|
+
}
|
124
124
|
|
125
125
|
set modch [Widget::hasChanged $path -constrainedheight ch]
|
126
126
|
set modh [Widget::hasChanged $path -areaheight h]
|
127
127
|
if { $modch || (!$ch && $modh) } {
|
128
|
-
if { $ch } {
|
129
|
-
set h [winfo height $path]
|
130
|
-
}
|
131
128
|
set upd 1
|
132
129
|
}
|
130
|
+
if { $ch } {
|
131
|
+
set h [winfo height $path]
|
132
|
+
}
|
133
133
|
|
134
134
|
if { $upd } {
|
135
135
|
$path:cmd itemconfigure win -width $w -height $h
|
File without changes
|
@@ -138,6 +138,7 @@ proc ScrolledWindow::setwidget { path widget } {
|
|
138
138
|
}
|
139
139
|
set data(widget) $widget
|
140
140
|
grid $widget -in $path -row 1 -column 1 -sticky news
|
141
|
+
raise $widget;
|
141
142
|
|
142
143
|
$path.hscroll configure -command [list $widget xview]
|
143
144
|
$path.vscroll configure -command [list $widget yview]
|
File without changes
|
File without changes
|
File without changes
|
@@ -23,7 +23,7 @@ foreach test {
|
|
23
23
|
{-command foo foo {} {}}
|
24
24
|
{-disabledforeground blue blue non-existent \
|
25
25
|
{unknown color name "non-existent"}}
|
26
|
-
{-editable false
|
26
|
+
{-editable false 0 shazbot {expected boolean value but got "shazbot"}}
|
27
27
|
{-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}}
|
28
28
|
{-fg #110022 #110022 bogus {unknown color name "bogus"}}
|
29
29
|
{-font {Helvetica 12 italic} {Helvetica 12 italic} {} \
|
@@ -65,7 +65,7 @@ destroy .e
|
|
65
65
|
|
66
66
|
test Entry-2.1 {Entry} {
|
67
67
|
list [catch {Entry} msg] $msg
|
68
|
-
} {1 {
|
68
|
+
} {1 {wrong # args: should be "Entry path ..."}}
|
69
69
|
test Entry-2.2 {Entry} {
|
70
70
|
list [catch {Entry gorp} msg] $msg
|
71
71
|
} {1 {bad window path name "gorp"}}
|
File without changes
|
File without changes
|
File without changes
|
@@ -0,0 +1,1651 @@
|
|
1
|
+
# ----------------------------------------------------------------------------
|
2
|
+
# widget.tcl
|
3
|
+
# This file is part of Unifix BWidget Toolkit
|
4
|
+
# $Id: widget.tcl,v 1.35.2.1 2011/11/14 14:33:29 oehhar Exp $
|
5
|
+
# ----------------------------------------------------------------------------
|
6
|
+
# Index of commands:
|
7
|
+
# - Widget::tkinclude
|
8
|
+
# - Widget::bwinclude
|
9
|
+
# - Widget::declare
|
10
|
+
# - Widget::addmap
|
11
|
+
# - Widget::init
|
12
|
+
# - Widget::destroy
|
13
|
+
# - Widget::setoption
|
14
|
+
# - Widget::configure
|
15
|
+
# - Widget::cget
|
16
|
+
# - Widget::subcget
|
17
|
+
# - Widget::hasChanged
|
18
|
+
# - Widget::options
|
19
|
+
# - Widget::_get_tkwidget_options
|
20
|
+
# - Widget::_test_tkresource
|
21
|
+
# - Widget::_test_bwresource
|
22
|
+
# - Widget::_test_synonym
|
23
|
+
# - Widget::_test_string
|
24
|
+
# - Widget::_test_flag
|
25
|
+
# - Widget::_test_enum
|
26
|
+
# - Widget::_test_int
|
27
|
+
# - Widget::_test_boolean
|
28
|
+
# ----------------------------------------------------------------------------
|
29
|
+
# Each megawidget gets a namespace of the same name inside the Widget namespace
|
30
|
+
# Each of these has an array opt, which contains information about the
|
31
|
+
# megawidget options. It maps megawidget options to a list with this format:
|
32
|
+
# {optionType defaultValue isReadonly {additionalOptionalInfo}}
|
33
|
+
# Option types and their additional optional info are:
|
34
|
+
# TkResource {genericTkWidget genericTkWidgetOptionName}
|
35
|
+
# BwResource {nothing}
|
36
|
+
# Enum {list of enumeration values}
|
37
|
+
# Int {Boundary information}
|
38
|
+
# Boolean {nothing}
|
39
|
+
# String {nothing}
|
40
|
+
# Flag {string of valid flag characters}
|
41
|
+
# Synonym {nothing}
|
42
|
+
# Color {nothing}
|
43
|
+
#
|
44
|
+
# Next, each namespace has an array map, which maps class options to their
|
45
|
+
# component widget options:
|
46
|
+
# map(-foreground) => {.e -foreground .f -foreground}
|
47
|
+
#
|
48
|
+
# Each has an array ${path}:opt, which contains the value of each megawidget
|
49
|
+
# option for a particular instance $path of the megawidget, and an array
|
50
|
+
# ${path}:mod, which stores the "changed" status of configuration options.
|
51
|
+
|
52
|
+
# Steps for creating a bwidget megawidget:
|
53
|
+
# 1. parse args to extract subwidget spec
|
54
|
+
# 2. Create frame with appropriate class and command line options
|
55
|
+
# 3. Get initialization options from optionDB, using frame
|
56
|
+
# 4. create subwidgets
|
57
|
+
|
58
|
+
# Uses newer string operations
|
59
|
+
package require Tcl 8.1.1
|
60
|
+
|
61
|
+
namespace eval Widget {
|
62
|
+
variable _optiontype
|
63
|
+
variable _class
|
64
|
+
variable _tk_widget
|
65
|
+
|
66
|
+
# This controls whether we try to use themed widgets from Tile
|
67
|
+
variable _theme 0
|
68
|
+
|
69
|
+
variable _aqua [expr {($::tcl_version >= 8.4) &&
|
70
|
+
[string equal [tk windowingsystem] "aqua"]}]
|
71
|
+
|
72
|
+
array set _optiontype {
|
73
|
+
TkResource Widget::_test_tkresource
|
74
|
+
BwResource Widget::_test_bwresource
|
75
|
+
Enum Widget::_test_enum
|
76
|
+
Int Widget::_test_int
|
77
|
+
Boolean Widget::_test_boolean
|
78
|
+
String Widget::_test_string
|
79
|
+
Flag Widget::_test_flag
|
80
|
+
Synonym Widget::_test_synonym
|
81
|
+
Color Widget::_test_color
|
82
|
+
Padding Widget::_test_padding
|
83
|
+
}
|
84
|
+
|
85
|
+
proc use {} {}
|
86
|
+
}
|
87
|
+
|
88
|
+
|
89
|
+
# ----------------------------------------------------------------------------
|
90
|
+
# Command Widget::tkinclude
|
91
|
+
# Includes tk widget resources to BWidget widget.
|
92
|
+
# class class name of the BWidget
|
93
|
+
# tkwidget tk widget to include
|
94
|
+
# subpath subpath to configure
|
95
|
+
# args additionnal args for included options
|
96
|
+
# ----------------------------------------------------------------------------
|
97
|
+
proc Widget::tkinclude { class tkwidget subpath args } {
|
98
|
+
foreach {cmd lopt} $args {
|
99
|
+
# cmd can be
|
100
|
+
# include options to include lopt = {opt ...}
|
101
|
+
# remove options to remove lopt = {opt ...}
|
102
|
+
# rename options to rename lopt = {opt newopt ...}
|
103
|
+
# prefix options to prefix lopt = {pref opt opt ..}
|
104
|
+
# initialize set default value for options lopt = {opt value ...}
|
105
|
+
# readonly set readonly flag for options lopt = {opt flag ...}
|
106
|
+
switch -- $cmd {
|
107
|
+
remove {
|
108
|
+
foreach option $lopt {
|
109
|
+
set remove($option) 1
|
110
|
+
}
|
111
|
+
}
|
112
|
+
include {
|
113
|
+
foreach option $lopt {
|
114
|
+
set include($option) 1
|
115
|
+
}
|
116
|
+
}
|
117
|
+
prefix {
|
118
|
+
set prefix [lindex $lopt 0]
|
119
|
+
foreach option [lrange $lopt 1 end] {
|
120
|
+
set rename($option) "-$prefix[string range $option 1 end]"
|
121
|
+
}
|
122
|
+
}
|
123
|
+
rename -
|
124
|
+
readonly -
|
125
|
+
initialize {
|
126
|
+
array set $cmd $lopt
|
127
|
+
}
|
128
|
+
default {
|
129
|
+
return -code error "invalid argument \"$cmd\""
|
130
|
+
}
|
131
|
+
}
|
132
|
+
}
|
133
|
+
|
134
|
+
namespace eval $class {}
|
135
|
+
upvar 0 ${class}::opt classopt
|
136
|
+
upvar 0 ${class}::map classmap
|
137
|
+
upvar 0 ${class}::map$subpath submap
|
138
|
+
upvar 0 ${class}::optionExports exports
|
139
|
+
|
140
|
+
# create resources informations from tk widget resources
|
141
|
+
foreach optdesc [_get_tkwidget_options $tkwidget] {
|
142
|
+
set option [lindex $optdesc 0]
|
143
|
+
if { (![info exists include] || [info exists include($option)]) &&
|
144
|
+
![info exists remove($option)] } {
|
145
|
+
if { [llength $optdesc] == 3 } {
|
146
|
+
# option is a synonym
|
147
|
+
set syn [lindex $optdesc 1]
|
148
|
+
if { ![info exists remove($syn)] } {
|
149
|
+
# original option is not removed
|
150
|
+
if { [info exists rename($syn)] } {
|
151
|
+
set classopt($option) [list Synonym $rename($syn)]
|
152
|
+
} else {
|
153
|
+
set classopt($option) [list Synonym $syn]
|
154
|
+
}
|
155
|
+
}
|
156
|
+
} else {
|
157
|
+
if { [info exists rename($option)] } {
|
158
|
+
set realopt $option
|
159
|
+
set option $rename($option)
|
160
|
+
} else {
|
161
|
+
set realopt $option
|
162
|
+
}
|
163
|
+
if { [info exists initialize($option)] } {
|
164
|
+
set value $initialize($option)
|
165
|
+
} else {
|
166
|
+
set value [lindex $optdesc 1]
|
167
|
+
}
|
168
|
+
if { [info exists readonly($option)] } {
|
169
|
+
set ro $readonly($option)
|
170
|
+
} else {
|
171
|
+
set ro 0
|
172
|
+
}
|
173
|
+
set classopt($option) \
|
174
|
+
[list TkResource $value $ro [list $tkwidget $realopt]]
|
175
|
+
|
176
|
+
# Add an option database entry for this option
|
177
|
+
set optionDbName ".[lindex [_configure_option $realopt ""] 0]"
|
178
|
+
if { ![string equal $subpath ":cmd"] } {
|
179
|
+
set optionDbName "$subpath$optionDbName"
|
180
|
+
}
|
181
|
+
option add *${class}$optionDbName $value widgetDefault
|
182
|
+
lappend exports($option) "$optionDbName"
|
183
|
+
|
184
|
+
# Store the forward and backward mappings for this
|
185
|
+
# option <-> realoption pair
|
186
|
+
lappend classmap($option) $subpath "" $realopt
|
187
|
+
set submap($realopt) $option
|
188
|
+
}
|
189
|
+
}
|
190
|
+
}
|
191
|
+
}
|
192
|
+
|
193
|
+
|
194
|
+
# ----------------------------------------------------------------------------
|
195
|
+
# Command Widget::bwinclude
|
196
|
+
# Includes BWidget resources to BWidget widget.
|
197
|
+
# class class name of the BWidget
|
198
|
+
# subclass BWidget class to include
|
199
|
+
# subpath subpath to configure
|
200
|
+
# args additionnal args for included options
|
201
|
+
# ----------------------------------------------------------------------------
|
202
|
+
proc Widget::bwinclude { class subclass subpath args } {
|
203
|
+
foreach {cmd lopt} $args {
|
204
|
+
# cmd can be
|
205
|
+
# include options to include lopt = {opt ...}
|
206
|
+
# remove options to remove lopt = {opt ...}
|
207
|
+
# rename options to rename lopt = {opt newopt ...}
|
208
|
+
# prefix options to prefix lopt = {prefix opt opt ...}
|
209
|
+
# initialize set default value for options lopt = {opt value ...}
|
210
|
+
# readonly set readonly flag for options lopt = {opt flag ...}
|
211
|
+
switch -- $cmd {
|
212
|
+
remove {
|
213
|
+
foreach option $lopt {
|
214
|
+
set remove($option) 1
|
215
|
+
}
|
216
|
+
}
|
217
|
+
include {
|
218
|
+
foreach option $lopt {
|
219
|
+
set include($option) 1
|
220
|
+
}
|
221
|
+
}
|
222
|
+
prefix {
|
223
|
+
set prefix [lindex $lopt 0]
|
224
|
+
foreach option [lrange $lopt 1 end] {
|
225
|
+
set rename($option) "-$prefix[string range $option 1 end]"
|
226
|
+
}
|
227
|
+
}
|
228
|
+
rename -
|
229
|
+
readonly -
|
230
|
+
initialize {
|
231
|
+
array set $cmd $lopt
|
232
|
+
}
|
233
|
+
default {
|
234
|
+
return -code error "invalid argument \"$cmd\""
|
235
|
+
}
|
236
|
+
}
|
237
|
+
}
|
238
|
+
|
239
|
+
namespace eval $class {}
|
240
|
+
upvar 0 ${class}::opt classopt
|
241
|
+
upvar 0 ${class}::map classmap
|
242
|
+
upvar 0 ${class}::map$subpath submap
|
243
|
+
upvar 0 ${class}::optionExports exports
|
244
|
+
upvar 0 ${subclass}::opt subclassopt
|
245
|
+
upvar 0 ${subclass}::optionExports subexports
|
246
|
+
|
247
|
+
# create resources informations from BWidget resources
|
248
|
+
foreach {option optdesc} [array get subclassopt] {
|
249
|
+
set subOption $option
|
250
|
+
if { (![info exists include] || [info exists include($option)]) &&
|
251
|
+
![info exists remove($option)] } {
|
252
|
+
set type [lindex $optdesc 0]
|
253
|
+
if { [string equal $type "Synonym"] } {
|
254
|
+
# option is a synonym
|
255
|
+
set syn [lindex $optdesc 1]
|
256
|
+
if { ![info exists remove($syn)] } {
|
257
|
+
if { [info exists rename($syn)] } {
|
258
|
+
set classopt($option) [list Synonym $rename($syn)]
|
259
|
+
} else {
|
260
|
+
set classopt($option) [list Synonym $syn]
|
261
|
+
}
|
262
|
+
}
|
263
|
+
} else {
|
264
|
+
if { [info exists rename($option)] } {
|
265
|
+
set realopt $option
|
266
|
+
set option $rename($option)
|
267
|
+
} else {
|
268
|
+
set realopt $option
|
269
|
+
}
|
270
|
+
if { [info exists initialize($option)] } {
|
271
|
+
set value $initialize($option)
|
272
|
+
} else {
|
273
|
+
set value [lindex $optdesc 1]
|
274
|
+
}
|
275
|
+
if { [info exists readonly($option)] } {
|
276
|
+
set ro $readonly($option)
|
277
|
+
} else {
|
278
|
+
set ro [lindex $optdesc 2]
|
279
|
+
}
|
280
|
+
set classopt($option) \
|
281
|
+
[list $type $value $ro [lindex $optdesc 3]]
|
282
|
+
|
283
|
+
# Add an option database entry for this option
|
284
|
+
foreach optionDbName $subexports($subOption) {
|
285
|
+
if { ![string equal $subpath ":cmd"] } {
|
286
|
+
set optionDbName "$subpath$optionDbName"
|
287
|
+
}
|
288
|
+
# Only add the option db entry if we are overriding the
|
289
|
+
# normal widget default
|
290
|
+
if { [info exists initialize($option)] } {
|
291
|
+
option add *${class}$optionDbName $value \
|
292
|
+
widgetDefault
|
293
|
+
}
|
294
|
+
lappend exports($option) "$optionDbName"
|
295
|
+
}
|
296
|
+
|
297
|
+
# Store the forward and backward mappings for this
|
298
|
+
# option <-> realoption pair
|
299
|
+
lappend classmap($option) $subpath $subclass $realopt
|
300
|
+
set submap($realopt) $option
|
301
|
+
}
|
302
|
+
}
|
303
|
+
}
|
304
|
+
}
|
305
|
+
|
306
|
+
|
307
|
+
# ----------------------------------------------------------------------------
|
308
|
+
# Command Widget::declare
|
309
|
+
# Declares new options to BWidget class.
|
310
|
+
# ----------------------------------------------------------------------------
|
311
|
+
proc Widget::declare { class optlist } {
|
312
|
+
variable _optiontype
|
313
|
+
|
314
|
+
namespace eval $class {}
|
315
|
+
upvar 0 ${class}::opt classopt
|
316
|
+
upvar 0 ${class}::optionExports exports
|
317
|
+
upvar 0 ${class}::optionClass optionClass
|
318
|
+
|
319
|
+
foreach optdesc $optlist {
|
320
|
+
set option [lindex $optdesc 0]
|
321
|
+
set optdesc [lrange $optdesc 1 end]
|
322
|
+
set type [lindex $optdesc 0]
|
323
|
+
|
324
|
+
if { ![info exists _optiontype($type)] } {
|
325
|
+
# invalid resource type
|
326
|
+
return -code error "invalid option type \"$type\""
|
327
|
+
}
|
328
|
+
|
329
|
+
if { [string equal $type "Synonym"] } {
|
330
|
+
# test existence of synonym option
|
331
|
+
set syn [lindex $optdesc 1]
|
332
|
+
if { ![info exists classopt($syn)] } {
|
333
|
+
return -code error "unknow option \"$syn\" for Synonym \"$option\""
|
334
|
+
}
|
335
|
+
set classopt($option) [list Synonym $syn]
|
336
|
+
continue
|
337
|
+
}
|
338
|
+
|
339
|
+
# all other resource may have default value, readonly flag and
|
340
|
+
# optional arg depending on type
|
341
|
+
set value [lindex $optdesc 1]
|
342
|
+
set ro [lindex $optdesc 2]
|
343
|
+
set arg [lindex $optdesc 3]
|
344
|
+
|
345
|
+
if { [string equal $type "BwResource"] } {
|
346
|
+
# We don't keep BwResource. We simplify to type of sub BWidget
|
347
|
+
set subclass [lindex $arg 0]
|
348
|
+
set realopt [lindex $arg 1]
|
349
|
+
if { ![string length $realopt] } {
|
350
|
+
set realopt $option
|
351
|
+
}
|
352
|
+
|
353
|
+
upvar 0 ${subclass}::opt subclassopt
|
354
|
+
if { ![info exists subclassopt($realopt)] } {
|
355
|
+
return -code error "unknow option \"$realopt\""
|
356
|
+
}
|
357
|
+
set suboptdesc $subclassopt($realopt)
|
358
|
+
if { $value == "" } {
|
359
|
+
# We initialize default value
|
360
|
+
set value [lindex $suboptdesc 1]
|
361
|
+
}
|
362
|
+
set type [lindex $suboptdesc 0]
|
363
|
+
set ro [lindex $suboptdesc 2]
|
364
|
+
set arg [lindex $suboptdesc 3]
|
365
|
+
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
366
|
+
option add *${class}${optionDbName} $value widgetDefault
|
367
|
+
set exports($option) $optionDbName
|
368
|
+
set classopt($option) [list $type $value $ro $arg]
|
369
|
+
continue
|
370
|
+
}
|
371
|
+
|
372
|
+
# retreive default value for TkResource
|
373
|
+
if { [string equal $type "TkResource"] } {
|
374
|
+
set tkwidget [lindex $arg 0]
|
375
|
+
set realopt [lindex $arg 1]
|
376
|
+
if { ![string length $realopt] } {
|
377
|
+
set realopt $option
|
378
|
+
}
|
379
|
+
set tkoptions [_get_tkwidget_options $tkwidget]
|
380
|
+
set ind [lsearch $tkoptions [list $realopt *]]
|
381
|
+
set optdesc [lindex $tkoptions $ind];
|
382
|
+
set tkoptions [_get_tkwidget_options $tkwidget]
|
383
|
+
if { ![string length $value] } {
|
384
|
+
# We initialize default value
|
385
|
+
set value [lindex $optdesc end]
|
386
|
+
}
|
387
|
+
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
388
|
+
option add *${class}${optionDbName} $value widgetDefault
|
389
|
+
set exports($option) $optionDbName
|
390
|
+
set classopt($option) [list TkResource $value $ro \
|
391
|
+
[list $tkwidget $realopt]]
|
392
|
+
set optionClass($option) [lindex $optdesc 1]
|
393
|
+
continue
|
394
|
+
}
|
395
|
+
|
396
|
+
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
397
|
+
option add *${class}${optionDbName} $value widgetDefault
|
398
|
+
set exports($option) $optionDbName
|
399
|
+
# for any other resource type, we keep original optdesc
|
400
|
+
set classopt($option) [list $type $value $ro $arg]
|
401
|
+
}
|
402
|
+
}
|
403
|
+
|
404
|
+
|
405
|
+
proc Widget::define { class filename args } {
|
406
|
+
variable ::BWidget::use
|
407
|
+
set use($class) $args
|
408
|
+
set use($class,file) $filename
|
409
|
+
lappend use(classes) $class
|
410
|
+
|
411
|
+
if {[set x [lsearch -exact $args "-classonly"]] > -1} {
|
412
|
+
set args [lreplace $args $x $x]
|
413
|
+
} else {
|
414
|
+
interp alias {} ::${class} {} ${class}::create
|
415
|
+
proc ::${class}::use {} {}
|
416
|
+
|
417
|
+
bind $class <Destroy> [list Widget::destroy %W]
|
418
|
+
}
|
419
|
+
|
420
|
+
foreach class $args { ${class}::use }
|
421
|
+
}
|
422
|
+
|
423
|
+
|
424
|
+
proc Widget::create { class path {rename 1} } {
|
425
|
+
if {$rename} { rename $path ::$path:cmd }
|
426
|
+
proc ::$path { cmd args } \
|
427
|
+
[subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}]
|
428
|
+
return $path
|
429
|
+
}
|
430
|
+
|
431
|
+
|
432
|
+
# ----------------------------------------------------------------------------
|
433
|
+
# Command Widget::addmap
|
434
|
+
# ----------------------------------------------------------------------------
|
435
|
+
proc Widget::addmap { class subclass subpath options } {
|
436
|
+
upvar 0 ${class}::opt classopt
|
437
|
+
upvar 0 ${class}::optionExports exports
|
438
|
+
upvar 0 ${class}::map classmap
|
439
|
+
upvar 0 ${class}::map$subpath submap
|
440
|
+
|
441
|
+
foreach {option realopt} $options {
|
442
|
+
if { ![string length $realopt] } {
|
443
|
+
set realopt $option
|
444
|
+
}
|
445
|
+
set val [lindex $classopt($option) 1]
|
446
|
+
set optDb ".[lindex [_configure_option $realopt ""] 0]"
|
447
|
+
if { ![string equal $subpath ":cmd"] } {
|
448
|
+
set optDb "$subpath$optDb"
|
449
|
+
}
|
450
|
+
option add *${class}${optDb} $val widgetDefault
|
451
|
+
lappend exports($option) $optDb
|
452
|
+
# Store the forward and backward mappings for this
|
453
|
+
# option <-> realoption pair
|
454
|
+
lappend classmap($option) $subpath $subclass $realopt
|
455
|
+
set submap($realopt) $option
|
456
|
+
}
|
457
|
+
}
|
458
|
+
|
459
|
+
|
460
|
+
# ----------------------------------------------------------------------------
|
461
|
+
# Command Widget::init
|
462
|
+
# ----------------------------------------------------------------------------
|
463
|
+
proc Widget::init { class path options } {
|
464
|
+
variable _inuse
|
465
|
+
variable _class
|
466
|
+
variable _optiontype
|
467
|
+
|
468
|
+
upvar 0 ${class}::opt classopt
|
469
|
+
upvar 0 ${class}::$path:opt pathopt
|
470
|
+
upvar 0 ${class}::$path:mod pathmod
|
471
|
+
upvar 0 ${class}::map classmap
|
472
|
+
upvar 0 ${class}::$path:init pathinit
|
473
|
+
|
474
|
+
if { [info exists pathopt] } {
|
475
|
+
unset pathopt
|
476
|
+
}
|
477
|
+
if { [info exists pathmod] } {
|
478
|
+
unset pathmod
|
479
|
+
}
|
480
|
+
# We prefer to use the actual widget for option db queries, but if it
|
481
|
+
# doesn't exist yet, do the next best thing: create a widget of the
|
482
|
+
# same class and use that.
|
483
|
+
set fpath $path
|
484
|
+
set rdbclass [string map [list :: ""] $class]
|
485
|
+
if { ![winfo exists $path] } {
|
486
|
+
set fpath ".#BWidget.#Class#$class"
|
487
|
+
# encapsulation frame to not pollute '.' childspace
|
488
|
+
if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
|
489
|
+
if { ![winfo exists $fpath] } {
|
490
|
+
frame $fpath -class $rdbclass
|
491
|
+
}
|
492
|
+
}
|
493
|
+
foreach {option optdesc} [array get classopt] {
|
494
|
+
set pathmod($option) 0
|
495
|
+
if { [info exists classmap($option)] } {
|
496
|
+
continue
|
497
|
+
}
|
498
|
+
set type [lindex $optdesc 0]
|
499
|
+
if { [string equal $type "Synonym"] } {
|
500
|
+
continue
|
501
|
+
}
|
502
|
+
if { [string equal $type "TkResource"] } {
|
503
|
+
set alt [lindex [lindex $optdesc 3] 1]
|
504
|
+
} else {
|
505
|
+
set alt ""
|
506
|
+
}
|
507
|
+
set optdb [lindex [_configure_option $option $alt] 0]
|
508
|
+
set def [option get $fpath $optdb $rdbclass]
|
509
|
+
if { [string length $def] } {
|
510
|
+
set pathopt($option) $def
|
511
|
+
} else {
|
512
|
+
set pathopt($option) [lindex $optdesc 1]
|
513
|
+
}
|
514
|
+
}
|
515
|
+
|
516
|
+
if {![info exists _inuse($class)]} { set _inuse($class) 0 }
|
517
|
+
incr _inuse($class)
|
518
|
+
|
519
|
+
set _class($path) $class
|
520
|
+
foreach {option value} $options {
|
521
|
+
if { ![info exists classopt($option)] } {
|
522
|
+
unset pathopt
|
523
|
+
unset pathmod
|
524
|
+
return -code error "unknown option \"$option\""
|
525
|
+
}
|
526
|
+
set optdesc $classopt($option)
|
527
|
+
set type [lindex $optdesc 0]
|
528
|
+
if { [string equal $type "Synonym"] } {
|
529
|
+
set option [lindex $optdesc 1]
|
530
|
+
set optdesc $classopt($option)
|
531
|
+
set type [lindex $optdesc 0]
|
532
|
+
}
|
533
|
+
# this may fail if a wrong enum element was used
|
534
|
+
if {[catch {
|
535
|
+
$_optiontype($type) $option $value [lindex $optdesc 3]
|
536
|
+
} msg]} {
|
537
|
+
if {[info exists pathopt]} {
|
538
|
+
unset pathopt
|
539
|
+
}
|
540
|
+
unset pathmod
|
541
|
+
return -code error $msg
|
542
|
+
}
|
543
|
+
set pathopt($option) $msg
|
544
|
+
set pathinit($option) $pathopt($option)
|
545
|
+
}
|
546
|
+
}
|
547
|
+
|
548
|
+
# Bastien Chevreux (bach@mwgdna.com)
|
549
|
+
#
|
550
|
+
# copyinit performs basically the same job as init, but it uses a
|
551
|
+
# existing template to initialize its values. So, first a perferct copy
|
552
|
+
# from the template is made just to be altered by any existing options
|
553
|
+
# afterwards.
|
554
|
+
# But this still saves time as the first initialization parsing block is
|
555
|
+
# skipped.
|
556
|
+
# As additional bonus, items that differ in just a few options can be
|
557
|
+
# initialized faster by leaving out the options that are equal.
|
558
|
+
|
559
|
+
# This function is currently used only by ListBox::multipleinsert, but other
|
560
|
+
# calls should follow :)
|
561
|
+
|
562
|
+
# ----------------------------------------------------------------------------
|
563
|
+
# Command Widget::copyinit
|
564
|
+
# ----------------------------------------------------------------------------
|
565
|
+
proc Widget::copyinit { class templatepath path options } {
|
566
|
+
variable _class
|
567
|
+
variable _optiontype
|
568
|
+
upvar 0 ${class}::opt classopt \
|
569
|
+
${class}::$path:opt pathopt \
|
570
|
+
${class}::$path:mod pathmod \
|
571
|
+
${class}::$path:init pathinit \
|
572
|
+
${class}::$templatepath:opt templatepathopt \
|
573
|
+
${class}::$templatepath:mod templatepathmod \
|
574
|
+
${class}::$templatepath:init templatepathinit
|
575
|
+
|
576
|
+
if { [info exists pathopt] } {
|
577
|
+
unset pathopt
|
578
|
+
}
|
579
|
+
if { [info exists pathmod] } {
|
580
|
+
unset pathmod
|
581
|
+
}
|
582
|
+
|
583
|
+
# We use the template widget for option db copying, but it has to exist!
|
584
|
+
array set pathmod [array get templatepathmod]
|
585
|
+
array set pathopt [array get templatepathopt]
|
586
|
+
array set pathinit [array get templatepathinit]
|
587
|
+
|
588
|
+
set _class($path) $class
|
589
|
+
foreach {option value} $options {
|
590
|
+
if { ![info exists classopt($option)] } {
|
591
|
+
unset pathopt
|
592
|
+
unset pathmod
|
593
|
+
return -code error "unknown option \"$option\""
|
594
|
+
}
|
595
|
+
set optdesc $classopt($option)
|
596
|
+
set type [lindex $optdesc 0]
|
597
|
+
if { [string equal $type "Synonym"] } {
|
598
|
+
set option [lindex $optdesc 1]
|
599
|
+
set optdesc $classopt($option)
|
600
|
+
set type [lindex $optdesc 0]
|
601
|
+
}
|
602
|
+
set pathopt($option) [$_optiontype($type) $option $value [lindex $optdesc 3]]
|
603
|
+
set pathinit($option) $pathopt($option)
|
604
|
+
}
|
605
|
+
}
|
606
|
+
|
607
|
+
# Widget::parseArgs --
|
608
|
+
#
|
609
|
+
# Given a widget class and a command-line spec, cannonize and validate
|
610
|
+
# the given options, and return a keyed list consisting of the
|
611
|
+
# component widget and its masked portion of the command-line spec, and
|
612
|
+
# one extra entry consisting of the portion corresponding to the
|
613
|
+
# megawidget itself.
|
614
|
+
#
|
615
|
+
# Arguments:
|
616
|
+
# class widget class to parse for.
|
617
|
+
# options command-line spec
|
618
|
+
#
|
619
|
+
# Results:
|
620
|
+
# result keyed list of portions of the megawidget and that segment of
|
621
|
+
# the command line in which that portion is interested.
|
622
|
+
|
623
|
+
proc Widget::parseArgs {class options} {
|
624
|
+
variable _optiontype
|
625
|
+
upvar 0 ${class}::opt classopt
|
626
|
+
upvar 0 ${class}::map classmap
|
627
|
+
|
628
|
+
foreach {option val} $options {
|
629
|
+
if { ![info exists classopt($option)] } {
|
630
|
+
error "unknown option \"$option\""
|
631
|
+
}
|
632
|
+
set optdesc $classopt($option)
|
633
|
+
set type [lindex $optdesc 0]
|
634
|
+
if { [string equal $type "Synonym"] } {
|
635
|
+
set option [lindex $optdesc 1]
|
636
|
+
set optdesc $classopt($option)
|
637
|
+
set type [lindex $optdesc 0]
|
638
|
+
}
|
639
|
+
if { [string equal $type "TkResource"] } {
|
640
|
+
# Make sure that the widget used for this TkResource exists
|
641
|
+
Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0]
|
642
|
+
}
|
643
|
+
set val [$_optiontype($type) $option $val [lindex $optdesc 3]]
|
644
|
+
|
645
|
+
if { [info exists classmap($option)] } {
|
646
|
+
foreach {subpath subclass realopt} $classmap($option) {
|
647
|
+
lappend maps($subpath) $realopt $val
|
648
|
+
}
|
649
|
+
} else {
|
650
|
+
lappend maps($class) $option $val
|
651
|
+
}
|
652
|
+
}
|
653
|
+
return [array get maps]
|
654
|
+
}
|
655
|
+
|
656
|
+
# Widget::initFromODB --
|
657
|
+
#
|
658
|
+
# Initialize a megawidgets options with information from the option
|
659
|
+
# database and from the command-line arguments given.
|
660
|
+
#
|
661
|
+
# Arguments:
|
662
|
+
# class class of the widget.
|
663
|
+
# path path of the widget -- should already exist.
|
664
|
+
# options command-line arguments.
|
665
|
+
#
|
666
|
+
# Results:
|
667
|
+
# None.
|
668
|
+
|
669
|
+
proc Widget::initFromODB {class path options} {
|
670
|
+
variable _inuse
|
671
|
+
variable _class
|
672
|
+
|
673
|
+
upvar 0 ${class}::$path:opt pathopt
|
674
|
+
upvar 0 ${class}::$path:mod pathmod
|
675
|
+
upvar 0 ${class}::map classmap
|
676
|
+
|
677
|
+
if { [info exists pathopt] } {
|
678
|
+
unset pathopt
|
679
|
+
}
|
680
|
+
if { [info exists pathmod] } {
|
681
|
+
unset pathmod
|
682
|
+
}
|
683
|
+
# We prefer to use the actual widget for option db queries, but if it
|
684
|
+
# doesn't exist yet, do the next best thing: create a widget of the
|
685
|
+
# same class and use that.
|
686
|
+
set fpath [_get_window $class $path]
|
687
|
+
set rdbclass [string map [list :: ""] $class]
|
688
|
+
if { ![winfo exists $path] } {
|
689
|
+
set fpath ".#BWidget.#Class#$class"
|
690
|
+
# encapsulation frame to not pollute '.' childspace
|
691
|
+
if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
|
692
|
+
if { ![winfo exists $fpath] } {
|
693
|
+
frame $fpath -class $rdbclass
|
694
|
+
}
|
695
|
+
}
|
696
|
+
|
697
|
+
foreach {option optdesc} [array get ${class}::opt] {
|
698
|
+
set pathmod($option) 0
|
699
|
+
if { [info exists classmap($option)] } {
|
700
|
+
continue
|
701
|
+
}
|
702
|
+
set type [lindex $optdesc 0]
|
703
|
+
if { [string equal $type "Synonym"] } {
|
704
|
+
continue
|
705
|
+
}
|
706
|
+
if { [string equal $type "TkResource"] } {
|
707
|
+
set alt [lindex [lindex $optdesc 3] 1]
|
708
|
+
} else {
|
709
|
+
set alt ""
|
710
|
+
}
|
711
|
+
set optdb [lindex [_configure_option $option $alt] 0]
|
712
|
+
set def [option get $fpath $optdb $rdbclass]
|
713
|
+
if { [string length $def] } {
|
714
|
+
set pathopt($option) $def
|
715
|
+
} else {
|
716
|
+
set pathopt($option) [lindex $optdesc 1]
|
717
|
+
}
|
718
|
+
}
|
719
|
+
|
720
|
+
if {![info exists _inuse($class)]} { set _inuse($class) 0 }
|
721
|
+
incr _inuse($class)
|
722
|
+
|
723
|
+
set _class($path) $class
|
724
|
+
array set pathopt $options
|
725
|
+
}
|
726
|
+
|
727
|
+
|
728
|
+
|
729
|
+
# ----------------------------------------------------------------------------
|
730
|
+
# Command Widget::destroy
|
731
|
+
# ----------------------------------------------------------------------------
|
732
|
+
proc Widget::destroy { path } {
|
733
|
+
variable _class
|
734
|
+
variable _inuse
|
735
|
+
|
736
|
+
if {![info exists _class($path)]} { return }
|
737
|
+
|
738
|
+
set class $_class($path)
|
739
|
+
upvar 0 ${class}::$path:opt pathopt
|
740
|
+
upvar 0 ${class}::$path:mod pathmod
|
741
|
+
upvar 0 ${class}::$path:init pathinit
|
742
|
+
|
743
|
+
if {[info exists _inuse($class)]} { incr _inuse($class) -1 }
|
744
|
+
|
745
|
+
if {[info exists pathopt]} {
|
746
|
+
unset pathopt
|
747
|
+
}
|
748
|
+
if {[info exists pathmod]} {
|
749
|
+
unset pathmod
|
750
|
+
}
|
751
|
+
if {[info exists pathinit]} {
|
752
|
+
unset pathinit
|
753
|
+
}
|
754
|
+
|
755
|
+
if {![string equal [info commands $path] ""]} { rename $path "" }
|
756
|
+
|
757
|
+
## Unset any variables used in this widget.
|
758
|
+
foreach var [info vars ::${class}::$path:*] { unset $var }
|
759
|
+
|
760
|
+
unset _class($path)
|
761
|
+
}
|
762
|
+
|
763
|
+
|
764
|
+
# ----------------------------------------------------------------------------
|
765
|
+
# Command Widget::configure
|
766
|
+
# ----------------------------------------------------------------------------
|
767
|
+
proc Widget::configure { path options } {
|
768
|
+
set len [llength $options]
|
769
|
+
if { $len <= 1 } {
|
770
|
+
return [_get_configure $path $options]
|
771
|
+
} elseif { $len % 2 == 1 } {
|
772
|
+
return -code error "incorrect number of arguments"
|
773
|
+
}
|
774
|
+
|
775
|
+
variable _class
|
776
|
+
variable _optiontype
|
777
|
+
|
778
|
+
set class $_class($path)
|
779
|
+
upvar 0 ${class}::opt classopt
|
780
|
+
upvar 0 ${class}::map classmap
|
781
|
+
upvar 0 ${class}::$path:opt pathopt
|
782
|
+
upvar 0 ${class}::$path:mod pathmod
|
783
|
+
|
784
|
+
set window [_get_window $class $path]
|
785
|
+
foreach {option value} $options {
|
786
|
+
if { ![info exists classopt($option)] } {
|
787
|
+
return -code error "unknown option \"$option\""
|
788
|
+
}
|
789
|
+
set optdesc $classopt($option)
|
790
|
+
set type [lindex $optdesc 0]
|
791
|
+
if { [string equal $type "Synonym"] } {
|
792
|
+
set option [lindex $optdesc 1]
|
793
|
+
set optdesc $classopt($option)
|
794
|
+
set type [lindex $optdesc 0]
|
795
|
+
}
|
796
|
+
if { ![lindex $optdesc 2] } {
|
797
|
+
set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
|
798
|
+
if { [info exists classmap($option)] } {
|
799
|
+
set window [_get_window $class $window]
|
800
|
+
foreach {subpath subclass realopt} $classmap($option) {
|
801
|
+
# Interpretation of special pointers:
|
802
|
+
# | subclass | subpath | widget | path | class |
|
803
|
+
# +----------+---------+------------------+----------------+-context-+
|
804
|
+
# | :cmd | :cmd | herited widget | window:cmd |window |
|
805
|
+
# | :cmd | * | subwidget | window.subpath | window |
|
806
|
+
# | "" | :cmd | herited widget | window:cmd | window |
|
807
|
+
# | "" | * | own | window | window |
|
808
|
+
# | * | :cmd | own | window | current |
|
809
|
+
# | * | * | subwidget | window.subpath | current |
|
810
|
+
if { [string length $subclass] && ! [string equal $subclass ":cmd"] } {
|
811
|
+
if { [string equal $subpath ":cmd"] } {
|
812
|
+
set subpath ""
|
813
|
+
}
|
814
|
+
set curval [${subclass}::cget $window$subpath $realopt]
|
815
|
+
${subclass}::configure $window$subpath $realopt $newval
|
816
|
+
} else {
|
817
|
+
set curval [$window$subpath cget $realopt]
|
818
|
+
$window$subpath configure $realopt $newval
|
819
|
+
}
|
820
|
+
}
|
821
|
+
} else {
|
822
|
+
set curval $pathopt($option)
|
823
|
+
set pathopt($option) $newval
|
824
|
+
}
|
825
|
+
set pathmod($option) [expr {![string equal $newval $curval]}]
|
826
|
+
}
|
827
|
+
}
|
828
|
+
|
829
|
+
return {}
|
830
|
+
}
|
831
|
+
|
832
|
+
|
833
|
+
# ----------------------------------------------------------------------------
|
834
|
+
# Command Widget::cget
|
835
|
+
# ----------------------------------------------------------------------------
|
836
|
+
proc Widget::cget { path option } {
|
837
|
+
variable _class
|
838
|
+
if { ![info exists _class($path)] } {
|
839
|
+
return -code error "unknown widget $path"
|
840
|
+
}
|
841
|
+
|
842
|
+
set class $_class($path)
|
843
|
+
if { ![info exists ${class}::opt($option)] } {
|
844
|
+
return -code error "unknown option \"$option\""
|
845
|
+
}
|
846
|
+
|
847
|
+
set optdesc [set ${class}::opt($option)]
|
848
|
+
set type [lindex $optdesc 0]
|
849
|
+
if {[string equal $type "Synonym"]} {
|
850
|
+
set option [lindex $optdesc 1]
|
851
|
+
}
|
852
|
+
|
853
|
+
if { [info exists ${class}::map($option)] } {
|
854
|
+
foreach {subpath subclass realopt} [set ${class}::map($option)] {break}
|
855
|
+
set path "[_get_window $class $path]$subpath"
|
856
|
+
return [$path cget $realopt]
|
857
|
+
}
|
858
|
+
upvar 0 ${class}::$path:opt pathopt
|
859
|
+
set pathopt($option)
|
860
|
+
}
|
861
|
+
|
862
|
+
|
863
|
+
# ----------------------------------------------------------------------------
|
864
|
+
# Command Widget::subcget
|
865
|
+
# ----------------------------------------------------------------------------
|
866
|
+
proc Widget::subcget { path subwidget } {
|
867
|
+
variable _class
|
868
|
+
set class $_class($path)
|
869
|
+
upvar 0 ${class}::$path:opt pathopt
|
870
|
+
upvar 0 ${class}::map$subwidget submap
|
871
|
+
upvar 0 ${class}::$path:init pathinit
|
872
|
+
|
873
|
+
set result {}
|
874
|
+
foreach realopt [array names submap] {
|
875
|
+
if { [info exists pathinit($submap($realopt))] } {
|
876
|
+
lappend result $realopt $pathopt($submap($realopt))
|
877
|
+
}
|
878
|
+
}
|
879
|
+
return $result
|
880
|
+
}
|
881
|
+
|
882
|
+
|
883
|
+
# ----------------------------------------------------------------------------
|
884
|
+
# Command Widget::hasChanged
|
885
|
+
# ----------------------------------------------------------------------------
|
886
|
+
proc Widget::hasChanged { path option pvalue } {
|
887
|
+
variable _class
|
888
|
+
upvar $pvalue value
|
889
|
+
set class $_class($path)
|
890
|
+
upvar 0 ${class}::$path:mod pathmod
|
891
|
+
|
892
|
+
set value [Widget::cget $path $option]
|
893
|
+
set result $pathmod($option)
|
894
|
+
set pathmod($option) 0
|
895
|
+
|
896
|
+
return $result
|
897
|
+
}
|
898
|
+
|
899
|
+
proc Widget::hasChangedX { path option args } {
|
900
|
+
variable _class
|
901
|
+
set class $_class($path)
|
902
|
+
upvar 0 ${class}::$path:mod pathmod
|
903
|
+
|
904
|
+
set result $pathmod($option)
|
905
|
+
set pathmod($option) 0
|
906
|
+
foreach option $args {
|
907
|
+
lappend result $pathmod($option)
|
908
|
+
set pathmod($option) 0
|
909
|
+
}
|
910
|
+
|
911
|
+
set result
|
912
|
+
}
|
913
|
+
|
914
|
+
|
915
|
+
# ----------------------------------------------------------------------------
|
916
|
+
# Command Widget::setoption
|
917
|
+
# ----------------------------------------------------------------------------
|
918
|
+
proc Widget::setoption { path option value } {
|
919
|
+
# variable _class
|
920
|
+
|
921
|
+
# set class $_class($path)
|
922
|
+
# upvar 0 ${class}::$path:opt pathopt
|
923
|
+
|
924
|
+
# set pathopt($option) $value
|
925
|
+
Widget::configure $path [list $option $value]
|
926
|
+
}
|
927
|
+
|
928
|
+
|
929
|
+
# ----------------------------------------------------------------------------
|
930
|
+
# Command Widget::getoption
|
931
|
+
# ----------------------------------------------------------------------------
|
932
|
+
proc Widget::getoption { path option } {
|
933
|
+
# set class $::Widget::_class($path)
|
934
|
+
# upvar 0 ${class}::$path:opt pathopt
|
935
|
+
|
936
|
+
# return $pathopt($option)
|
937
|
+
return [Widget::cget $path $option]
|
938
|
+
}
|
939
|
+
|
940
|
+
# Widget::getMegawidgetOption --
|
941
|
+
#
|
942
|
+
# Bypass the superfluous checks in cget and just directly peer at the
|
943
|
+
# widget's data space. This is much more fragile than cget, so it
|
944
|
+
# should only be used with great care, in places where speed is critical.
|
945
|
+
#
|
946
|
+
# Arguments:
|
947
|
+
# path widget to lookup options for.
|
948
|
+
# option option to retrieve.
|
949
|
+
#
|
950
|
+
# Results:
|
951
|
+
# value option value.
|
952
|
+
|
953
|
+
proc Widget::getMegawidgetOption {path option} {
|
954
|
+
variable _class
|
955
|
+
set class $_class($path)
|
956
|
+
upvar 0 ${class}::${path}:opt pathopt
|
957
|
+
set pathopt($option)
|
958
|
+
}
|
959
|
+
|
960
|
+
# Widget::setMegawidgetOption --
|
961
|
+
#
|
962
|
+
# Bypass the superfluous checks in cget and just directly poke at the
|
963
|
+
# widget's data space. This is much more fragile than configure, so it
|
964
|
+
# should only be used with great care, in places where speed is critical.
|
965
|
+
#
|
966
|
+
# Arguments:
|
967
|
+
# path widget to lookup options for.
|
968
|
+
# option option to retrieve.
|
969
|
+
# value option value.
|
970
|
+
#
|
971
|
+
# Results:
|
972
|
+
# value option value.
|
973
|
+
|
974
|
+
proc Widget::setMegawidgetOption {path option value} {
|
975
|
+
variable _class
|
976
|
+
set class $_class($path)
|
977
|
+
upvar 0 ${class}::${path}:opt pathopt
|
978
|
+
set pathopt($option) $value
|
979
|
+
}
|
980
|
+
|
981
|
+
# ----------------------------------------------------------------------------
|
982
|
+
# Command Widget::_get_window
|
983
|
+
# returns the window corresponding to widget path
|
984
|
+
# ----------------------------------------------------------------------------
|
985
|
+
proc Widget::_get_window { class path } {
|
986
|
+
set idx [string last "#" $path]
|
987
|
+
if { $idx != -1 && [string equal [string range $path [expr {$idx+1}] end] $class] } {
|
988
|
+
return [string range $path 0 [expr {$idx-1}]]
|
989
|
+
} else {
|
990
|
+
return $path
|
991
|
+
}
|
992
|
+
}
|
993
|
+
|
994
|
+
|
995
|
+
# ----------------------------------------------------------------------------
|
996
|
+
# Command Widget::_get_configure
|
997
|
+
# returns the configuration list of options
|
998
|
+
# (as tk widget do - [$w configure ?option?])
|
999
|
+
# ----------------------------------------------------------------------------
|
1000
|
+
proc Widget::_get_configure { path options } {
|
1001
|
+
variable _class
|
1002
|
+
|
1003
|
+
set class $_class($path)
|
1004
|
+
upvar 0 ${class}::opt classopt
|
1005
|
+
upvar 0 ${class}::map classmap
|
1006
|
+
upvar 0 ${class}::$path:opt pathopt
|
1007
|
+
upvar 0 ${class}::$path:mod pathmod
|
1008
|
+
|
1009
|
+
set len [llength $options]
|
1010
|
+
if { !$len } {
|
1011
|
+
set result {}
|
1012
|
+
foreach option [lsort [array names classopt]] {
|
1013
|
+
set optdesc $classopt($option)
|
1014
|
+
set type [lindex $optdesc 0]
|
1015
|
+
if { [string equal $type "Synonym"] } {
|
1016
|
+
set syn $option
|
1017
|
+
set option [lindex $optdesc 1]
|
1018
|
+
set optdesc $classopt($option)
|
1019
|
+
set type [lindex $optdesc 0]
|
1020
|
+
} else {
|
1021
|
+
set syn ""
|
1022
|
+
}
|
1023
|
+
if { [string equal $type "TkResource"] } {
|
1024
|
+
set alt [lindex [lindex $optdesc 3] 1]
|
1025
|
+
} else {
|
1026
|
+
set alt ""
|
1027
|
+
}
|
1028
|
+
set res [_configure_option $option $alt]
|
1029
|
+
if { $syn == "" } {
|
1030
|
+
lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
|
1031
|
+
} else {
|
1032
|
+
lappend result [list $syn [lindex $res 0]]
|
1033
|
+
}
|
1034
|
+
}
|
1035
|
+
return $result
|
1036
|
+
} elseif { $len == 1 } {
|
1037
|
+
set option [lindex $options 0]
|
1038
|
+
if { ![info exists classopt($option)] } {
|
1039
|
+
return -code error "unknown option \"$option\""
|
1040
|
+
}
|
1041
|
+
set optdesc $classopt($option)
|
1042
|
+
set type [lindex $optdesc 0]
|
1043
|
+
if { [string equal $type "Synonym"] } {
|
1044
|
+
set option [lindex $optdesc 1]
|
1045
|
+
set optdesc $classopt($option)
|
1046
|
+
set type [lindex $optdesc 0]
|
1047
|
+
}
|
1048
|
+
if { [string equal $type "TkResource"] } {
|
1049
|
+
set alt [lindex [lindex $optdesc 3] 1]
|
1050
|
+
} else {
|
1051
|
+
set alt ""
|
1052
|
+
}
|
1053
|
+
set res [_configure_option $option $alt]
|
1054
|
+
return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
|
1055
|
+
}
|
1056
|
+
}
|
1057
|
+
|
1058
|
+
|
1059
|
+
# ----------------------------------------------------------------------------
|
1060
|
+
# Command Widget::_configure_option
|
1061
|
+
# ----------------------------------------------------------------------------
|
1062
|
+
proc Widget::_configure_option { option altopt } {
|
1063
|
+
variable _optiondb
|
1064
|
+
variable _optionclass
|
1065
|
+
|
1066
|
+
if { [info exists _optiondb($option)] } {
|
1067
|
+
set optdb $_optiondb($option)
|
1068
|
+
} else {
|
1069
|
+
set optdb [string range $option 1 end]
|
1070
|
+
}
|
1071
|
+
if { [info exists _optionclass($option)] } {
|
1072
|
+
set optclass $_optionclass($option)
|
1073
|
+
} elseif { [string length $altopt] } {
|
1074
|
+
if { [info exists _optionclass($altopt)] } {
|
1075
|
+
set optclass $_optionclass($altopt)
|
1076
|
+
} else {
|
1077
|
+
set optclass [string range $altopt 1 end]
|
1078
|
+
}
|
1079
|
+
} else {
|
1080
|
+
set optclass [string range $option 1 end]
|
1081
|
+
}
|
1082
|
+
return [list $optdb $optclass]
|
1083
|
+
}
|
1084
|
+
|
1085
|
+
# ----------------------------------------------------------------------------
|
1086
|
+
# Command Widget::_make_tk_widget_name
|
1087
|
+
# ----------------------------------------------------------------------------
|
1088
|
+
# Before, the widget meta name was build as: ".#BWidget.#$tkwidget"
|
1089
|
+
# This does not work for ttk widgets, as they have an "::" in their name.
|
1090
|
+
# Thus replace any "::" by "__" will do the job.
|
1091
|
+
proc Widget::_make_tk_widget_name { tkwidget } {
|
1092
|
+
set pos 0
|
1093
|
+
for {set pos 0} {0 <= [set pos [string first "::" $tkwidget $pos]]} {incr pos} {
|
1094
|
+
set tkwidget [string range $tkwidget 0 [expr {$pos-1}]]__[string range $tkwidget [expr {$pos+2}] end]
|
1095
|
+
}
|
1096
|
+
return ".#BWidget.#$tkwidget"
|
1097
|
+
}
|
1098
|
+
|
1099
|
+
# ----------------------------------------------------------------------------
|
1100
|
+
# Command Widget::_get_tkwidget_options
|
1101
|
+
# ----------------------------------------------------------------------------
|
1102
|
+
proc Widget::_get_tkwidget_options { tkwidget } {
|
1103
|
+
variable _tk_widget
|
1104
|
+
variable _optiondb
|
1105
|
+
variable _optionclass
|
1106
|
+
|
1107
|
+
set widget [_make_tk_widget_name $tkwidget]
|
1108
|
+
# encapsulation frame to not pollute '.' childspace
|
1109
|
+
if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
|
1110
|
+
if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } {
|
1111
|
+
set widget [$tkwidget $widget]
|
1112
|
+
# JDC: Withdraw toplevels, otherwise visible
|
1113
|
+
if {[string equal $tkwidget "toplevel"]} {
|
1114
|
+
wm withdraw $widget
|
1115
|
+
}
|
1116
|
+
set config [$widget configure]
|
1117
|
+
foreach optlist $config {
|
1118
|
+
set opt [lindex $optlist 0]
|
1119
|
+
if { [llength $optlist] == 2 } {
|
1120
|
+
set refsyn [lindex $optlist 1]
|
1121
|
+
# search for class
|
1122
|
+
set idx [lsearch $config [list * $refsyn *]]
|
1123
|
+
if { $idx == -1 } {
|
1124
|
+
if { [string index $refsyn 0] == "-" } {
|
1125
|
+
# search for option (tk8.1b1 bug)
|
1126
|
+
set idx [lsearch $config [list $refsyn * *]]
|
1127
|
+
} else {
|
1128
|
+
# last resort
|
1129
|
+
set idx [lsearch $config [list -[string tolower $refsyn] * *]]
|
1130
|
+
}
|
1131
|
+
if { $idx == -1 } {
|
1132
|
+
# fed up with "can't read classopt()"
|
1133
|
+
return -code error "can't find option of synonym $opt"
|
1134
|
+
}
|
1135
|
+
}
|
1136
|
+
set syn [lindex [lindex $config $idx] 0]
|
1137
|
+
# JDC: used 4 (was 3) to get def from optiondb
|
1138
|
+
set def [lindex [lindex $config $idx] 4]
|
1139
|
+
lappend _tk_widget($tkwidget) [list $opt $syn $def]
|
1140
|
+
} else {
|
1141
|
+
# JDC: used 4 (was 3) to get def from optiondb
|
1142
|
+
set def [lindex $optlist 4]
|
1143
|
+
lappend _tk_widget($tkwidget) [list $opt $def]
|
1144
|
+
set _optiondb($opt) [lindex $optlist 1]
|
1145
|
+
set _optionclass($opt) [lindex $optlist 2]
|
1146
|
+
}
|
1147
|
+
}
|
1148
|
+
}
|
1149
|
+
return $_tk_widget($tkwidget)
|
1150
|
+
}
|
1151
|
+
|
1152
|
+
|
1153
|
+
# ----------------------------------------------------------------------------
|
1154
|
+
# Command Widget::_test_tkresource
|
1155
|
+
# ----------------------------------------------------------------------------
|
1156
|
+
proc Widget::_test_tkresource { option value arg } {
|
1157
|
+
# set tkwidget [lindex $arg 0]
|
1158
|
+
# set realopt [lindex $arg 1]
|
1159
|
+
foreach {tkwidget realopt} $arg break
|
1160
|
+
set path [_make_tk_widget_name $tkwidget]
|
1161
|
+
set old [$path cget $realopt]
|
1162
|
+
$path configure $realopt $value
|
1163
|
+
set res [$path cget $realopt]
|
1164
|
+
$path configure $realopt $old
|
1165
|
+
|
1166
|
+
return $res
|
1167
|
+
}
|
1168
|
+
|
1169
|
+
|
1170
|
+
# ----------------------------------------------------------------------------
|
1171
|
+
# Command Widget::_test_bwresource
|
1172
|
+
# ----------------------------------------------------------------------------
|
1173
|
+
proc Widget::_test_bwresource { option value arg } {
|
1174
|
+
return -code error "bad option type BwResource in widget"
|
1175
|
+
}
|
1176
|
+
|
1177
|
+
|
1178
|
+
# ----------------------------------------------------------------------------
|
1179
|
+
# Command Widget::_test_synonym
|
1180
|
+
# ----------------------------------------------------------------------------
|
1181
|
+
proc Widget::_test_synonym { option value arg } {
|
1182
|
+
return -code error "bad option type Synonym in widget"
|
1183
|
+
}
|
1184
|
+
|
1185
|
+
# ----------------------------------------------------------------------------
|
1186
|
+
# Command Widget::_test_color
|
1187
|
+
# ----------------------------------------------------------------------------
|
1188
|
+
proc Widget::_test_color { option value arg } {
|
1189
|
+
if {[catch {winfo rgb . $value} color]} {
|
1190
|
+
return -code error "bad $option value \"$value\": must be a colorname \
|
1191
|
+
or #RRGGBB triplet"
|
1192
|
+
}
|
1193
|
+
|
1194
|
+
return $value
|
1195
|
+
}
|
1196
|
+
|
1197
|
+
|
1198
|
+
# ----------------------------------------------------------------------------
|
1199
|
+
# Command Widget::_test_string
|
1200
|
+
# ----------------------------------------------------------------------------
|
1201
|
+
proc Widget::_test_string { option value arg } {
|
1202
|
+
set value
|
1203
|
+
}
|
1204
|
+
|
1205
|
+
|
1206
|
+
# ----------------------------------------------------------------------------
|
1207
|
+
# Command Widget::_test_flag
|
1208
|
+
# ----------------------------------------------------------------------------
|
1209
|
+
proc Widget::_test_flag { option value arg } {
|
1210
|
+
set len [string length $value]
|
1211
|
+
set res ""
|
1212
|
+
for {set i 0} {$i < $len} {incr i} {
|
1213
|
+
set c [string index $value $i]
|
1214
|
+
if { [string first $c $arg] == -1 } {
|
1215
|
+
return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
|
1216
|
+
}
|
1217
|
+
if { [string first $c $res] == -1 } {
|
1218
|
+
append res $c
|
1219
|
+
}
|
1220
|
+
}
|
1221
|
+
return $res
|
1222
|
+
}
|
1223
|
+
|
1224
|
+
|
1225
|
+
# -----------------------------------------------------------------------------
|
1226
|
+
# Command Widget::_test_enum
|
1227
|
+
# -----------------------------------------------------------------------------
|
1228
|
+
proc Widget::_test_enum { option value arg } {
|
1229
|
+
if { [lsearch $arg $value] == -1 } {
|
1230
|
+
set last [lindex $arg end]
|
1231
|
+
set sub [lreplace $arg end end]
|
1232
|
+
if { [llength $sub] } {
|
1233
|
+
set str "[join $sub ", "] or $last"
|
1234
|
+
} else {
|
1235
|
+
set str $last
|
1236
|
+
}
|
1237
|
+
return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
|
1238
|
+
}
|
1239
|
+
return $value
|
1240
|
+
}
|
1241
|
+
|
1242
|
+
|
1243
|
+
# -----------------------------------------------------------------------------
|
1244
|
+
# Command Widget::_test_int
|
1245
|
+
# -----------------------------------------------------------------------------
|
1246
|
+
proc Widget::_test_int { option value arg } {
|
1247
|
+
if { ![string is int -strict $value] || \
|
1248
|
+
([string length $arg] && \
|
1249
|
+
![expr [string map [list %d $value] $arg]]) } {
|
1250
|
+
return -code error "bad $option value\
|
1251
|
+
\"$value\": must be integer ($arg)"
|
1252
|
+
}
|
1253
|
+
return $value
|
1254
|
+
}
|
1255
|
+
|
1256
|
+
|
1257
|
+
# -----------------------------------------------------------------------------
|
1258
|
+
# Command Widget::_test_boolean
|
1259
|
+
# -----------------------------------------------------------------------------
|
1260
|
+
proc Widget::_test_boolean { option value arg } {
|
1261
|
+
if { ![string is boolean -strict $value] } {
|
1262
|
+
return -code error "bad $option value \"$value\": must be boolean"
|
1263
|
+
}
|
1264
|
+
|
1265
|
+
# Get the canonical form of the boolean value (1 for true, 0 for false)
|
1266
|
+
return [string is true $value]
|
1267
|
+
}
|
1268
|
+
|
1269
|
+
|
1270
|
+
# -----------------------------------------------------------------------------
|
1271
|
+
# Command Widget::_test_padding
|
1272
|
+
# -----------------------------------------------------------------------------
|
1273
|
+
proc Widget::_test_padding { option values arg } {
|
1274
|
+
set len [llength $values]
|
1275
|
+
if {$len < 1 || $len > 2} {
|
1276
|
+
return -code error "bad pad value \"$values\":\
|
1277
|
+
must be positive screen distance"
|
1278
|
+
}
|
1279
|
+
|
1280
|
+
foreach value $values {
|
1281
|
+
if { ![string is int -strict $value] || \
|
1282
|
+
([string length $arg] && \
|
1283
|
+
![expr [string map [list %d $value] $arg]]) } {
|
1284
|
+
return -code error "bad pad value \"$value\":\
|
1285
|
+
must be positive screen distance ($arg)"
|
1286
|
+
}
|
1287
|
+
}
|
1288
|
+
return $values
|
1289
|
+
}
|
1290
|
+
|
1291
|
+
|
1292
|
+
# Widget::_get_padding --
|
1293
|
+
#
|
1294
|
+
# Return the requesting padding value for a padding option.
|
1295
|
+
#
|
1296
|
+
# Arguments:
|
1297
|
+
# path Widget to get the options for.
|
1298
|
+
# option The name of the padding option.
|
1299
|
+
# index The index of the padding. If the index is empty,
|
1300
|
+
# the first padding value is returned.
|
1301
|
+
#
|
1302
|
+
# Results:
|
1303
|
+
# Return a numeric value that can be used for padding.
|
1304
|
+
proc Widget::_get_padding { path option {index 0} } {
|
1305
|
+
set pad [Widget::cget $path $option]
|
1306
|
+
set val [lindex $pad $index]
|
1307
|
+
if {$val == ""} { set val [lindex $pad 0] }
|
1308
|
+
return $val
|
1309
|
+
}
|
1310
|
+
|
1311
|
+
|
1312
|
+
# -----------------------------------------------------------------------------
|
1313
|
+
# Command Widget::focusNext
|
1314
|
+
# Same as tk_focusNext, but call Widget::focusOK
|
1315
|
+
# -----------------------------------------------------------------------------
|
1316
|
+
proc Widget::focusNext { w } {
|
1317
|
+
set cur $w
|
1318
|
+
while 1 {
|
1319
|
+
|
1320
|
+
# Descend to just before the first child of the current widget.
|
1321
|
+
|
1322
|
+
set parent $cur
|
1323
|
+
set children [winfo children $cur]
|
1324
|
+
set i -1
|
1325
|
+
|
1326
|
+
# Look for the next sibling that isn't a top-level.
|
1327
|
+
|
1328
|
+
while 1 {
|
1329
|
+
incr i
|
1330
|
+
if {$i < [llength $children]} {
|
1331
|
+
set cur [lindex $children $i]
|
1332
|
+
if {[string equal [winfo toplevel $cur] $cur]} {
|
1333
|
+
continue
|
1334
|
+
} else {
|
1335
|
+
break
|
1336
|
+
}
|
1337
|
+
}
|
1338
|
+
|
1339
|
+
# No more siblings, so go to the current widget's parent.
|
1340
|
+
# If it's a top-level, break out of the loop, otherwise
|
1341
|
+
# look for its next sibling.
|
1342
|
+
|
1343
|
+
set cur $parent
|
1344
|
+
if {[string equal [winfo toplevel $cur] $cur]} {
|
1345
|
+
break
|
1346
|
+
}
|
1347
|
+
set parent [winfo parent $parent]
|
1348
|
+
set children [winfo children $parent]
|
1349
|
+
set i [lsearch -exact $children $cur]
|
1350
|
+
}
|
1351
|
+
if {[string equal $cur $w] || [focusOK $cur]} {
|
1352
|
+
return $cur
|
1353
|
+
}
|
1354
|
+
}
|
1355
|
+
}
|
1356
|
+
|
1357
|
+
|
1358
|
+
# -----------------------------------------------------------------------------
|
1359
|
+
# Command Widget::focusPrev
|
1360
|
+
# Same as tk_focusPrev, except:
|
1361
|
+
# + Don't traverse from a child to a direct ancestor
|
1362
|
+
# + Call Widget::focusOK instead of tk::focusOK
|
1363
|
+
# -----------------------------------------------------------------------------
|
1364
|
+
proc Widget::focusPrev { w } {
|
1365
|
+
set cur $w
|
1366
|
+
set origParent [winfo parent $w]
|
1367
|
+
while 1 {
|
1368
|
+
|
1369
|
+
# Collect information about the current window's position
|
1370
|
+
# among its siblings. Also, if the window is a top-level,
|
1371
|
+
# then reposition to just after the last child of the window.
|
1372
|
+
|
1373
|
+
if {[string equal [winfo toplevel $cur] $cur]} {
|
1374
|
+
set parent $cur
|
1375
|
+
set children [winfo children $cur]
|
1376
|
+
set i [llength $children]
|
1377
|
+
} else {
|
1378
|
+
set parent [winfo parent $cur]
|
1379
|
+
set children [winfo children $parent]
|
1380
|
+
set i [lsearch -exact $children $cur]
|
1381
|
+
}
|
1382
|
+
|
1383
|
+
# Go to the previous sibling, then descend to its last descendant
|
1384
|
+
# (highest in stacking order. While doing this, ignore top-levels
|
1385
|
+
# and their descendants. When we run out of descendants, go up
|
1386
|
+
# one level to the parent.
|
1387
|
+
|
1388
|
+
while {$i > 0} {
|
1389
|
+
incr i -1
|
1390
|
+
set cur [lindex $children $i]
|
1391
|
+
if {[string equal [winfo toplevel $cur] $cur]} {
|
1392
|
+
continue
|
1393
|
+
}
|
1394
|
+
set parent $cur
|
1395
|
+
set children [winfo children $parent]
|
1396
|
+
set i [llength $children]
|
1397
|
+
}
|
1398
|
+
set cur $parent
|
1399
|
+
if {[string equal $cur $w]} {
|
1400
|
+
return $cur
|
1401
|
+
}
|
1402
|
+
# If we are just at the original parent of $w, skip it as a
|
1403
|
+
# potential focus accepter. Extra safety in this is to see if
|
1404
|
+
# that parent is also a proc (not a C command), which is what
|
1405
|
+
# BWidgets makes for any megawidget. Could possibly also check
|
1406
|
+
# for '[info commands ::${origParent}:cmd] != ""'. [Bug 765667]
|
1407
|
+
if {[string equal $cur $origParent]
|
1408
|
+
&& [info procs ::$origParent] != ""} {
|
1409
|
+
continue
|
1410
|
+
}
|
1411
|
+
if {[focusOK $cur]} {
|
1412
|
+
return $cur
|
1413
|
+
}
|
1414
|
+
}
|
1415
|
+
}
|
1416
|
+
|
1417
|
+
|
1418
|
+
# ----------------------------------------------------------------------------
|
1419
|
+
# Command Widget::focusOK
|
1420
|
+
# Same as tk_focusOK, but handles -editable option and whole tags list.
|
1421
|
+
# ----------------------------------------------------------------------------
|
1422
|
+
proc Widget::focusOK { w } {
|
1423
|
+
set code [catch {$w cget -takefocus} value]
|
1424
|
+
if { $code == 1 } {
|
1425
|
+
return 0
|
1426
|
+
}
|
1427
|
+
if {($code == 0) && ($value != "")} {
|
1428
|
+
if {$value == 0} {
|
1429
|
+
return 0
|
1430
|
+
} elseif {$value == 1} {
|
1431
|
+
return [winfo viewable $w]
|
1432
|
+
} else {
|
1433
|
+
set value [uplevel \#0 [list $value $w]]
|
1434
|
+
if {$value != ""} {
|
1435
|
+
return $value
|
1436
|
+
}
|
1437
|
+
}
|
1438
|
+
}
|
1439
|
+
if {![winfo viewable $w]} {
|
1440
|
+
return 0
|
1441
|
+
}
|
1442
|
+
set code [catch {$w cget -state} value]
|
1443
|
+
if {($code == 0) && ($value == "disabled")} {
|
1444
|
+
return 0
|
1445
|
+
}
|
1446
|
+
set code [catch {$w cget -editable} value]
|
1447
|
+
if {($code == 0) && ($value == 0)} {
|
1448
|
+
return 0
|
1449
|
+
}
|
1450
|
+
|
1451
|
+
set top [winfo toplevel $w]
|
1452
|
+
foreach tags [bindtags $w] {
|
1453
|
+
if { ![string equal $tags $top] &&
|
1454
|
+
![string equal $tags "all"] &&
|
1455
|
+
[regexp Key [bind $tags]] } {
|
1456
|
+
return 1
|
1457
|
+
}
|
1458
|
+
}
|
1459
|
+
return 0
|
1460
|
+
}
|
1461
|
+
|
1462
|
+
|
1463
|
+
proc Widget::traverseTo { w } {
|
1464
|
+
set focus [focus]
|
1465
|
+
if {![string equal $focus ""]} {
|
1466
|
+
event generate $focus <<TraverseOut>>
|
1467
|
+
}
|
1468
|
+
focus $w
|
1469
|
+
|
1470
|
+
event generate $w <<TraverseIn>>
|
1471
|
+
}
|
1472
|
+
|
1473
|
+
# Widget::which --
|
1474
|
+
#
|
1475
|
+
# Retrieve a fully qualified variable name for the specified option or
|
1476
|
+
# widget variable.
|
1477
|
+
#
|
1478
|
+
# If the option is not one for which a variable exists, throw an error
|
1479
|
+
# (ie, those options that map directly to widget options).
|
1480
|
+
#
|
1481
|
+
# For widget variables, return the fully qualified name even if the
|
1482
|
+
# variable had not been previously set, in order to allow adding variable
|
1483
|
+
# traces prior to their creation.
|
1484
|
+
#
|
1485
|
+
# Arguments:
|
1486
|
+
# path megawidget to get an option var for.
|
1487
|
+
# type either -option or -variable.
|
1488
|
+
# name name of the option or widget variable.
|
1489
|
+
#
|
1490
|
+
# Results:
|
1491
|
+
# Fully qualified name of the variable for the option or the widget
|
1492
|
+
# variable.
|
1493
|
+
#
|
1494
|
+
proc Widget::which {path args} {
|
1495
|
+
switch -- [llength $args] {
|
1496
|
+
1 {
|
1497
|
+
set type -option;
|
1498
|
+
set name [lindex $args 0];
|
1499
|
+
}
|
1500
|
+
2 {
|
1501
|
+
set type [lindex $args 0];
|
1502
|
+
set name [lindex $args 1];
|
1503
|
+
}
|
1504
|
+
default {
|
1505
|
+
return -code error "incorrect number of arguments";
|
1506
|
+
}
|
1507
|
+
}
|
1508
|
+
|
1509
|
+
variable _class;
|
1510
|
+
set class $_class($path);
|
1511
|
+
|
1512
|
+
switch -- $type {
|
1513
|
+
-option {
|
1514
|
+
upvar 0 ${class}::$path:opt pathopt;
|
1515
|
+
|
1516
|
+
if { ![info exists pathopt($option)] } {
|
1517
|
+
error "unable to find variable for option \"$option\"";
|
1518
|
+
}
|
1519
|
+
|
1520
|
+
return ::Widget::${class}::${path}:opt(${name});
|
1521
|
+
}
|
1522
|
+
-variable {
|
1523
|
+
return ${class}::${path}:${name};
|
1524
|
+
}
|
1525
|
+
}
|
1526
|
+
}
|
1527
|
+
|
1528
|
+
|
1529
|
+
# Widget::varForOption --
|
1530
|
+
#
|
1531
|
+
# Retrieve a fully qualified variable name for the option specified.
|
1532
|
+
# If the option is not one for which a variable exists, throw an error
|
1533
|
+
# (ie, those options that map directly to widget options) Superseded by
|
1534
|
+
# widget::which.
|
1535
|
+
#
|
1536
|
+
# Arguments:
|
1537
|
+
# path megawidget to get an option var for.
|
1538
|
+
# option option to get a var for.
|
1539
|
+
#
|
1540
|
+
# Results:
|
1541
|
+
# varname name of the variable, fully qualified, suitable for tracing.
|
1542
|
+
|
1543
|
+
proc Widget::varForOption {path option} {
|
1544
|
+
return [::Widget::which $path -option $option];
|
1545
|
+
}
|
1546
|
+
|
1547
|
+
# Widget::getVariable --
|
1548
|
+
#
|
1549
|
+
# Get a variable from within the namespace of the widget.
|
1550
|
+
#
|
1551
|
+
# Arguments:
|
1552
|
+
# path Megawidget to get the variable for.
|
1553
|
+
# varName The variable name to retrieve.
|
1554
|
+
# newVarName The variable name to refer to in the calling proc.
|
1555
|
+
#
|
1556
|
+
# Results:
|
1557
|
+
# Creates a reference to newVarName in the calling proc.
|
1558
|
+
proc Widget::getVariable { path varName {newVarName ""} } {
|
1559
|
+
variable _class
|
1560
|
+
set class $_class($path)
|
1561
|
+
if {![string length $newVarName]} { set newVarName $varName }
|
1562
|
+
uplevel 1 [list ::upvar \#0 ${class}::$path:$varName $newVarName]
|
1563
|
+
}
|
1564
|
+
|
1565
|
+
# Widget::options --
|
1566
|
+
#
|
1567
|
+
# Return a key-value list of options for a widget. This can
|
1568
|
+
# be used to serialize the options of a widget and pass them
|
1569
|
+
# on to a new widget with the same options.
|
1570
|
+
#
|
1571
|
+
# Arguments:
|
1572
|
+
# path Widget to get the options for.
|
1573
|
+
# args A list of options. If empty, all options are returned.
|
1574
|
+
#
|
1575
|
+
# Results:
|
1576
|
+
# Returns list of options as: -option value -option value ...
|
1577
|
+
proc Widget::options { path args } {
|
1578
|
+
if {[llength $args]} {
|
1579
|
+
foreach option $args {
|
1580
|
+
lappend options [_get_configure $path $option]
|
1581
|
+
}
|
1582
|
+
} else {
|
1583
|
+
set options [_get_configure $path {}]
|
1584
|
+
}
|
1585
|
+
|
1586
|
+
set result [list]
|
1587
|
+
foreach list $options {
|
1588
|
+
if {[llength $list] < 5} { continue }
|
1589
|
+
lappend result [lindex $list 0] [lindex $list end]
|
1590
|
+
}
|
1591
|
+
return $result
|
1592
|
+
}
|
1593
|
+
|
1594
|
+
|
1595
|
+
# Widget::getOption --
|
1596
|
+
#
|
1597
|
+
# Given a list of widgets, determine which option value to use.
|
1598
|
+
# The widgets are given to the command in order of highest to
|
1599
|
+
# lowest. Starting with the lowest widget, whichever one does
|
1600
|
+
# not match the default option value is returned as the value.
|
1601
|
+
# If all the widgets are default, we return the highest widget's
|
1602
|
+
# value.
|
1603
|
+
#
|
1604
|
+
# Arguments:
|
1605
|
+
# option The option to check.
|
1606
|
+
# default The default value. If any widget in the list
|
1607
|
+
# does not match this default, its value is used.
|
1608
|
+
# args A list of widgets.
|
1609
|
+
#
|
1610
|
+
# Results:
|
1611
|
+
# Returns the value of the given option to use.
|
1612
|
+
#
|
1613
|
+
proc Widget::getOption { option default args } {
|
1614
|
+
for {set i [expr [llength $args] -1]} {$i >= 0} {incr i -1} {
|
1615
|
+
set widget [lindex $args $i]
|
1616
|
+
set value [Widget::cget $widget $option]
|
1617
|
+
if {[string equal $value $default]} { continue }
|
1618
|
+
return $value
|
1619
|
+
}
|
1620
|
+
return $value
|
1621
|
+
}
|
1622
|
+
|
1623
|
+
|
1624
|
+
proc Widget::nextIndex { path node } {
|
1625
|
+
Widget::getVariable $path autoIndex
|
1626
|
+
if {![info exists autoIndex]} { set autoIndex -1 }
|
1627
|
+
return [string map [list #auto [incr autoIndex]] $node]
|
1628
|
+
}
|
1629
|
+
|
1630
|
+
|
1631
|
+
proc Widget::exists { path } {
|
1632
|
+
variable _class
|
1633
|
+
return [info exists _class($path)]
|
1634
|
+
}
|
1635
|
+
|
1636
|
+
proc Widget::theme {{bool {}}} {
|
1637
|
+
# Private, *experimental* API that may change at any time - JH
|
1638
|
+
variable _theme
|
1639
|
+
if {[llength [info level 0]] == 2} {
|
1640
|
+
# set theme-ability
|
1641
|
+
if {[catch {package require Tk 8.5a6}]
|
1642
|
+
&& [catch {package require tile 0.6}]
|
1643
|
+
&& [catch {package require tile 1}]} {
|
1644
|
+
return -code error "BWidget's theming requires tile 0.6+"
|
1645
|
+
} else {
|
1646
|
+
catch {style default BWSlim.Toolbutton -padding 0}
|
1647
|
+
}
|
1648
|
+
set _theme [string is true -strict $bool]
|
1649
|
+
}
|
1650
|
+
return $_theme
|
1651
|
+
}
|