home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / rexxtk12.zip / extensions / rexxtkmclistbox.c < prev    next >
Text File  |  2002-08-07  |  62KB  |  1,878 lines
  1. /*
  2.  *  Rexx/Tk Multi-column listbox
  3.  *  Copyright (C) 2000  Mark Hessling  <M.Hessling@qut.edu.au>
  4.  *
  5.  *  This library is free software; you can redistribute it and/or
  6.  *  modify it under the terms of the GNU Library General Public
  7.  *  License as published by the Free Software Foundation; either
  8.  *  version 2 of the License, or (at your option) any later version.
  9.  *
  10.  *  This library is distributed in the hope that it will be useful,
  11.  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.  *  Library General Public License for more details.
  14.  *
  15.  *  You should have received a copy of the GNU Library General Public
  16.  *  License along with this library; if not, write to the Free
  17.  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  */
  19.  
  20. #include "rexxtk.h"
  21.  
  22. char *RxPackageName = "rexxtkmclistbox";
  23. char *ExtensionSource =
  24. "package require Tk 8.0\n"
  25. "package provide mclistbox 1.02\n"
  26. "namespace eval ::mclistbox {\n"
  27. "namespace export mclistbox\n"
  28. "variable widgetOptions\n"
  29. "variable columnOptions\n"
  30. "variable widgetCommands\n"
  31. "variable columnCommands\n"
  32. "variable labelCommands\n"
  33. "}\n"
  34. "proc ::mclistbox::Init {} {\n"
  35. "variable widgetOptions\n"
  36. "variable columnOptions\n"
  37. "variable widgetCommands\n"
  38. "variable columnCommands\n"
  39. "variable labelCommands\n"
  40. "array set widgetOptions [list  "
  41. "-background          {background          Background}  "
  42. "-bd                  -borderwidth  "
  43. "-bg                  -background  "
  44. "-borderwidth         {borderWidth         BorderWidth}  "
  45. "-columnbd            -columnborderwidth  "
  46. "-columnborderwidth   {columnBorderWidth   BorderWidth}  "
  47. "-columnrelief        {columnRelief        Relief}  "
  48. "-cursor              {cursor              Cursor}  "
  49. "-exportselection     {exportSelection     ExportSelection}  "
  50. "-fg                  -foreground  "
  51. "-fillcolumn          {fillColumn          FillColumn}  "
  52. "-font                {font                Font}  "
  53. "-foreground          {foreground          Foreground}  "
  54. "-height              {height              Height}  "
  55. "-highlightbackground {highlightBackground HighlightBackground}  "
  56. "-highlightcolor      {highlightColor      HighlightColor}  "
  57. "-highlightthickness  {highlightThickness  HighlightThickness}  "
  58. "-labelanchor         {labelAnchor         Anchor}  "
  59. "-labelbackground     {labelBackground     Background}  "
  60. "-labelbd             -labelborderwidth  "
  61. "-labelbg             -labelbackground  "
  62. "-labelborderwidth    {labelBorderWidth    BorderWidth}  "
  63. "-labelfg             -labelforeground  "
  64. "-labelfont           {labelFont           Font}  "
  65. "-labelforeground     {labelForeground     Foreground}  "
  66. "-labelheight         {labelHeight         Height}  "
  67. "-labelimage          {labelImage          Image}  "
  68. "-labelrelief         {labelRelief         Relief}  "
  69. "-labels              {labels              Labels}  "
  70. "-relief              {relief              Relief}  "
  71. "-resizablecolumns    {resizableColumns    ResizableColumns}  "
  72. "-selectbackground    {selectBackground    Foreground}  "
  73. "-selectborderwidth   {selectBorderWidth   BorderWidth}  "
  74. "-selectcommand       {selectCommand       Command}  "
  75. "-selectforeground    {selectForeground    Background}  "
  76. "-selectmode          {selectMode          SelectMode}  "
  77. "-setgrid             {setGrid             SetGrid}  "
  78. "-takefocus           {takeFocus           TakeFocus}  "
  79. "-width               {width               Width}  "
  80. "-xscrollcommand      {xScrollCommand      ScrollCommand}  "
  81. "-yscrollcommand      {yScrollCommand      ScrollCommand}  "
  82. "]\n"
  83. "array set columnOptions [list  "
  84. "-background         {background           Background}  "
  85. "-bitmap  {bitmap               Bitmap}  "
  86. "-font               {font                 Font}  "
  87. "-foreground         {foreground           Foreground}  "
  88. "-image              {image                Image}  "
  89. "-label   {label                Label}  "
  90. "-position           {position             Position}  "
  91. "-resizable          {resizable            Resizable}  "
  92. "-visible            {visible              Visible}  "
  93. "-width              {width                Width}  "
  94. "]\n"
  95. "set widgetCommands [list  "
  96. "activate  bbox       cget     column    configure   "
  97. "curselection delete     get      index     insert  itemconfigure "
  98. "label        nearest    scan     see       selection   "
  99. "size         xview      yview\n"
  100. "]\n"
  101. "set columnCommands [list add cget configure delete names nearest]\n"
  102. "set labelCommands  [list bind]\n"
  103. "set packages [package names]\n"
  104. "if {[lsearch -exact [package names] \"Tk\"] != -1} {\n"
  105. "set tmpWidget \".__tmp__\"\n"
  106. "set count 0\n"
  107. "while {[winfo exists $tmpWidget] == 1} {\n"
  108. "set tmpWidget \".__tmp__$count\"\n"
  109. "incr count\n"
  110. "}\n"
  111. "listbox $tmpWidget\n"
  112. "foreach foo [$tmpWidget configure] {\n"
  113. "if {[llength $foo] == 5} {\n"
  114. "set option [lindex $foo 1]\n"
  115. "set value [lindex $foo 4]\n"
  116. "option add *Mclistbox.$option $value widgetDefault\n"
  117. "if {[string compare $option \"foreground\"] == 0  "
  118. "|| [string compare $option \"background\"] == 0  "
  119. "|| [string compare $option \"font\"] == 0} {\n"
  120. "option add *Mclistbox*MclistboxColumn.$option $value  "
  121. "widgetDefault\n"
  122. "}\n"
  123. "}\n"
  124. "}\n"
  125. "destroy $tmpWidget\n"
  126. "label $tmpWidget\n"
  127. "foreach option [list Anchor Background Font  "
  128. "Foreground Height Image  ] {\n"
  129. "set values [$tmpWidget configure -[string tolower $option]]\n"
  130. "option add *Mclistbox.label$option [lindex $values 3]\n"
  131. "}\n"
  132. "destroy $tmpWidget\n"
  133. "option add *Mclistbox.columnBorderWidth   0      widgetDefault\n"
  134. "option add *Mclistbox.columnRelief        flat   widgetDefault\n"
  135. "option add *Mclistbox.labelBorderWidth    1      widgetDefault\n"
  136. "option add *Mclistbox.labelRelief         raised widgetDefault\n"
  137. "option add *Mclistbox.labels              1      widgetDefault\n"
  138. "option add *Mclistbox.resizableColumns    1      widgetDefault\n"
  139. "option add *Mclistbox.selectcommand       {}     widgetDefault\n"
  140. "option add *Mclistbox.fillcolumn          {}     widgetDefault\n"
  141. "option add *Mclistbox*MclistboxColumn.visible       1      widgetDefault\n"
  142. "option add *Mclistbox*MclistboxColumn.resizable     1      widgetDefault\n"
  143. "option add *Mclistbox*MclistboxColumn.position      end    widgetDefault\n"
  144. "option add *Mclistbox*MclistboxColumn.label         \"\"     widgetDefault\n"
  145. "option add *Mclistbox*MclistboxColumn.width         0      widgetDefault\n"
  146. "option add *Mclistbox*MclistboxColumn.bitmap        \"\"     widgetDefault\n"
  147. "option add *Mclistbox*MclistboxColumn.image         \"\"     widgetDefault\n"
  148. "}\n"
  149. "SetClassBindings\n"
  150. "}\n"
  151. "proc ::mclistbox::mclistbox {args} {\n"
  152. "variable widgetOptions\n"
  153. "if {![info exists widgetOptions]} {\n"
  154. "Init\n"
  155. "}\n"
  156. "if {[llength $args] == 0} {\n"
  157. "error \"wrong # args: should be \\\"mclistbox pathName ?options?\\\"\"\n"
  158. "}\n"
  159. "if {[winfo exists [lindex $args 0]]} {\n"
  160. "error \"window name \\\"[lindex $args 0]\\\" already exists\"\n"
  161. "}\n"
  162. "foreach {name value} [lrange $args 1 end] {\n"
  163. "Canonize [lindex $args 0] option $name\n"
  164. "}\n"
  165. "set w [eval Build $args]\n"
  166. "SetBindings $w\n"
  167. "return $w\n"
  168. "}\n"
  169. "proc ::mclistbox::Build {w args} {\n"
  170. "variable widgetOptions\n"
  171. "namespace eval ::mclistbox::$w {\n"
  172. "variable options\n"
  173. "variable widgets\n"
  174. "variable misc\n"
  175. "}\n"
  176. "upvar ::mclistbox::${w}::widgets widgets\n"
  177. "upvar ::mclistbox::${w}::options options\n"
  178. "upvar ::mclistbox::${w}::misc    misc\n"
  179. "set misc(columns) {}\n"
  180. "set widgets(this)   [frame  $w -class Mclistbox -takefocus 1]\n"
  181. "foreach name [array names widgetOptions] {\n"
  182. "if {[llength $widgetOptions($name)] == 1} continue\n"
  183. "set optName  [lindex $widgetOptions($name) 0]\n"
  184. "set optClass [lindex $widgetOptions($name) 1]\n"
  185. "set options($name) [option get $w $optName $optClass]\n"
  186. "}\n"
  187. "if {[llength $args] > 0} {\n"
  188. "array set options $args\n"
  189. "}\n"
  190. "set widgets(text) [text $w.text  "
  191. "-width 0  "
  192. "-height 0  "
  193. "-padx 0  "
  194. "-pady 0  "
  195. "-wrap none  "
  196. "-borderwidth 0  "
  197. "-highlightthickness 0  "
  198. "-takefocus 0  "
  199. "-cursor {}  "
  200. "]\n"
  201. "$widgets(text) configure -state disabled\n"
  202. "set columnWidgets [NewColumn $w {__hidden__}]\n"
  203. "set widgets(hiddenFrame)   [lindex $columnWidgets 0]\n"
  204. "set widgets(hiddenListbox) [lindex $columnWidgets 1]\n"
  205. "set widgets(hiddenLabel)   [lindex $columnWidgets 2]\n"
  206. "pack propagate $widgets(hiddenFrame) on\n"
  207. "pack $widgets(hiddenFrame) -side top -fill both -expand y\n"
  208. "place $widgets(text) -x 0 -y 0 -relwidth 1.0 -relheight 1.0\n"
  209. "raise $widgets(text)\n"
  210. "set widgets(frame) ::mclistbox::${w}::$w\n"
  211. "rename ::$w $widgets(frame)\n"
  212. "proc ::$w {command args}  "
  213. "\"eval ::mclistbox::WidgetProc {$w} \\$command \\$args\"\n"
  214. "if {[catch \"Configure $widgets(this) [array get options]\" error]} {\n"
  215. "catch {destroy $w}\n"
  216. "}\n"
  217. "selection handle $w [list ::mclistbox::SelectionHandler $w get]\n"
  218. "return $w\n"
  219. "}\n"
  220. "proc ::mclistbox::SelectionHandler {w type {offset \"\"} {length \"\"}} {\n"
  221. "upvar ::mclistbox::${w}::options   options\n"
  222. "upvar ::mclistbox::${w}::misc      misc\n"
  223. "upvar ::mclistbox::${w}::widgets   widgets\n"
  224. "switch -exact $type {\n"
  225. "own {\n"
  226. "selection own  "
  227. "-command [list ::mclistbox::SelectionHandler $w lose]  "
  228. "-selection PRIMARY  "
  229. "$w\n"
  230. "}\n"
  231. "lose {\n"
  232. "if {$options(-exportselection)} {\n"
  233. "foreach id $misc(columns) {\n"
  234. "$widgets(listbox$id) selection clear 0 end\n"
  235. "}\n"
  236. "}\n"
  237. "}\n"
  238. "get {\n"
  239. "set end [expr {$length + $offset - 1}]\n"
  240. "set column [lindex $misc(columns) 0]\n"
  241. "set curselection [$widgets(listbox$column) curselection]\n"
  242. "set data \"\"\n"
  243. "foreach index $curselection {\n"
  244. "set rowdata [join [::mclistbox::WidgetProc-get $w $index]  \"\t\"]\n"
  245. "lappend data $rowdata\n"
  246. "}\n"
  247. "set data [join $data \"\n\"]\n"
  248. "return [string range $data $offset $end]\n"
  249. "}\n"
  250. "}\n"
  251. "}\n"
  252. "proc ::mclistbox::convert {w args} {\n"
  253. "set result {}\n"
  254. "if {![winfo exists $w]} {\n"
  255. "error \"window \\\"$w\\\" doesn't exist\"\n"
  256. "}\n"
  257. "while {[llength $args] > 0} {\n"
  258. "set option [lindex $args 0]\n"
  259. "set args [lrange $args 1 end]\n"
  260. "switch -exact -- $option {\n"
  261. "-x {\n"
  262. "set value [lindex $args 0]\n"
  263. "set args [lrange $args 1 end]\n"
  264. "set win $w\n"
  265. "while {[winfo class $win] != \"Mclistbox\"} {\n"
  266. "incr value [winfo x $win]\n"
  267. "set win [winfo parent $win]\n"
  268. "if {$win == \".\"} break\n"
  269. "}\n"
  270. "lappend result $value\n"
  271. "}\n"
  272. "-y {\n"
  273. "set value [lindex $args 0]\n"
  274. "set args [lrange $args 1 end]\n"
  275. "set win $w\n"
  276. "while {[winfo class $win] != \"Mclistbox\"} {\n"
  277. "incr value [winfo y $win]\n"
  278. "set win [winfo parent $win]\n"
  279. "if {$win == \".\"} break\n"
  280. "}\n"
  281. "lappend result $value\n"
  282. "}\n"
  283. "-w -\n"
  284. "-W {\n"
  285. "set win $w\n"
  286. "while {[winfo class $win] != \"Mclistbox\"} {\n"
  287. "set win [winfo parent $win]\n"
  288. "if {$win == \".\"} break;\n"
  289. "}\n"
  290. "lappend result $win\n"
  291. "}\n"
  292. "}\n"
  293. "}\n"
  294. "return $result\n"
  295. "}\n"
  296. "proc ::mclistbox::SetBindings {w} {\n"
  297. "upvar ::mclistbox::${w}::widgets widgets\n"
  298. "upvar ::mclistbox::${w}::options options\n"
  299. "upvar ::mclistbox::${w}::misc    misc\n"
  300. "bind $widgets(text) <Configure>  "
  301. "[list ::mclistbox::AdjustColumns $w %h]\n"
  302. "}\n"
  303. "proc ::mclistbox::SetClassBindings {} {\n"
  304. "bind Mclistbox <Destroy> [list ::mclistbox::DestroyHandler %W]\n"
  305. "foreach event [bind Listbox] {\n"
  306. "set binding [bind Listbox $event]\n"
  307. "regsub -all {%W} $binding {[::mclistbox::convert %W -W]} binding\n"
  308. "regsub -all {%x} $binding {[::mclistbox::convert %W -x %x]} binding\n"
  309. "regsub -all {%y} $binding {[::mclistbox::convert %W -y %y]} binding\n"
  310. "bind Mclistbox $event $binding\n"
  311. "}\n"
  312. "set this {[::mclistbox::convert %W -W]}\n"
  313. "bind MclistboxMouseBindings <ButtonPress-1>  "
  314. "\"::mclistbox::ResizeEvent $this buttonpress %W %x %X %Y\"\n"
  315. "bind MclistboxMouseBindings <ButtonRelease-1>  "
  316. "\"::mclistbox::ResizeEvent $this buttonrelease %W %x %X %Y\"\n"
  317. "bind MclistboxMouseBindings <Enter>  "
  318. "\"::mclistbox::ResizeEvent $this motion %W %x %X %Y\"\n"
  319. "bind MclistboxMouseBindings <Motion>  "
  320. "\"::mclistbox::ResizeEvent $this motion %W %x %X %Y\"\n"
  321. "bind MclistboxMouseBindings <B1-Motion>  "
  322. "\"::mclistbox::ResizeEvent $this drag %W %x %X %Y\"\n"
  323. "}\n"
  324. "proc ::mclistbox::NewColumn {w id} {\n"
  325. "upvar ::mclistbox::${w}::widgets   widgets\n"
  326. "upvar ::mclistbox::${w}::options   options\n"
  327. "upvar ::mclistbox::${w}::misc      misc\n"
  328. "upvar ::mclistbox::${w}::columnID  columnID\n"
  329. "set frame      "
  330. "[frame $w.frame$id  "
  331. "-takefocus 0  "
  332. "-highlightthickness 0  "
  333. "-class MclistboxColumn  "
  334. "-background $options(-background)  "
  335. "]\n"
  336. "set listbox    "
  337. "[listbox $frame.listbox  "
  338. "-takefocus 0  "
  339. "-bd 0  "
  340. "-setgrid $options(-setgrid)  "
  341. "-exportselection false  "
  342. "-selectmode $options(-selectmode)  "
  343. "-highlightthickness 0  "
  344. "]\n"
  345. "set label      "
  346. "[label $frame.label  "
  347. "-takefocus 0  "
  348. "-relief raised  "
  349. "-bd 1  "
  350. "-highlightthickness 0  "
  351. "]\n"
  352. "set columnID($label) $id\n"
  353. "set columnID($frame) $id\n"
  354. "set columnID($listbox) $id\n"
  355. "set tag MclistboxLabel\n"
  356. "bindtags $label  [list MclistboxMouseBindings $label]\n"
  357. "foreach option [list bd image height relief font anchor  "
  358. "background foreground borderwidth] {\n"
  359. "if {[info exists options(-label$option)]  "
  360. "&& $options(-label$option) != \"\"} {\n"
  361. "$label configure -$option $options(-label$option)\n"
  362. "}\n"
  363. "}\n"
  364. "foreach option [list borderwidth relief] {\n"
  365. "if {[info exists options(-column$option)]  "
  366. "&& $options(-column$option) != \"\"} {\n"
  367. "$frame configure -$option $options(-column$option)\n"
  368. "}\n"
  369. "}\n"
  370. "pack propagate $frame off\n"
  371. "pack $label   -side top -fill x -expand n\n"
  372. "pack $listbox -side top -fill both -expand y -pady 2\n"
  373. "bindtags $listbox [list $w Mclistbox all]\n"
  374. "return [list $frame $listbox $label]\n"
  375. "}\n"
  376. "proc ::mclistbox::Column-add {w args} {\n"
  377. "upvar ::mclistbox::${w}::widgets widgets\n"
  378. "upvar ::mclistbox::${w}::options options\n"
  379. "upvar ::mclistbox::${w}::misc    misc\n"
  380. "variable widgetOptions\n"
  381. "set id \"column-[llength $misc(columns)]\" ;# a suitable default\n"
  382. "if {![string match {-*} [lindex $args 0]]} {\n"
  383. "set id [lindex $args 0]\n"
  384. "set args [lrange $args 1 end]\n"
  385. "if {[lsearch -exact $misc(columns) $id] != -1} {\n"
  386. "error \"column \\\"$id\\\" already exists\"\n"
  387. "}\n"
  388. "}\n"
  389. "set opts(-bitmap)     {}\n"
  390. "set opts(-image)      {}\n"
  391. "set opts(-visible)    1\n"
  392. "set opts(-resizable)  1\n"
  393. "set opts(-position)   \"end\"\n"
  394. "set opts(-width)      20\n"
  395. "set opts(-background) $options(-background)\n"
  396. "set opts(-foreground) $options(-foreground)\n"
  397. "set opts(-font)       $options(-font)\n"
  398. "set opts(-label)      $id\n"
  399. "if {[expr {[llength $args]%2}] == 1} {\n"
  400. "set option [::mclistbox::Canonize $w \"column option\" [lindex $args end]]\n"
  401. "error \"value for \\\"[lindex $args end]\\\" missing\"\n"
  402. "}\n"
  403. "array set opts $args\n"
  404. "if {[llength $misc(columns)] > 0} {\n"
  405. "set col0 [lindex $misc(columns) 0]\n"
  406. "set existingRows [$widgets(listbox$col0) size]\n"
  407. "} else {\n"
  408. "set existingRows 0\n"
  409. "}\n"
  410. "set widgetlist [NewColumn $w $id]\n"
  411. "set widgets(frame$id)   [lindex $widgetlist 0]\n"
  412. "set widgets(listbox$id) [lindex $widgetlist 1]\n"
  413. "set widgets(label$id)   [lindex $widgetlist 2]\n"
  414. "lappend misc(columns) $id\n"
  415. "eval ::mclistbox::Column-configure {$w} {$id} [array get opts]\n"
  416. "if {$existingRows > 0} {\n"
  417. "set blanks {}\n"
  418. "for {set i 0} {$i < $existingRows} {incr i} {\n"
  419. "lappend blanks {}\n"
  420. "}\n"
  421. "eval {$widgets(listbox$id)} insert end $blanks\n"
  422. "}\n"
  423. "InvalidateScrollbars $w\n"
  424. "return $id\n"
  425. "}\n"
  426. "proc ::mclistbox::Column-configure {w id args} {\n"
  427. "variable widgetOptions\n"
  428. "variable columnOptions\n"
  429. "upvar ::mclistbox::${w}::widgets widgets\n"
  430. "upvar ::mclistbox::${w}::options options\n"
  431. "upvar ::mclistbox::${w}::misc    misc\n"
  432. "set index [CheckColumnID $w $id]\n"
  433. "set listbox $widgets(listbox$id)\n"
  434. "set frame   $widgets(frame$id)\n"
  435. "set label   $widgets(label$id)\n"
  436. "if {[llength $args] == 0} {\n"
  437. "set results {}\n"
  438. "foreach opt [lsort [array names columnOptions]] {\n"
  439. "if {[llength $columnOptions($opt)] == 1} {\n"
  440. "set alias $columnOptions($opt)\n"
  441. "set optName $columnOptions($alias)\n"
  442. "lappend results [list $opt $optName]\n"
  443. "} else {\n"
  444. "set optName  [lindex $columnOptions($opt) 0]\n"
  445. "set optClass [lindex $columnOptions($opt) 1]\n"
  446. "set default [option get $frame $optName $optClass]\n"
  447. "lappend results [list $opt $optName $optClass  "
  448. "$default $options($id:$opt)]\n"
  449. "}\n"
  450. "}\n"
  451. "return $results\n"
  452. "} elseif {[llength $args] == 1} {\n"
  453. "set option [::mclistbox::Canonize $w \"column option\" [lindex $args 0]]\n"
  454. "set value $options($id:$option)\n"
  455. "set optName  [lindex $columnOptions($option) 0]\n"
  456. "set optClass [lindex $columnOptions($option) 1]\n"
  457. "set default  [option get $frame $optName $optClass]\n"
  458. "set results  [list $option $optName $optClass $default $value]\n"
  459. "return $results\n"
  460. "}\n"
  461. "if {[expr {[llength $args]%2}] == 1} {\n"
  462. "error \"value for \\\"[lindex $args end]\\\" missing\"\n"
  463. "}\n"
  464. "foreach {name value} $args {\n"
  465. "set name [::mclistbox::Canonize $w \"column option\" $name]\n"
  466. "set opts($name) $value\n"
  467. "}\n"
  468. "foreach option [array names opts] {\n"
  469. "set value $opts($option)\n"
  470. "set options($id:$option) $value\n"
  471. "switch -- $option {\n"
  472. "-label {\n"
  473. "$label configure -text $value\n"
  474. "}\n"
  475. "-image -\n"
  476. "-bitmap {\n"
  477. "$label configure $option $value\n"
  478. "}\n"
  479. "-width {\n"
  480. "set font [$listbox cget -font]\n"
  481. "set factor [font measure $options(-font) \"0\"]\n"
  482. "set width [expr {$value * $factor}]\n"
  483. "$widgets(frame$id) configure -width $width\n"
  484. "set misc(min-$widgets(frame$id)) $width\n"
  485. "AdjustColumns $w\n"
  486. "}\n"
  487. "-font -\n"
  488. "-foreground -\n"
  489. "-background {\n"
  490. "if {[string length $value] == 0} {set value $options($option)}\n"
  491. "$listbox configure $option $value\n"
  492. "}\n"
  493. "-resizable {\n"
  494. "if {[catch {\n"
  495. "if {$value} {\n"
  496. "set options($id:-resizable) 1\n"
  497. "} else {\n"
  498. "set options($id:-resizable) 0\n"
  499. "}\n"
  500. "} msg]} {\n"
  501. "error \"expected boolean but got \\\"$value\\\"\"\n"
  502. "}\n"
  503. "}\n"
  504. "-visible {\n"
  505. "if {[catch {\n"
  506. "if {$value} {\n"
  507. "set options($id:-visible) 1\n"
  508. "$widgets(text) configure -state normal\n"
  509. "$widgets(text) window configure 1.$index -window $frame\n"
  510. "$widgets(text) configure -state disabled\n"
  511. "} else {\n"
  512. "set options($id:-visible) 0\n"
  513. "$widgets(text) configure -state normal\n"
  514. "$widgets(text) window configure 1.$index -window {}\n"
  515. "$widgets(text) configure -state disabled\n"
  516. "}\n"
  517. "InvalidateScrollbars $w\n"
  518. "} msg]} {\n"
  519. "error \"expected boolean but got \\\"$value\\\"\"\n"
  520. "}\n"
  521. "}\n"
  522. "-position {\n"
  523. "if {[string compare $value \"start\"] == 0} {\n"
  524. "set position 0\n"
  525. "} elseif {[string compare $value \"end\"] == 0} {\n"
  526. "set position [expr {[llength $misc(columns)] -1}]\n"
  527. "} else {\n"
  528. "set position $value\n"
  529. "}\n"
  530. "if {$position >= [llength $misc(columns)]} {\n"
  531. "set max [expr {[llength $misc(columns)] -1}]\n"
  532. "error \"bad position; must be in the range of 0-$max\"\n"
  533. "}\n"
  534. "set current [lsearch -exact $misc(columns) $id]\n"
  535. "set misc(columns) [lreplace $misc(columns) $current $current]\n"
  536. "set misc(columns) [linsert $misc(columns) $position $id]\n"
  537. "set frame $widgets(frame$id)\n"
  538. "$widgets(text) configure -state normal\n"
  539. "$widgets(text) window create 1.$position  "
  540. "-window $frame -stretch 1\n"
  541. "$widgets(text) configure -state disabled\n"
  542. "}\n"
  543. "}\n"
  544. "}\n"
  545. "}\n";
  546. char *ExtensionSource1 =
  547. "proc ::mclistbox::DestroyHandler {w} {\n"
  548. "if {[info exists ::mclistbox::${w}::misc(afterid)]} {\n"
  549. "catch {\n"
  550. "after cancel $::mclistbox::${w}::misc(afterid)\n"
  551. "unset ::mclistbox::${w}::misc(afterid)\n"
  552. "}\n"
  553. "}\n"
  554. "if {[string compare [winfo class $w] \"Mclistbox\"] == 0} {\n"
  555. "namespace delete ::mclistbox::$w\n"
  556. "rename $w {}\n"
  557. "}\n"
  558. "}\n"
  559. "proc ::mclistbox::MassageIndex {w index} {\n"
  560. "upvar ::mclistbox::${w}::widgets   widgets\n"
  561. "upvar ::mclistbox::${w}::misc      misc\n"
  562. "if {[regexp {@([0-9]+),([0-9]+)} $index matchvar x y]} {\n"
  563. "set id [lindex $misc(columns) 0]\n"
  564. "incr y -[winfo y $widgets(listbox$id)]\n"
  565. "incr y -[winfo y $widgets(frame$id)]\n"
  566. "incr x [winfo x $widgets(listbox$id)]\n"
  567. "incr x [winfo x $widgets(frame$id)]\n"
  568. "set index @${x},${y}\n"
  569. "}\n"
  570. "return $index\n"
  571. "}\n"
  572. "proc ::mclistbox::WidgetProc {w command args} {\n"
  573. "variable widgetOptions\n"
  574. "upvar ::mclistbox::${w}::widgets   widgets\n"
  575. "upvar ::mclistbox::${w}::options   options\n"
  576. "upvar ::mclistbox::${w}::misc      misc\n"
  577. "upvar ::mclistbox::${w}::columnID  columnID\n"
  578. "set command [::mclistbox::Canonize $w command $command]\n"
  579. "if {[string compare $command \"column\"] == 0} {\n"
  580. "set subcommand [::mclistbox::Canonize $w \"column command\"  "
  581. "[lindex $args 0]]\n"
  582. "set command \"$command-$subcommand\"\n"
  583. "set args [lrange $args 1 end]\n"
  584. "} elseif {[string compare $command \"label\"] == 0} {\n"
  585. "set subcommand [::mclistbox::Canonize $w \"label command\"  "
  586. "[lindex $args 0]]\n"
  587. "set command \"$command-$subcommand\"\n"
  588. "set args [lrange $args 1 end]\n"
  589. "}\n"
  590. "set result \"\"\n"
  591. "catch {unset priorSelection}\n"
  592. "switch $command {\n"
  593. "xview {\n"
  594. "set result [eval {$widgets(text)} xview $args]\n"
  595. "InvalidateScrollbars $w\n"
  596. "}\n"
  597. "yview {\n"
  598. "if {[llength $args] == 0} {\n"
  599. "set result [$widgets(hiddenListbox) yview]\n"
  600. "} else {\n"
  601. "if {[llength $args] == 1} {\n"
  602. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  603. "set args [list $index]\n"
  604. "}\n"
  605. "foreach id $misc(columns) {\n"
  606. "eval {$widgets(listbox$id)} yview $args\n"
  607. "}\n"
  608. "eval {$widgets(hiddenListbox)} yview $args\n"
  609. "InvalidateScrollbars $w\n"
  610. "set result \"\"\n"
  611. "}\n"
  612. "}\n"
  613. "activate {\n"
  614. "if {[llength $args] != 1} {\n"
  615. "error \"wrong \\# of args: should be $w activate index\"\n"
  616. "}\n"
  617. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  618. "foreach id $misc(columns) {\n"
  619. "$widgets(listbox$id) activate $index\n"
  620. "}\n"
  621. "set result \"\"\n"
  622. "}\n"
  623. "bbox {\n"
  624. "if {[llength $args] != 1} {\n"
  625. "error \"wrong \\# of args: should be $w bbox index\"\n"
  626. "}\n"
  627. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  628. "set id [lindex $misc(columns) 0]\n"
  629. "set bbox [$widgets(listbox$id) bbox $index]\n"
  630. "if {[string length $bbox] == 0} {return \"\"}\n"
  631. "foreach {x y w h} $bbox {}\n"
  632. "incr y [winfo y $widgets(listbox$id)]\n"
  633. "incr y [winfo y $widgets(frame$id)]\n"
  634. "incr x [winfo x $widgets(listbox$id)]\n"
  635. "incr x [winfo x $widgets(frame$id)]\n"
  636. "set id [lindex $misc(columns) end]\n"
  637. "set w [expr {[winfo width $widgets(frame$id)] +  "
  638. "[winfo x $widgets(frame$id)]}]\n"
  639. "set bbox [list $x $y [expr {$x + $w}] $h]\n"
  640. "set result $bbox\n"
  641. "}\n"
  642. "label-bind {\n"
  643. "set id [lindex $args 0]\n"
  644. "set index [CheckColumnID $w $id]\n"
  645. "set args [lrange $args 1 end]\n"
  646. "if {[llength $args] == 0} {\n"
  647. "set result [bind $widgets(label$id)]\n"
  648. "} else {\n"
  649. "set sequence [lindex $args 0]\n"
  650. "if {[llength $args] == 1} {\n"
  651. "set result [lindex [bind $widgets(label$id) $sequence] end]\n"
  652. "} else {\n"
  653. "set code [lindex $args 1]\n"
  654. "regsub -all {%W} $code $w code\n"
  655. "set result [bind $widgets(label$id) $sequence  "
  656. "[list ::mclistbox::LabelEvent $w $id $code]]\n"
  657. "}\n"
  658. "}\n"
  659. "}\n"
  660. "column-add {\n"
  661. "eval ::mclistbox::Column-add {$w} $args\n"
  662. "AdjustColumns $w\n"
  663. "set result \"\"\n"
  664. "}\n"
  665. "column-delete {\n"
  666. "foreach id $args {\n"
  667. "set index [CheckColumnID $w $id]\n"
  668. "set misc(columns) [lreplace $misc(columns) $index $index]\n"
  669. "destroy $widgets(frame$id)\n"
  670. "unset widgets(frame$id)\n"
  671. "unset widgets(listbox$id)\n"
  672. "unset widgets(label$id)\n"
  673. "}\n"
  674. "InvalidateScrollbars $w\n"
  675. "set result \"\"\n"
  676. "}\n"
  677. "column-cget {\n"
  678. "if {[llength $args] != 2} {\n"
  679. "error \"wrong # of args: should be \\\"$w column cget name option\\\"\"\n"
  680. "}\n"
  681. "set id [::mclistbox::Canonize $w column [lindex $args 0]]\n"
  682. "set option [lindex $args 1]\n"
  683. "set data [::mclistbox::Column-configure $w $id $option]\n"
  684. "set result [lindex $data 4]\n"
  685. "}\n"
  686. "column-configure {\n"
  687. "set id [::mclistbox::Canonize $w column [lindex $args 0]]\n"
  688. "set args [lrange $args 1 end]\n"
  689. "set result [eval ::mclistbox::Column-configure {$w} {$id} $args]\n"
  690. "}\n"
  691. "column-names {\n"
  692. "if {[llength $args] != 0} {\n"
  693. "error \"wrong # of args: should be \\\"$w column names\\\"\"\n"
  694. "}\n"
  695. "set result $misc(columns)\n"
  696. "}\n"
  697. "column-nearest {\n"
  698. "if {[llength $args] != 1} {\n"
  699. "error \"wrong # of args: should be \\\"$w column nearest x\\\"\"\n"
  700. "}\n"
  701. "set x [lindex $args 0]\n"
  702. "set tmp [$widgets(text) index @$x,0]\n"
  703. "set tmp [split $tmp \".\"]\n"
  704. "set index [lindex $tmp 1]\n"
  705. "set result [lindex $misc(columns) $index]\n"
  706. "}\n"
  707. "cget {\n"
  708. "if {[llength $args] != 1} {\n"
  709. "error \"wrong # args: should be $w cget option\"\n"
  710. "}\n"
  711. "set opt [::mclistbox::Canonize $w option [lindex $args 0]]\n"
  712. "set result $options($opt)\n"
  713. "}\n"
  714. "configure {\n"
  715. "set result [eval ::mclistbox::Configure {$w} $args]\n"
  716. "}\n"
  717. "curselection {\n"
  718. "set id [lindex $misc(columns) 0]\n"
  719. "set result [$widgets(listbox$id) curselection]\n"
  720. "}\n"
  721. "delete {\n"
  722. "if {[llength $args] < 1 || [llength $args] > 2} {\n"
  723. "error \"wrong \\# of args: should be $w delete first ?last?\"\n"
  724. "}\n"
  725. "if {$options(-selectcommand) != \"\"} {\n"
  726. "set col0 [lindex $misc(columns) 0]\n"
  727. "set priorSelection [$widgets(listbox$col0) curselection]\n"
  728. "}\n"
  729. "set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  730. "if {[llength $args] == 2} {\n"
  731. "set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]\n"
  732. "} else {\n"
  733. "set index2 \"\"\n"
  734. "}\n"
  735. "foreach id $misc(columns) {\n"
  736. "eval {$widgets(listbox$id)} delete $index1 $index2\n"
  737. "}\n"
  738. "eval {$widgets(hiddenListbox)} delete $index1 $index2\n"
  739. "InvalidateScrollbars $w\n"
  740. "set result \"\"\n"
  741. "}\n"
  742. "get {\n"
  743. "if {[llength $args] < 1 || [llength $args] > 2} {\n"
  744. "error \"wrong \\# of args: should be $w get first ?last?\"\n"
  745. "}\n"
  746. "set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  747. "if {[llength $args] == 2} {\n"
  748. "set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]\n"
  749. "} else {\n"
  750. "set index2 \"\"\n"
  751. "}\n"
  752. "set result [eval ::mclistbox::WidgetProc-get {$w} $index1 $index2]\n"
  753. "}\n"
  754. "index {\n"
  755. "if {[llength $args] != 1} {\n"
  756. "error \"wrong \\# of args: should be $w index index\"\n"
  757. "}\n"
  758. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  759. "set id [lindex $misc(columns) 0]\n"
  760. "set result [$widgets(listbox$id) index $index]\n"
  761. "}\n"
  762. "insert {\n"
  763. "if {[llength $args] < 1} {\n"
  764. "error \"wrong \\# of args: should be $w insert ?element  "
  765. "element...?\"\n"
  766. "}\n"
  767. "if {$options(-selectcommand) != \"\"} {\n"
  768. "set col0 [lindex $misc(columns) 0]\n"
  769. "set priorSelection [$widgets(listbox$col0) curselection]\n"
  770. "}\n"
  771. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  772. "::mclistbox::Insert $w $index [lrange $args 1 end]\n"
  773. "InvalidateScrollbars $w\n"
  774. "set result \"\"\n"
  775. "}\n"
  776. "itemconfigure {\n"
  777. "if {[llength $args] < 2} {\n"
  778. "error \"wrong \\# of args: should be $w itemconfigure index option ?option...?\"\n"
  779. "}\n"
  780. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  781. "set newargs [lreplace $args 0 0]\n"
  782. "set result [eval ::mclistbox::ItemConfigure {$w} $index $newargs]\n"
  783. "}\n"
  784. "nearest {\n"
  785. "if {[llength $args] != 1} {\n"
  786. "error \"wrong \\# of args: should be $w nearest y\"\n"
  787. "}\n"
  788. "set id [lindex $misc(columns) 0]\n"
  789. "set y [lindex $args 0]\n"
  790. "incr y -[winfo y $widgets(listbox$id)]\n"
  791. "incr y -[winfo y $widgets(frame$id)]\n"
  792. "set col0 [lindex $misc(columns) 0]\n"
  793. "set result [$widgets(listbox$col0) nearest $y]\n"
  794. "}\n"
  795. "scan {\n"
  796. "foreach {subcommand x y} $args {}\n"
  797. "switch $subcommand {\n"
  798. "mark {\n"
  799. "set misc(scanmarkx) $x\n"
  800. "set misc(scanmarky) $y\n"
  801. "foreach id $misc(columns) {\n"
  802. "$widgets(listbox$id) scan mark $x $y\n"
  803. "}\n"
  804. "$widgets(text) scan mark [winfo pointerx $w]  $y\n"
  805. "}\n"
  806. "dragto {\n"
  807. "foreach id $misc(columns) {\n"
  808. "$widgets(listbox$id) scan dragto $misc(scanmarkx) $y\n"
  809. "}\n"
  810. "$widgets(text) scan dragto  "
  811. "[winfo pointerx $w] $misc(scanmarky)\n"
  812. "InvalidateScrollbars $w\n"
  813. "}\n"
  814. "set result \"\"\n"
  815. "}\n"
  816. "}\n"
  817. "see {\n"
  818. "if {[llength $args] != 1} {\n"
  819. "error \"wrong \\# of args: should be $w see index\"\n"
  820. "}\n"
  821. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  822. "foreach id $misc(columns) {\n"
  823. "$widgets(listbox$id) see $index\n"
  824. "}\n"
  825. "InvalidateScrollbars $w\n"
  826. "set result {}\n"
  827. "}\n"
  828. "selection {\n"
  829. "if {$options(-selectcommand) != \"\"} {\n"
  830. "set col0 [lindex $misc(columns) 0]\n"
  831. "set priorSelection [$widgets(listbox$col0) curselection]\n"
  832. "}\n"
  833. "set subcommand [lindex $args 0]\n"
  834. "set args [lrange $args 1 end]\n"
  835. "set prefix \"wrong \\# of args: should be $w\"\n"
  836. "switch $subcommand {\n"
  837. "includes {\n"
  838. "if {[llength $args] != 1} {\n"
  839. "error \"$prefix selection $subcommand index\"\n"
  840. "}\n"
  841. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  842. "set id [lindex $misc(columns) 0]\n"
  843. "set result [$widgets(listbox$id) selection includes $index]\n"
  844. "}\n"
  845. "set {\n"
  846. "switch [llength $args] {\n"
  847. "1 {\n"
  848. "set index1 [::mclistbox::MassageIndex $w  "
  849. "[lindex $args 0]]\n"
  850. "set index2 \"\"\n"
  851. "}\n"
  852. "2 {\n"
  853. "set index1 [::mclistbox::MassageIndex $w  "
  854. "[lindex $args 0]]\n"
  855. "set index2 [::mclistbox::MassageIndex $w  "
  856. "[lindex $args 1]]\n"
  857. "}\n"
  858. "default {\n"
  859. "error \"$prefix selection clear first ?last?\"\n"
  860. "}\n"
  861. "}\n"
  862. "if {$options(-exportselection)} {\n"
  863. "SelectionHandler $w own\n"
  864. "}\n"
  865. "if {$index1 != \"\"} {\n"
  866. "foreach id $misc(columns) {\n"
  867. "eval {$widgets(listbox$id)} selection set  "
  868. "$index1 $index2\n"
  869. "}\n"
  870. "}\n"
  871. "set result \"\"\n"
  872. "}\n"
  873. "anchor {\n"
  874. "if {[llength $args] != 1} {\n"
  875. "error \"$prefix selection $subcommand index\"\n"
  876. "}\n"
  877. "set index [::mclistbox::MassageIndex $w [lindex $args 0]]\n"
  878. "if {$options(-exportselection)} {\n"
  879. "SelectionHandler $w own\n"
  880. "}\n"
  881. "foreach id $misc(columns) {\n"
  882. "$widgets(listbox$id) selection anchor $index\n"
  883. "}\n"
  884. "set result \"\"\n"
  885. "}\n"
  886. "clear {\n"
  887. "switch [llength $args] {\n"
  888. "1 {\n"
  889. "set index1 [::mclistbox::MassageIndex $w  "
  890. "[lindex $args 0]]\n"
  891. "set index2 \"\"\n"
  892. "}\n"
  893. "2 {\n"
  894. "set index1 [::mclistbox::MassageIndex $w  "
  895. "[lindex $args 0]]\n"
  896. "set index2 [::mclistbox::MassageIndex $w  "
  897. "[lindex $args 1]]\n"
  898. "}\n"
  899. "default {\n"
  900. "error \"$prefix selection clear first ?last?\"\n"
  901. "}\n"
  902. "}\n"
  903. "if {$options(-exportselection)} {\n"
  904. "SelectionHandler $w own\n"
  905. "}\n"
  906. "foreach id $misc(columns) {\n"
  907. "eval {$widgets(listbox$id)} selection clear  "
  908. "$index1 $index2\n"
  909. "}\n"
  910. "set result \"\"\n"
  911. "}\n"
  912. "}\n"
  913. "}\n"
  914. "size {\n"
  915. "set id [lindex $misc(columns) 0]\n"
  916. "set result [$widgets(listbox$id) size]\n"
  917. "}\n"
  918. "}\n"
  919. "if {[info exists priorSelection] && $options(-selectcommand) != \"\"} {\n"
  920. "set column [lindex $misc(columns) 0]\n"
  921. "set currentSelection [$widgets(listbox$column) curselection]\n"
  922. "if {[string compare $priorSelection $currentSelection] != 0} {\n"
  923. "if {![info exists misc(skipRecursiveCall)]} {\n"
  924. "set misc(skipRecursiveCall) 1\n"
  925. "uplevel \\#0 $options(-selectcommand) $currentSelection\n"
  926. "catch {unset misc(skipRecursiveCall)}\n"
  927. "}\n"
  928. "}\n"
  929. "}\n"
  930. "return $result\n"
  931. "}\n"
  932. "proc ::mclistbox::WidgetProc-get {w args} {\n"
  933. "upvar ::mclistbox::${w}::widgets widgets\n"
  934. "upvar ::mclistbox::${w}::options options\n"
  935. "upvar ::mclistbox::${w}::misc    misc\n"
  936. "set returnType \"list\"\n"
  937. "if {[llength $args] == 1} {\n"
  938. "lappend args [lindex $args 0]\n"
  939. "set returnType \"listOfLists\"\n"
  940. "}\n"
  941. "foreach id $misc(columns) {\n"
  942. "set data($id) [eval {$widgets(listbox$id)} get $args]\n"
  943. "}\n"
  944. "set result {}\n"
  945. "set rows [llength $data($id)]\n"
  946. "for {set i 0} {$i < $rows} {incr i} {\n"
  947. "set this {}\n"
  948. "foreach column $misc(columns) {\n"
  949. "lappend this [lindex $data($column) $i]\n"
  950. "}\n"
  951. "lappend result $this\n"
  952. "}\n"
  953. "if {[string compare $returnType \"list\"] == 0} {\n"
  954. "return $result\n"
  955. "} else {\n"
  956. "return [lindex $result 0]\n"
  957. "}\n"
  958. "}\n"
  959. "proc ::mclistbox::CheckColumnID {w id} {\n"
  960. "upvar ::mclistbox::${w}::misc    misc\n"
  961. "set id [::mclistbox::Canonize $w column $id]\n"
  962. "set index [lsearch -exact $misc(columns) $id]\n"
  963. "return $index\n"
  964. "}\n"
  965. "proc ::mclistbox::LabelEvent {w id code} {\n"
  966. "upvar ::mclistbox::${w}::widgets widgets\n"
  967. "upvar ::mclistbox::${w}::options options\n"
  968. "set cursor [$widgets(label$id) cget -cursor]\n"
  969. "if {[string compare $cursor $options(-cursor)] == 0} {\n"
  970. "uplevel \\#0 $code\n"
  971. "}\n"
  972. "}\n"
  973. "proc ::mclistbox::HumanizeList {list} {\n"
  974. "if {[llength $list] == 1} {\n"
  975. "return [lindex $list 0]\n"
  976. "} else {\n"
  977. "set list [lsort $list]\n"
  978. "set secondToLast [expr {[llength $list] -2}]\n"
  979. "set most [lrange $list 0 $secondToLast]\n"
  980. "set last [lindex $list end]\n"
  981. "return \"[join $most {, }] or $last\"\n"
  982. "}\n"
  983. "}\n"
  984. "proc ::mclistbox::Canonize {w object opt} {\n"
  985. "variable widgetOptions\n"
  986. "variable columnOptions\n"
  987. "variable widgetCommands\n"
  988. "variable columnCommands\n"
  989. "variable labelCommands\n"
  990. "switch $object {\n"
  991. "command {\n"
  992. "if {[lsearch -exact $widgetCommands $opt] >= 0} {\n"
  993. "return $opt\n"
  994. "}\n"
  995. "set list $widgetCommands\n"
  996. "foreach element $list {\n"
  997. "set tmp($element) \"\"\n"
  998. "}\n"
  999. "set matches [array names tmp ${opt}*]\n"
  1000. "}\n"
  1001. "{label command} {\n"
  1002. "if {[lsearch -exact $labelCommands $opt] >= 0} {\n"
  1003. "return $opt\n"
  1004. "}\n"
  1005. "set list $labelCommands\n"
  1006. "foreach element $list {\n"
  1007. "set tmp($element) \"\"\n"
  1008. "}\n"
  1009. "set matches [array names tmp ${opt}*]\n"
  1010. "}\n"
  1011. "{column command} {\n"
  1012. "if {[lsearch -exact $columnCommands $opt] >= 0} {\n"
  1013. "return $opt\n"
  1014. "}\n"
  1015. "set list $columnCommands\n"
  1016. "foreach element $list {\n"
  1017. "set tmp($element) \"\"\n"
  1018. "}\n"
  1019. "set matches [array names tmp ${opt}*]\n"
  1020. "}\n"
  1021. "option {\n"
  1022. "if {[info exists widgetOptions($opt)]  "
  1023. "&& [llength $widgetOptions($opt)] == 3} {\n"
  1024. "return $opt\n"
  1025. "}\n"
  1026. "set list [array names widgetOptions]\n"
  1027. "set matches [array names widgetOptions ${opt}*]\n"
  1028. "}\n"
  1029. "{column option} {\n"
  1030. "if {[info exists columnOptions($opt)]} {\n"
  1031. "return $opt\n"
  1032. "}\n"
  1033. "set list [array names columnOptions]\n"
  1034. "set matches [array names columnOptions ${opt}*]\n"
  1035. "}\n"
  1036. "column {\n"
  1037. "upvar ::mclistbox::${w}::misc    misc\n"
  1038. "if {[lsearch -exact $misc(columns) $opt] != -1} {\n"
  1039. "return $opt\n"
  1040. "}\n"
  1041. "set list $misc(columns)\n"
  1042. "foreach element $misc(columns) {\n"
  1043. "set tmp($element) \"\"\n"
  1044. "}\n"
  1045. "set matches [array names tmp ${opt}*]\n"
  1046. "}\n"
  1047. "}\n"
  1048. "if {[llength $matches] == 0} {\n"
  1049. "set choices [HumanizeList $list]\n"
  1050. "error \"unknown $object \\\"$opt\\\"; must be one of $choices\"\n"
  1051. "} elseif {[llength $matches] == 1} {\n"
  1052. "set opt [lindex $matches 0]\n"
  1053. "switch $object {\n"
  1054. "option {\n"
  1055. "if {[llength $widgetOptions($opt)] == 1} {\n"
  1056. "set opt $widgetOptions($opt)\n"
  1057. "}\n"
  1058. "}\n"
  1059. "{column option} {\n"
  1060. "if {[llength $columnOptions($opt)] == 1} {\n"
  1061. "set opt $columnOptions($opt)\n"
  1062. "}\n"
  1063. "}\n"
  1064. "}\n"
  1065. "return $opt\n"
  1066. "} else {\n"
  1067. "set choices [HumanizeList $list]\n"
  1068. "error \"ambiguous $object \\\"$opt\\\"; must be one of $choices\"\n"
  1069. "}\n"
  1070. "}\n"
  1071. "proc ::mclistbox::Configure {w args} {\n"
  1072. "variable widgetOptions\n"
  1073. "upvar ::mclistbox::${w}::widgets widgets\n"
  1074. "upvar ::mclistbox::${w}::options options\n"
  1075. "upvar ::mclistbox::${w}::misc    misc\n"
  1076. "if {[llength $args] == 0} {\n"
  1077. "set results {}\n"
  1078. "foreach opt [lsort [array names widgetOptions]] {\n"
  1079. "if {[llength $widgetOptions($opt)] == 1} {\n"
  1080. "set alias $widgetOptions($opt)\n"
  1081. "set optName $widgetOptions($alias)\n"
  1082. "lappend results [list $opt $optName]\n"
  1083. "} else {\n"
  1084. "set optName  [lindex $widgetOptions($opt) 0]\n"
  1085. "set optClass [lindex $widgetOptions($opt) 1]\n"
  1086. "set default [option get $w $optName $optClass]\n"
  1087. "lappend results [list $opt $optName $optClass  "
  1088. "$default $options($opt)]\n"
  1089. "}\n"
  1090. "}\n"
  1091. "return $results\n"
  1092. "}\n"
  1093. "if {[llength $args] == 1} {\n"
  1094. "set opt [::mclistbox::Canonize $w option [lindex $args 0]]\n"
  1095. "set optName  [lindex $widgetOptions($opt) 0]\n"
  1096. "set optClass [lindex $widgetOptions($opt) 1]\n"
  1097. "set default [option get $w $optName $optClass]\n"
  1098. "set results [list $opt $optName $optClass  "
  1099. "$default $options($opt)]\n"
  1100. "return $results\n"
  1101. "}\n"
  1102. "if {[expr {[llength $args]%2}] == 1} {\n"
  1103. "error \"value for \\\"[lindex $args end]\\\" missing\"\n"
  1104. "}\n"
  1105. "foreach {name value} $args {\n"
  1106. "set name [::mclistbox::Canonize $w option $name]\n"
  1107. "set opts($name) $value\n"
  1108. "}\n"
  1109. "foreach option [array names opts] {\n"
  1110. "set newValue $opts($option)\n"
  1111. "if {[info exists options($option)]} {\n"
  1112. "set oldValue $options($option)\n"
  1113. "}\n"
  1114. "switch -- $option {\n"
  1115. "-exportselection {\n"
  1116. "if {$newValue} {\n"
  1117. "SelectionHandler $w own\n"
  1118. "set options($option) 1\n"
  1119. "} else {\n"
  1120. "set options($option) 0\n"
  1121. "}\n"
  1122. "}\n"
  1123. "-fillcolumn {\n"
  1124. "AdjustColumns $w\n"
  1125. "set options($option) $newValue\n"
  1126. "}\n"
  1127. "-takefocus {\n"
  1128. "$widgets(frame) configure -takefocus $newValue\n"
  1129. "set options($option) [$widgets(frame) cget $option]\n"
  1130. "}\n"
  1131. "-background {\n"
  1132. "foreach id $misc(columns) {\n"
  1133. "$widgets(listbox$id) configure -background $newValue\n"
  1134. "$widgets(frame$id) configure   -background $newValue\n"
  1135. "}\n"
  1136. "$widgets(frame) configure -background $newValue\n"
  1137. "$widgets(text) configure -background $newValue\n"
  1138. "set options($option) [$widgets(frame) cget $option]\n"
  1139. "}\n"
  1140. "-foreground -\n"
  1141. "-font -\n"
  1142. "-selectborderwidth -\n"
  1143. "-selectforeground -\n"
  1144. "-selectbackground -\n"
  1145. "-setgrid {\n"
  1146. "foreach id $misc(columns) {\n"
  1147. "$widgets(listbox$id) configure $option $newValue\n"
  1148. "}\n"
  1149. "$widgets(hiddenListbox) configure $option $newValue\n"
  1150. "set options($option) [$widgets(hiddenListbox) cget $option]\n"
  1151. "}\n"
  1152. "-cursor {\n"
  1153. "foreach id $misc(columns) {\n"
  1154. "$widgets(listbox$id) configure $option $newValue\n"
  1155. "$widgets(frame$id) configure -cursor $newValue\n"
  1156. "}\n"
  1157. "foreach id $misc(columns) {\n"
  1158. "$widgets(frame$id) configure -cursor $newValue\n"
  1159. "}\n"
  1160. "$widgets(hiddenListbox) configure $option $newValue\n"
  1161. "set options($option) [$widgets(hiddenListbox) cget $option]\n"
  1162. "}\n"
  1163. "-labels {\n"
  1164. "if {$newValue} {\n"
  1165. "set newValue 1\n"
  1166. "foreach id $misc(columns) {\n"
  1167. "pack $widgets(label$id)  "
  1168. "-side top -fill x -expand n  "
  1169. "-before $widgets(listbox$id)\n"
  1170. "}\n"
  1171. "pack $widgets(hiddenLabel)  "
  1172. "-side top -fill x -expand n  "
  1173. "-before $widgets(hiddenListbox)\n"
  1174. "} else {\n"
  1175. "set newValue\n"
  1176. "foreach id $misc(columns) {\n"
  1177. "pack forget $widgets(label$id)\n"
  1178. "}\n"
  1179. "pack forget $widgets(hiddenLabel)\n"
  1180. "}\n"
  1181. "set options($option) $newValue\n"
  1182. "}\n"
  1183. "-height {\n"
  1184. "$widgets(hiddenListbox) configure -height $newValue\n"
  1185. "InvalidateScrollbars $w\n"
  1186. "set options($option) [$widgets(hiddenListbox) cget $option]\n"
  1187. "}\n"
  1188. "-width {\n"
  1189. "if {$newValue == 0} {\n"
  1190. "error \"a -width of zero is not supported. \"\n"
  1191. "}\n"
  1192. "$widgets(hiddenListbox) configure -width $newValue\n"
  1193. "InvalidateScrollbars $w\n"
  1194. "set options($option) [$widgets(hiddenListbox) cget $option]\n"
  1195. "}\n"
  1196. "-columnborderwidth -\n"
  1197. "-columnrelief {\n"
  1198. "regsub {column} $option {} listboxoption\n"
  1199. "foreach id $misc(columns) {\n"
  1200. "$widgets(listbox$id) configure $listboxoption $newValue\n"
  1201. "}\n"
  1202. "$widgets(hiddenListbox) configure $listboxoption $newValue\n"
  1203. "set options($option) [$widgets(hiddenListbox) cget  "
  1204. "$listboxoption]\n"
  1205. "}\n"
  1206. "-resizablecolumns {\n"
  1207. "if {$newValue} {\n"
  1208. "set options($option) 1\n"
  1209. "} else {\n"
  1210. "set options($option) 0\n"
  1211. "}\n"
  1212. "}\n"
  1213. "-labelimage -\n"
  1214. "-labelheight -\n"
  1215. "-labelrelief -\n"
  1216. "-labelfont -\n"
  1217. "-labelanchor -\n"
  1218. "-labelbackground -\n"
  1219. "-labelforeground -\n"
  1220. "-labelborderwidth {\n"
  1221. "regsub {label} $option {} labeloption\n"
  1222. "foreach id $misc(columns) {\n"
  1223. "$widgets(label$id) configure $labeloption $newValue\n"
  1224. "}\n"
  1225. "$widgets(hiddenLabel) configure $labeloption $newValue\n"
  1226. "set options($option) [$widgets(hiddenLabel) cget $labeloption]\n"
  1227. "}\n"
  1228. "-borderwidth -\n"
  1229. "-highlightthickness -\n"
  1230. "-highlightcolor -\n"
  1231. "-highlightbackground -\n"
  1232. "-relief {\n"
  1233. "$widgets(frame) configure $option $newValue\n"
  1234. "set options($option) [$widgets(frame) cget $option]\n"
  1235. "}\n"
  1236. "-selectmode {\n"
  1237. "set options($option) $newValue\n"
  1238. "}\n"
  1239. "-selectcommand {\n"
  1240. "set options($option) $newValue\n"
  1241. "}\n"
  1242. "-xscrollcommand {\n"
  1243. "InvalidateScrollbars $w\n"
  1244. "set options($option) $newValue\n"
  1245. "}\n"
  1246. "-yscrollcommand {\n"
  1247. "InvalidateScrollbars $w\n"
  1248. "set options($option) $newValue\n"
  1249. "}\n"
  1250. "}\n"
  1251. "}\n"
  1252. "}\n"
  1253. "proc ::mclistbox::ItemConfigure {w index args} {\n"
  1254. "variable widgetOptions\n"
  1255. "upvar ::mclistbox::${w}::widgets widgets\n"
  1256. "upvar ::mclistbox::${w}::options options\n"
  1257. "upvar ::mclistbox::${w}::misc    misc\n"
  1258. "if {[llength $args] == 0} {\n"
  1259. "set results {}\n"
  1260. "foreach opt [lsort [array names widgetOptions]] {\n"
  1261. "if {[llength $widgetOptions($opt)] == 1} {\n"
  1262. "set alias $widgetOptions($opt)\n"
  1263. "set optName $widgetOptions($alias)\n"
  1264. "lappend results [list $opt $optName]\n"
  1265. "} else {\n"
  1266. "set optName  [lindex $widgetOptions($opt) 0]\n"
  1267. "set optClass [lindex $widgetOptions($opt) 1]\n"
  1268. "set default [option get $w $optName $optClass]\n"
  1269. "lappend results [list $opt $optName $optClass  "
  1270. "$default $options($opt)]\n"
  1271. "}\n"
  1272. "}\n"
  1273. "return $results\n"
  1274. "}\n"
  1275. "if {[llength $args] == 1} {\n"
  1276. "set opt [::mclistbox::Canonize $w option [lindex $args 0]]\n"
  1277. "set optName  [lindex $widgetOptions($opt) 0]\n"
  1278. "set optClass [lindex $widgetOptions($opt) 1]\n"
  1279. "set default [option get $w $optName $optClass]\n"
  1280. "set results [list $opt $optName $optClass  "
  1281. "$default $options($opt)]\n"
  1282. "return $results\n"
  1283. "}\n"
  1284. "if {[expr {[llength $args]%2}] == 1} {\n"
  1285. "error \"value for \\\"[lindex $args end]\\\" missing\"\n"
  1286. "}\n"
  1287. "foreach {name value} $args {\n"
  1288. "set name [::mclistbox::Canonize $w option $name]\n"
  1289. "set opts($name) $value\n"
  1290. "}\n"
  1291. "foreach option [array names opts] {\n"
  1292. "set newValue $opts($option)\n"
  1293. "if {[info exists options($option)]} {\n"
  1294. "set oldValue $options($option)\n"
  1295. "}\n"
  1296. "switch -- $option {\n"
  1297. "-background {\n"
  1298. "foreach id $misc(columns) {\n"
  1299. "$widgets(listbox$id) itemconfigure $index -background $newValue\n"
  1300. "$widgets(frame$id) itemconfigure $index -background $newValue\n"
  1301. "}\n"
  1302. "$widgets(frame) itemconfigure $index -background $newValue\n"
  1303. "$widgets(text) itemconfigure $index -background $newValue\n"
  1304. "set options($option) [$widgets(frame) cget $option]\n"
  1305. "}\n"
  1306. "-foreground -\n"
  1307. "-selectforeground -\n"
  1308. "-selectbackground {\n"
  1309. "foreach id $misc(columns) {\n"
  1310. "$widgets(listbox$id) itemconfigure $index $option $newValue\n"
  1311. "}\n"
  1312. "$widgets(hiddenListbox) itemconfigure $index $option $newValue\n"
  1313. "set options($option) [$widgets(hiddenListbox) cget $option]\n"
  1314. "}\n"
  1315. "}\n"
  1316. "}\n"
  1317. "}\n"
  1318. "proc ::mclistbox::UpdateScrollbars {w} {\n"
  1319. "upvar ::mclistbox::${w}::widgets widgets\n"
  1320. "upvar ::mclistbox::${w}::options options\n"
  1321. "upvar ::mclistbox::${w}::misc    misc\n"
  1322. "if {![winfo ismapped $w]} {\n"
  1323. "catch {unset misc(afterid)}\n"
  1324. "return\n"
  1325. "}\n"
  1326. "update idletasks\n"
  1327. "if {[llength $misc(columns)] > 0} {\n"
  1328. "if {[string length $options(-yscrollcommand)] != 0} {\n"
  1329. "set col0 [lindex $misc(columns) 0]\n"
  1330. "set yview [$widgets(listbox$col0) yview]\n"
  1331. "eval $options(-yscrollcommand) $yview\n"
  1332. "}\n"
  1333. "if {[string length $options(-xscrollcommand)] != 0} {\n"
  1334. "set col0 [lindex $misc(columns) 0]\n"
  1335. "set xview [$widgets(text) xview]\n"
  1336. "eval $options(-xscrollcommand) $xview\n"
  1337. "}\n"
  1338. "}\n"
  1339. "catch {unset misc(afterid)}\n"
  1340. "}\n"
  1341. "proc ::mclistbox::InvalidateScrollbars {w} {\n"
  1342. "upvar ::mclistbox::${w}::widgets widgets\n"
  1343. "upvar ::mclistbox::${w}::options options\n"
  1344. "upvar ::mclistbox::${w}::misc    misc\n"
  1345. "if {![info exists misc(afterid)]} {\n"
  1346. "set misc(afterid)  "
  1347. "[after idle \"catch {::mclistbox::UpdateScrollbars $w}\"]\n"
  1348. "}\n"
  1349. "}\n"
  1350. "proc ::mclistbox::Insert {w index arglist} {\n"
  1351. "upvar ::mclistbox::${w}::widgets widgets\n"
  1352. "upvar ::mclistbox::${w}::options options\n"
  1353. "upvar ::mclistbox::${w}::misc    misc\n"
  1354. "foreach list $arglist {\n"
  1355. "for {set i [llength $list]} {$i < [llength $misc(columns)]} {incr i} {\n"
  1356. "lappend list {}\n"
  1357. "}\n"
  1358. "set column 0\n"
  1359. "foreach id $misc(columns) {\n"
  1360. "$widgets(listbox$id) insert $index [lindex $list $column]\n"
  1361. "incr column\n"
  1362. "}\n"
  1363. "$widgets(hiddenListbox) insert $index \"x\"\n"
  1364. "}\n"
  1365. "return \"\"\n"
  1366. "}\n"
  1367. "proc ::mclistbox::ColumnIsHidden {w id} {\n"
  1368. "upvar ::mclistbox::${w}::widgets widgets\n"
  1369. "upvar ::mclistbox::${w}::misc    misc\n"
  1370. "set retval 1\n"
  1371. "set col [lsearch -exact $misc(columns) $id]\n"
  1372. "if {$col != \"\"} {\n"
  1373. "set index \"1.$col\"\n"
  1374. "catch {\n"
  1375. "set window [$widgets(text) window cget $index -window]\n"
  1376. "if {[string length $window] > 0 && [winfo exists $window]} {\n"
  1377. "set retval 0\n"
  1378. "}\n"
  1379. "}\n"
  1380. "}\n"
  1381. "return $retval\n"
  1382. "}\n"
  1383. "proc ::mclistbox::AdjustColumns {w {height \"\"}} {\n"
  1384. "upvar ::mclistbox::${w}::widgets widgets\n"
  1385. "upvar ::mclistbox::${w}::options options\n"
  1386. "upvar ::mclistbox::${w}::misc    misc\n"
  1387. "if {[string length $height] == 0} {\n"
  1388. "set height [winfo height $widgets(text)]\n"
  1389. "}\n"
  1390. "incr height -4\n"
  1391. "foreach id $misc(columns) {\n"
  1392. "$widgets(frame$id) configure -height $height\n"
  1393. "}\n"
  1394. "if {$options(-fillcolumn) != \"\"} {\n"
  1395. "if {![info exists widgets(frame$options(-fillcolumn))]} {\n"
  1396. "return\n"
  1397. "}\n"
  1398. "set frame $widgets(frame$options(-fillcolumn))\n"
  1399. "set minwidth $misc(min-$frame)\n"
  1400. "set colwidth 0\n"
  1401. "set col 0\n"
  1402. "foreach id $misc(columns) {\n"
  1403. "if {![ColumnIsHidden $w $id] && $id != $options(-fillcolumn)} {\n"
  1404. "incr colwidth [winfo reqwidth $widgets(frame$id)]\n"
  1405. "}\n"
  1406. "}\n"
  1407. "set id $options(-fillcolumn)\n"
  1408. "set optwidth [expr {[winfo width $widgets(text)] -  "
  1409. "(2 * [$widgets(text) cget -padx])}]\n"
  1410. "set newwidth [expr {$optwidth - $colwidth}]\n"
  1411. "if {$newwidth < $minwidth} {\n"
  1412. "set newwidth $minwidth\n"
  1413. "}\n"
  1414. "$widgets(frame$id) configure -width $newwidth\n"
  1415. "}\n"
  1416. "InvalidateScrollbars $w\n"
  1417. "}\n"
  1418. "proc ::mclistbox::FindResizableNeighbor {w id {direction right}} {\n"
  1419. "upvar ::mclistbox::${w}::widgets       widgets\n"
  1420. "upvar ::mclistbox::${w}::options       options\n"
  1421. "upvar ::mclistbox::${w}::misc          misc\n"
  1422. "if {$direction == \"right\"} {\n"
  1423. "set incr 1\n"
  1424. "set stop [llength $misc(columns)]\n"
  1425. "set start [expr {[lsearch -exact $misc(columns) $id] + 1}]\n"
  1426. "} else {\n"
  1427. "set incr -1\n"
  1428. "set stop -1\n"
  1429. "set start [expr {[lsearch -exact $misc(columns) $id] - 1}]\n"
  1430. "}\n"
  1431. "for {set i $start} {$i != $stop} {incr i $incr} {\n"
  1432. "set col [lindex $misc(columns) $i]\n"
  1433. "if {![ColumnIsHidden $w $col] && $options($col:-resizable)} {\n"
  1434. "return $col\n"
  1435. "}\n"
  1436. "}\n"
  1437. "return \"\"\n"
  1438. "}\n"
  1439. "proc ::mclistbox::ResizeEvent {w type widget x X Y} {\n"
  1440. "upvar ::mclistbox::${w}::widgets       widgets\n"
  1441. "upvar ::mclistbox::${w}::options       options\n"
  1442. "upvar ::mclistbox::${w}::misc          misc\n"
  1443. "upvar ::mclistbox::${w}::columnID      columnID\n"
  1444. "if {!$options(-resizablecolumns)} {\n"
  1445. "return\n"
  1446. "}\n"
  1447. "variable drag\n"
  1448. "set threshold [expr {$options(-labelborderwidth) + 4}]\n"
  1449. "set resizeCursor sb_h_double_arrow\n"
  1450. "if {![info exists columnID($widget)]} {\n"
  1451. "return\n"
  1452. "}\n"
  1453. "set id $columnID($widget)\n"
  1454. "switch $type {\n"
  1455. "buttonpress {\n"
  1456. "if {[$widgets(label$id) cget -cursor] == $resizeCursor} {\n"
  1457. "if {$x <= $threshold} {\n"
  1458. "set lid [::mclistbox::FindResizableNeighbor $w $id left]\n"
  1459. "if {$lid == \"\"} return\n"
  1460. "set drag(leftFrame)  $widgets(frame$lid)\n"
  1461. "set drag(rightFrame) $widgets(frame$id)\n"
  1462. "set drag(leftListbox)  $widgets(listbox$lid)\n"
  1463. "set drag(rightListbox) $widgets(listbox$id)\n"
  1464. "} else {\n"
  1465. "set rid [::mclistbox::FindResizableNeighbor $w $id right]\n"
  1466. "if {$rid == \"\"} return\n"
  1467. "set drag(leftFrame)  $widgets(frame$id)\n"
  1468. "set drag(rightFrame) $widgets(frame$rid)\n"
  1469. "set drag(leftListbox)  $widgets(listbox$id)\n"
  1470. "set drag(rightListbox) $widgets(listbox$rid)\n"
  1471. "}\n"
  1472. "set drag(leftWidth)  [winfo width $drag(leftFrame)]\n"
  1473. "set drag(rightWidth) [winfo width $drag(rightFrame)]\n"
  1474. "set drag(maxDelta)   [expr {$drag(rightWidth) - 1}]\n"
  1475. "set drag(minDelta)  -[expr {$drag(leftWidth) - 1}]\n"
  1476. "set drag(x) $X\n"
  1477. "}\n"
  1478. "}\n"
  1479. "motion {\n"
  1480. "if {[info exists drag(x)]} {return}\n"
  1481. "set resizable 0\n"
  1482. "if {!$options($id:-resizable)} {return}\n"
  1483. "if {$x < $threshold} {\n"
  1484. "set leftColumn [::mclistbox::FindResizableNeighbor $w $id left]\n"
  1485. "if {$leftColumn != \"\"} {\n"
  1486. "set resizable 1\n"
  1487. "}\n"
  1488. "} elseif {$x > [winfo width $widget] - $threshold} {\n"
  1489. "set rightColumn [::mclistbox::FindResizableNeighbor $w $id  "
  1490. "right]\n"
  1491. "if {$rightColumn != \"\"} {\n"
  1492. "set resizable 1\n"
  1493. "}\n"
  1494. "}\n"
  1495. "set cursor [$widgets(label$id) cget -cursor]\n"
  1496. "if {$resizable && $cursor != $resizeCursor} {\n"
  1497. "$widgets(label$id) configure -cursor $resizeCursor\n"
  1498. "} elseif {!$resizable && $cursor == $resizeCursor} {\n"
  1499. "$widgets(label$id) configure -cursor $options(-cursor)\n"
  1500. "}\n"
  1501. "}\n"
  1502. "drag {\n"
  1503. "if {[info exists drag(x)]} {\n"
  1504. "set delta [expr {$X - $drag(x)}]\n"
  1505. "if {$delta >= $drag(maxDelta)} {\n"
  1506. "set delta $drag(maxDelta)\n"
  1507. "} elseif {$delta <= $drag(minDelta)} {\n"
  1508. "set delta $drag(minDelta)\n"
  1509. "}\n"
  1510. "set lwidth [expr {$drag(leftWidth) + $delta}]\n"
  1511. "set rwidth [expr {$drag(rightWidth) - $delta}]\n"
  1512. "$drag(leftFrame)   configure -width $lwidth\n"
  1513. "$drag(rightFrame)  configure -width $rwidth\n"
  1514. "}\n"
  1515. "}\n"
  1516. "buttonrelease {\n"
  1517. "set fillColumnID $options(-fillcolumn)\n"
  1518. "if {[info exists drag(x)] && $fillColumnID != {}} {\n"
  1519. "set fillColumnFrame $widgets(frame$fillColumnID)\n"
  1520. "if {[string compare $drag(leftFrame) $fillColumnFrame] == 0  "
  1521. "|| [string compare $drag(rightFrame) $fillColumnFrame] == 0} {\n"
  1522. "set width [$fillColumnFrame cget -width]\n"
  1523. "set misc(minFillColumnSize) $width\n"
  1524. "}\n"
  1525. "set misc(min-$drag(leftFrame))  [$drag(leftFrame) cget -width]\n"
  1526. "set misc(min-$drag(rightFrame)) [$drag(rightFrame) cget -width]\n"
  1527. "}\n"
  1528. "catch {unset drag}\n"
  1529. "$widgets(label$id) configure -cursor $options(-cursor)\n"
  1530. "}\n"
  1531. "}\n"
  1532. "}\n";
  1533.  
  1534. RexxFunctionHandler TkMCListbox              ;
  1535. RexxFunctionHandler TkMCListboxColumnAdd     ;
  1536. RexxFunctionHandler TkMCListboxColumnCget    ;
  1537. RexxFunctionHandler TkMCListboxColumnConfig  ;
  1538. RexxFunctionHandler TkMCListboxColumnDelete  ;
  1539. RexxFunctionHandler TkMCListboxColumnNames   ;
  1540. RexxFunctionHandler TkMCListboxColumnNearest ;
  1541. RexxFunctionHandler TkMCListboxLabelBind     ;
  1542. RexxFunctionHandler TkMCListboxLoadFuncs     ;
  1543. RexxFunctionHandler TkMCListboxDropFuncs     ;
  1544.  
  1545. /*-----------------------------------------------------------------------------
  1546.  * Table of TK Functions. Used to install/de-install functions.
  1547.  * If you change this table, don't forget to change the table at the end
  1548.  * of this file.
  1549.  *----------------------------------------------------------------------------*/
  1550. RexxFunction RxPackageFunctions[] = {
  1551.    { "TKMCLISTBOXDROPFUNCS"       ,TkMCListboxDropFuncs       ,"TkMCListboxDropFuncs"       , 1 },
  1552.    { "TKMCLISTBOXLOADFUNCS"       ,TkMCListboxLoadFuncs       ,"TkMCListboxLoadFuncs"       , 0 }, /* don't load this from a DLL */
  1553.    { "TKMCLISTBOX"                ,TkMCListbox                ,"TkMCListbox"                , 1 },
  1554.    { "TKMCLISTBOXCOLUMNADD"       ,TkMCListboxColumnAdd       ,"TkMCListboxColumnAdd"       , 1 },
  1555.    { "TKMCLISTBOXCOLUMNCGET"      ,TkMCListboxColumnCget      ,"TkMCListboxColumnCget"      , 1 },
  1556.    { "TKMCLISTBOXCOLUMNCONFIG"    ,TkMCListboxColumnConfig    ,"TkMCListboxColumnConfig"    , 1 },
  1557.    { "TKMCLISTBOXCOLUMNDELETE"    ,TkMCListboxColumnDelete    ,"TkMCListboxColumnDelete"    , 1 },
  1558.    { "TKMCLISTBOXCOLUMNNAMES"     ,TkMCListboxColumnNames     ,"TkMCListboxColumnNames"     , 1 },
  1559.    { "TKMCLISTBOXCOLUMNNEAREST"   ,TkMCListboxColumnNearest   ,"TkMCListboxColumnNearest"   , 1 },
  1560.    { "TKMCLISTBOXLABELBIND"       ,TkMCListboxLabelBind       ,"TkMCListboxLabelBind"       , 1 },
  1561.    { NULL, NULL, NULL, 0 }
  1562. };
  1563.  
  1564. static char czTclCommand[TCLCOMMANDLEN];
  1565. static REXXTKDATA *RexxTkData;
  1566.    
  1567. #if defined(WIN32) || defined(OS2_DYN)
  1568. Tcl_Interp *RexxTk_TclCreateInterp(void)
  1569. {
  1570.    return RexxTkData->Dyn_TclCreateInterp();
  1571. }
  1572.  
  1573. int RexxTk_TclEval(Tcl_Interp *interp, char *string)
  1574. {
  1575.    return RexxTkData->Dyn_TclEval( interp, string );
  1576. }
  1577.  
  1578. int RexxTk_TclInit(Tcl_Interp *interp)
  1579. {
  1580.    return RexxTkData->Dyn_TclInit( interp );
  1581. }
  1582.  
  1583. int RexxTk_TkInit(Tcl_Interp *interp)
  1584. {
  1585.    return RexxTkData->Dyn_TkInit( interp );
  1586. }
  1587. #endif
  1588.  
  1589. /*
  1590.  * Rexx/Tk multi-column listbox functions start here...
  1591.  */
  1592.  
  1593. /*
  1594.  * mclistbox pathName ?options?
  1595.  * TkMCListbox(pathName [,options])
  1596.  */
  1597. RFH_RETURN_TYPE TkMCListbox
  1598.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1599. {
  1600.    FunctionPrologue( (char *)name, argc, argv );
  1601.  
  1602.    return rtk_TypeA(RexxTkData,czTclCommand,name,"mclistbox::mclistbox", argc, argv, retstr);
  1603. }
  1604.  
  1605. /*
  1606.  * pathName column add name ?options...?
  1607.  * TkMCListboxColumnAdd(pathName, name [,options...])
  1608.  */
  1609. RFH_RETURN_TYPE TkMCListboxColumnAdd
  1610.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1611. {
  1612.    FunctionPrologue( (char *)name, argc, argv );
  1613.  
  1614.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1615.  
  1616.    if ( my_checkparam( name, argc, 2, 0 ) )
  1617.       return 1;
  1618.  
  1619.    return rtk_TypeD(RexxTkData,czTclCommand,name,"column add", argc, argv, retstr);
  1620. }
  1621.  
  1622. /*
  1623.  * pathName column cget name option
  1624.  * TkMCListboxColumnCget(pathName, name ,option)
  1625.  */
  1626. RFH_RETURN_TYPE TkMCListboxColumnCget
  1627.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1628. {
  1629.    FunctionPrologue( (char *)name, argc, argv );
  1630.  
  1631.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1632.  
  1633.    if ( my_checkparam( name, argc, 2, 0 ) )
  1634.       return 1;
  1635.  
  1636.    return rtk_TypeC(RexxTkData,czTclCommand,name,"column cget", argc, argv, retstr);
  1637. }
  1638.  
  1639. /*
  1640.  * pathName column configure name ?options...?
  1641.  * TkMCListboxColumnConfig(pathName, name [,options...])
  1642.  */
  1643. RFH_RETURN_TYPE TkMCListboxColumnConfig
  1644.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1645. {
  1646.    FunctionPrologue( (char *)name, argc, argv );
  1647.  
  1648.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1649.  
  1650.    if ( my_checkparam( name, argc, 2, 0 ) )
  1651.       return 1;
  1652.  
  1653.    return rtk_TypeD(RexxTkData,czTclCommand,name,"column configure", argc, argv, retstr);
  1654. }
  1655.  
  1656. /*
  1657.  * pathName column delete name
  1658.  * TkMCListboxColumnDelete(pathName, name)
  1659.  */
  1660. RFH_RETURN_TYPE TkMCListboxColumnDelete
  1661.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1662. {
  1663.    FunctionPrologue( (char *)name, argc, argv );
  1664.  
  1665.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1666.  
  1667.    if ( my_checkparam( name, argc, 2, 2 ) )
  1668.       return 1;
  1669.  
  1670.    return rtk_TypeC(RexxTkData,czTclCommand,name,"column delete", argc, argv, retstr);
  1671. }
  1672.  
  1673. /*
  1674.  * pathName column names
  1675.  * TkMCListboxColumnNames(pathName)
  1676.  */
  1677. RFH_RETURN_TYPE TkMCListboxColumnNames
  1678.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1679. {
  1680.    FunctionPrologue( (char *)name, argc, argv );
  1681.  
  1682.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1683.  
  1684.    if ( my_checkparam( name, argc, 1, 1 ) )
  1685.       return 1;
  1686.  
  1687.    return rtk_TypeC(RexxTkData,czTclCommand,name,"column names", argc, argv, retstr);
  1688. }
  1689.  
  1690. /*
  1691.  * pathName column nearest x
  1692.  * TkMCListboxColumnNearest(pathName,x)
  1693.  */
  1694. RFH_RETURN_TYPE TkMCListboxColumnNearest
  1695.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1696. {
  1697.    FunctionPrologue( (char *)name, argc, argv );
  1698.  
  1699.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1700.  
  1701.    if ( my_checkparam( name, argc, 1, 1 ) )
  1702.       return 1;
  1703.  
  1704.    return rtk_TypeC(RexxTkData,czTclCommand,name,"column nearest", argc, argv, retstr);
  1705. }
  1706.  
  1707. /*
  1708.  * pathName label bind name sequence command
  1709.  * TkMCListboxLabelBind(pathName,name,sequence,[*|+]command)
  1710.  */
  1711. RFH_RETURN_TYPE TkMCListboxLabelBind
  1712.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1713. {
  1714.    FunctionPrologue( (char *)name, argc, argv );
  1715.  
  1716.    if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
  1717.  
  1718.    if ( my_checkparam( name, argc, 4, 4 ) )
  1719.       return 1;
  1720.  
  1721.    czTclCommand[0] = '\0';
  1722.  
  1723.    strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
  1724.    strcat(czTclCommand, " label bind");
  1725.    strcat(czTclCommand, " ");
  1726.    strncat(czTclCommand, argv[1].strptr, argv[1].strlength);
  1727.    strcat(czTclCommand, " ");
  1728.    strncat(czTclCommand, argv[2].strptr, argv[2].strlength);
  1729.    if ( argv[3].strptr[0] == '*' )
  1730.    {
  1731.       strcat(czTclCommand, " {setRexxtk ");
  1732.       strncat(czTclCommand, argv[3].strptr+1, argv[3].strlength);
  1733.       strcat(czTclCommand, "} "); 
  1734.    }
  1735.    else
  1736.    {
  1737.       strcat(czTclCommand, " ");
  1738.       strncat(czTclCommand, argv[3].strptr, argv[3].strlength);
  1739.    }
  1740.    
  1741.    DEBUGDUMP(fprintf(stderr,"%s-%d: (TkMCListboxLabelBind) command: %s\n",__FILE__,__LINE__,czTclCommand);)
  1742.  
  1743.    if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK)
  1744.    {
  1745.       return ReturnError(RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
  1746.    }
  1747.    return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
  1748. }
  1749.  
  1750.  
  1751.  
  1752.  
  1753. RFH_RETURN_TYPE TkMCListboxDropFuncs
  1754.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1755. {
  1756.    ULONG rc=0;
  1757.    int unload=0;
  1758.  
  1759.    if ( my_checkparam(name, argc, 0, 1 ) )
  1760.       return( 1 );
  1761.    if ( argv[0].strlength == 6
  1762.    &&   memcmpi( argv[0].strptr, "UNLOAD", 6 ) == 0 )
  1763.       unload = 1;
  1764.    (void)TermRxPackage( RxPackageName, unload );
  1765.    return RxReturnNumber( retstr, rc );
  1766. }
  1767.  
  1768.  
  1769. RFH_RETURN_TYPE TkMCListboxLoadFuncs
  1770.    (RFH_ARG0_TYPE name, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG3_TYPE stck, RFH_ARG4_TYPE retstr)
  1771. {
  1772.    ULONG rc = 0L;
  1773.  
  1774. #if defined(DYNAMIC_LIBRARY)
  1775.    if ( !QueryRxFunction( "TKWAIT" ) )
  1776.    {
  1777.       fprintf(stderr,"The base Rexx/Tk function package must be loaded before this one\n");
  1778.       return RxReturnNumber( retstr, 1 );
  1779.    }
  1780.    /*
  1781.     * get the pointer to the tcl Interpreter and the base data from base Rexx/Tk
  1782.     * library
  1783.     */
  1784.    if ( argc == 0 )
  1785.    {
  1786.       fprintf(stderr,"You must pass the return value from TkGetBaseData() as the one and only argument.\n");
  1787.       return RxReturnNumber( retstr, 1 );
  1788.    }
  1789.    RexxTkData = (REXXTKDATA *)atol(argv[0].strptr);
  1790.    rc = InitRxPackage( NULL );
  1791.    /* 
  1792.     * Register all external functions
  1793.     */
  1794.    if ( !rc )
  1795.    {
  1796.       rc = RegisterRxFunctions( );
  1797.    }
  1798. #endif
  1799.    return RxReturnNumber( retstr, rc );
  1800. }
  1801.    
  1802. /*
  1803.  * The following functions are used in rxpackage.c
  1804.  */
  1805.  
  1806. /*-----------------------------------------------------------------------------
  1807.  * Execute any initialisation
  1808.  *----------------------------------------------------------------------------*/
  1809. int InitialisePackage
  1810.  
  1811. #ifdef HAVE_PROTO
  1812.    ( void )
  1813. #else
  1814.    ( )
  1815. #endif
  1816.  
  1817. {
  1818.    InternalTrace( "InitialisePackage", NULL );
  1819.  
  1820.    /*
  1821.     * Install the MCListbox widget
  1822.     */
  1823.    if (Tcl_Eval( RexxTkData->RexxTkInterp,ExtensionSource ) !=TCL_OK) {
  1824.       fprintf(stderr, "Tk_Eval for MCListbox widget failed miserably at line %d: %s\n", RexxTkData->RexxTkInterp->errorLine, RexxTkData->RexxTkInterp->result);
  1825.       return 1;
  1826.    }
  1827.    if (Tcl_Eval( RexxTkData->RexxTkInterp,ExtensionSource1 ) !=TCL_OK) {
  1828.       fprintf(stderr, "Tk_Eval for MCListbox widget failed miserably at line %d: %s\n", RexxTkData->RexxTkInterp->errorLine, RexxTkData->RexxTkInterp->result);
  1829.       return 1;
  1830.    }
  1831.    DEBUGDUMP(fprintf(stderr,"%s-%d: After Tcl_Eval()\n",__FILE__,__LINE__);)
  1832.    return 0;
  1833. }
  1834.  
  1835. /*-----------------------------------------------------------------------------
  1836.  * Execute any termination
  1837.  *----------------------------------------------------------------------------*/
  1838. int TerminatePackage
  1839.  
  1840. #ifdef HAVE_PROTO
  1841.    ( void )
  1842. #else
  1843.    ( )
  1844. #endif
  1845.  
  1846. {
  1847.    return 0;
  1848. }
  1849.  
  1850.  
  1851. #if defined(USE_REXX6000)
  1852. /*
  1853.  * This function is used as the entry point for the REXX/6000
  1854.  * Rexx Interpreter
  1855.  * If you change this table, don't forget to change the table at the
  1856.  * start of this file.
  1857.  */
  1858. USHORT InitFunc( RXFUNCBLOCK **FuncBlock )
  1859. {
  1860.    static RXFUNCBLOCK funcarray[] =
  1861.    {
  1862.       { "TKMCLISTBOXDROPFUNCS"       ,TkMCListboxDropFuncs      ,NULL },
  1863.       { "TKMCLISTBOXLOADFUNCS"       ,TkMCListboxLoadFuncs      ,NULL },
  1864.       { "TKMCLISTBOX"                ,TkMCListbox               ,NULL },
  1865.       { "TKMCLISTBOXCOLUMNADD"       ,TkMCListboxColumnAdd      ,NULL },
  1866.       { "TKMCLISTBOXCOLUMNCGET"      ,TkMCListboxColumnCget     ,NULL },
  1867.       { "TKMCLISTBOXCOLUMNCONFIG"    ,TkMCListboxColumnConfig   ,NULL },
  1868.       { "TKMCLISTBOXCOLUMNDELETE"    ,TkMCListboxColumnDelete   ,NULL },
  1869.       { "TKMCLISTBOXCOLUMNNAMES"     ,TkMCListboxColumnNames    ,NULL },
  1870.       { "TKMCLISTBOXCOLUMNNEAREST"   ,TkMCListboxColumnNearest  ,NULL },
  1871.       { "TKMCLISTBOXLABELBIND"       ,TkMCListboxLabelBind      ,NULL },
  1872.       { NULL, NULL, NULL }
  1873.    } ;
  1874.    *FuncBlock = funcarray;
  1875.    return (USHORT)0;
  1876. }
  1877. #endif
  1878.