Posted to tcl by kostix at Wed Feb 21 16:41:54 GMT 2007view raw

  1. # $Id$
  2.  
  3. proc btags {what args} {
  4. switch -glob -- $what {
  5. add { eval btags::add $args }
  6. remove { eval btags::remove $args }
  7. default {
  8. error "Bad option: "$what": must be add, remove"
  9. }
  10. }
  11. }
  12.  
  13. namespace eval btags {}
  14.  
  15. proc btags::add {where what args} {
  16. set which ""
  17. set off 0
  18. foreach {opt val} $args {
  19. switch -glob -- $opt {
  20. -before {
  21. set which $val
  22. set off 1
  23. }
  24. -after {
  25. set which $val
  26. set off 0
  27. }
  28. default {
  29. error "bad option \"$opt\": must be -before, -after"
  30. }
  31. }
  32. }
  33.  
  34. set btags [bindtags $where]
  35.  
  36. if {[string equal $which ""]} {
  37. set ix 0
  38. } else {
  39. set ix [lsearch -exact $btags $which]
  40. if {$ix < 0} {
  41. error "bindtag \"$which\" is not defined for \"$where\""
  42. }
  43. incr ix $off
  44. }
  45.  
  46. bindtags $where [linsert $btags $ix $what]
  47. }
  48.  
  49. proc btags::remove {where what} {
  50. set btags [bindtags $where]
  51. set ix [lsearch -exact $btags $what]
  52. if {$ix < 0} {
  53. error "bindtag \"$what\" is not defined for \"$where\""
  54. }
  55.  
  56. bindtags $where [lreplace $btags $ix $ix]
  57. }
  58.  
  59. ### JUNK ###
  60. if 1 {
  61. namespace eval hook {
  62. proc run args {}
  63. }
  64. }
  65.  
  66. bind TkabberTextActions <Button-3> \
  67. [list tk_messageBox -message {Menu placeholder}]
  68.  
  69. # The trickery (see http://wiki.tcl.tk/16343):
  70. rename entry orig.entry
  71. rename text orig.text
  72.  
  73. proc entry {w args} {
  74. eval [linsert $args 0 orig.entry $w]
  75. btags add $w TkabberTextActions -before Entry
  76. hook::run entry_created_hook $w $args
  77. return $w
  78. }
  79.  
  80. proc text {w args} {
  81. eval [linsert $args 0 orig.text $w]
  82. btags add $w TkabberTextActions -before Text
  83. hook::run text_created_hook $w $args
  84. return $w
  85. }
  86.  
  87. ### TEST ###
  88. if 1 {
  89. pack [entry .e] -fill x -expand true
  90. pack [text .t] -fill x -expand true
  91. pack [button .b -text REMOVE -command \
  92. [list btags remove .e TkabberTextActions]]
  93. }
  94.  
  95.