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.
Files changed (159) hide show
  1. checksums.yaml +4 -4
  2. data/{README → README.md} +60 -53
  3. data/conf/LC/en-UK.LANG +10 -4
  4. data/conf/arcadia.conf +221 -83
  5. data/conf/arcadia.res.rb +165 -175
  6. data/conf/theme-dark.conf +1 -1
  7. data/conf/theme-dark.res.rb +0 -123
  8. data/ext/ae-breakpoints/ae-breakpoints.rb +4 -3
  9. data/ext/ae-dir-projects/ae-dir-projects.conf +27 -1
  10. data/ext/ae-dir-projects/ae-dir-projects.rb +120 -70
  11. data/ext/ae-editor/ae-editor.conf +2 -2
  12. data/ext/ae-editor/ae-editor.rb +610 -303
  13. data/ext/ae-file-history/ae-file-history.rb +60 -39
  14. data/ext/ae-output/ae-output.rb +52 -27
  15. data/ext/ae-ruby-debug/ae-ruby-debug.conf +3 -1
  16. data/ext/ae-ruby-debug/ae-ruby-debug.rb +18 -11
  17. data/ext/ae-search-in-files/ae-search-in-files.conf +2 -2
  18. data/ext/ae-search-in-files/ae-search-in-files.rb +124 -77
  19. data/ext/ae-shell/ae-shell.conf +1 -1
  20. data/ext/ae-shell/ae-shell.rb +18 -81
  21. data/ext/ae-subprocess-inspector/ae-subprocess-inspector.rb +78 -81
  22. data/ext/ae-term/ae-term.rb +9 -7
  23. data/lib/a-commons.rb +125 -17
  24. data/lib/a-contracts.rb +6 -2
  25. data/lib/a-core.rb +441 -405
  26. data/lib/a-tkcommons.rb +1237 -45
  27. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ArrowButton.html +0 -0
  28. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/BWidget.html +0 -0
  29. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Button.html +0 -0
  30. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ButtonBox.html +0 -0
  31. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ComboBox.html +0 -0
  32. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Dialog.html +0 -0
  33. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/DragSite.html +0 -0
  34. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/DropSite.html +0 -0
  35. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/DynamicHelp.html +0 -0
  36. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Entry.html +0 -0
  37. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Label.html +0 -0
  38. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/LabelEntry.html +0 -0
  39. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/LabelFrame.html +0 -0
  40. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ListBox.html +0 -0
  41. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/MainFrame.html +0 -0
  42. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/MessageDlg.html +0 -0
  43. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/NoteBook.html +0 -0
  44. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PagesManager.html +0 -0
  45. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PanedWindow.html +0 -0
  46. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PanelFrame.html +0 -0
  47. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/PasswdDlg.html +0 -0
  48. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ProgressBar.html +0 -0
  49. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ProgressDlg.html +0 -0
  50. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ScrollView.html +0 -0
  51. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ScrollableFrame.html +0 -0
  52. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/ScrolledWindow.html +0 -0
  53. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/SelectColor.html +0 -0
  54. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/SelectFont.html +0 -0
  55. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Separator.html +0 -0
  56. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/SpinBox.html +0 -0
  57. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/StatusBar.html +0 -0
  58. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/TitleFrame.html +0 -0
  59. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Tree.html +0 -0
  60. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/Widget.html +0 -0
  61. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/contents.html +0 -0
  62. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/index.html +0 -0
  63. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/navtree.html +0 -0
  64. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/BWman/options.htm +0 -0
  65. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/CHANGES.txt +0 -0
  66. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/ChangeLog +65 -0
  67. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/LICENSE.txt +0 -0
  68. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/README.txt +0 -0
  69. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/arrow.tcl +0 -0
  70. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/bitmap.tcl +0 -0
  71. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/button.tcl +0 -2
  72. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/buttonbox.tcl +0 -0
  73. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/color.tcl +0 -0
  74. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/combobox.tcl +40 -16
  75. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/basic.tcl +0 -0
  76. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/bwidget.xbm +0 -0
  77. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/demo.tcl +0 -0
  78. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/dnd.tcl +0 -0
  79. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/manager.tcl +0 -0
  80. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/select.tcl +0 -0
  81. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/tmpldlg.tcl +0 -0
  82. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/tree.tcl +0 -0
  83. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/demo/x1.xbm +0 -0
  84. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dialog.tcl +0 -0
  85. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dragsite.tcl +0 -0
  86. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dropsite.tcl +0 -0
  87. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/dynhelp.tcl +3 -0
  88. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/entry.tcl +0 -0
  89. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/font.tcl +0 -0
  90. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/bold.gif +0 -0
  91. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/copy.gif +0 -0
  92. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/cut.gif +0 -0
  93. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/dragfile.gif +0 -0
  94. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/dragicon.gif +0 -0
  95. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/error.gif +0 -0
  96. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/file.gif +0 -0
  97. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/folder.gif +0 -0
  98. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/hourglass.gif +0 -0
  99. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/info.gif +0 -0
  100. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/italic.gif +0 -0
  101. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/minus.xbm +0 -0
  102. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/new.gif +0 -0
  103. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/opcopy.xbm +0 -0
  104. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/open.gif +0 -0
  105. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/openfold.gif +0 -0
  106. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/oplink.xbm +0 -0
  107. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/opmove.xbm +0 -0
  108. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/overstrike.gif +0 -0
  109. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/palette.gif +0 -0
  110. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/passwd.gif +0 -0
  111. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/paste.gif +0 -0
  112. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/plus.xbm +0 -0
  113. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/print.gif +0 -0
  114. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/question.gif +0 -0
  115. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/redo.gif +0 -0
  116. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/save.gif +0 -0
  117. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/target.xbm +0 -0
  118. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/underline.gif +0 -0
  119. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/undo.gif +0 -0
  120. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/images/warning.gif +0 -0
  121. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/init.tcl +0 -0
  122. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/label.tcl +0 -2
  123. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/labelentry.tcl +0 -3
  124. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/labelframe.tcl +0 -2
  125. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/da.rc +1 -0
  126. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/de.rc +1 -0
  127. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/en.rc +1 -0
  128. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/es.rc +1 -0
  129. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/fr.rc +1 -0
  130. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/hu.rc +1 -0
  131. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/nl.rc +1 -0
  132. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/no.rc +59 -58
  133. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/lang/pl.rc +0 -0
  134. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/listbox.tcl +17 -4
  135. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/mainframe.tcl +0 -0
  136. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/messagedlg.tcl +0 -0
  137. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/notebook.tcl +0 -0
  138. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/pagesmgr.tcl +0 -0
  139. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/panedw.tcl +0 -0
  140. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/panelframe.tcl +0 -0
  141. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/passwddlg.tcl +0 -0
  142. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/pkgIndex.tcl +2 -2
  143. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/progressbar.tcl +0 -0
  144. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/progressdlg.tcl +0 -0
  145. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/scrollframe.tcl +6 -6
  146. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/scrollview.tcl +0 -0
  147. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/scrollw.tcl +1 -0
  148. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/separator.tcl +0 -0
  149. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/spinbox.tcl +0 -0
  150. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/statusbar.tcl +0 -0
  151. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/tests/entry.test +2 -2
  152. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/titleframe.tcl +0 -0
  153. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/tree.tcl +0 -0
  154. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/utils.tcl +0 -0
  155. data/tcl/bwidget-1.9.8/widget-old.tcl +1651 -0
  156. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/widget.tcl +64 -36
  157. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/wizard.tcl +0 -0
  158. data/tcl/{bwidget-1.9.7 → bwidget-1.9.8}/xpm2image.tcl +0 -0
  159. metadata +196 -195
@@ -56,3 +56,4 @@
56
56
 
57
57
  *baseColorsName: Base colors
58
58
  *userColorsName: User colors
59
+
@@ -56,3 +56,4 @@
56
56
 
57
57
  *baseColorsName: Base colors
58
58
  *userColorsName: User colors
59
+
@@ -57,3 +57,4 @@
57
57
 
58
58
  *baseColorsName: Alapszínek
59
59
  *userColorsName: Felhasználói színek
60
+
@@ -56,3 +56,4 @@
56
56
 
57
57
  *baseColorsName: Base colors
58
58
  *userColorsName: User colors
59
+
@@ -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
+
@@ -240,7 +240,8 @@ proc ListBox::configure { path args } {
240
240
  _configureSelectmode $path $selectmode $selectmodePrevious
241
241
  }
242
242
 
243
- set ch1 [expr {[Widget::hasChanged $path -deltay dy] |
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
- set redraw 1
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
- set x0 4
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]]
@@ -1,7 +1,7 @@
1
1
  if {[catch {package require Tcl}]} return
2
- package ifneeded BWidget 1.9.7 "\
2
+ package ifneeded BWidget 1.9.8 "\
3
3
  package require Tk 8.1.1;\
4
- [list tclPkgSetup $dir BWidget 1.9.7 {
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}}
@@ -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
@@ -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]
@@ -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 false shazbot {expected boolean value but got "shazbot"}}
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 {no value given for parameter "path" to "Entry"}}
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"}}
@@ -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
+ }