Posted to tcl by auriocus at Sat Dec 06 14:10:53 GMT 2014view raw

  1. --- tkcon.tcl 2014-12-06 13:39:41.000000000 +0100
  2. +++ tkcon_patched.tcl 2014-12-06 15:07:30.000000000 +0100
  3. @@ -2156,6 +2156,21 @@
  4. return [expr {[llength [$w tag ranges find]]/2}]
  5. }
  6.  
  7. +## ::tkcon::Goto - highlights a line in the text widget
  8. +## If $str is empty, it just deletes any highlighting
  9. +# ARGS: w - text widget
  10. +# pos - line to highlight
  11. +##
  12. +proc ::tkcon::Goto {w pos} {
  13. + $w tag remove gotopos 1.0 end
  14. + set truth {^(1|yes|true|on)$}
  15. + if {$pos eq ""} { return }
  16. +
  17. + $w tag add gotopos ${pos}.0 ${pos}.end
  18. + $w tag configure gotopos -background $::tkcon::COLOR(blink)
  19. + catch {$w see gotopos.first}
  20. +}
  21. +
  22. ## ::tkcon::Attach - called to attach tkcon to an interpreter
  23. # ARGS: name - application name to which tkcon sends commands
  24. # This is either a slave interperter name or tk appname.
  25. @@ -3105,6 +3120,26 @@
  26. {[list $OPT(edit) -attach $app -type proc -- $cmd]}"
  27. }
  28. }
  29. +
  30. + # do voodoo for class methods, less vodoo than for procs
  31. + set info [$w get 1.0 end-1c]
  32. + # Check for specific line error in a proc
  33. + set exp(method) {\(class\s+"([^"]*)"\s+method\s+"([^"]*)"\s+line\s+(\d+)\)}
  34. + set positions [regexp -inline -all -indices $exp(method) $info]
  35. + set pieces [regexp -inline -all $exp(method) $info]
  36. +
  37. + foreach {all _ _ _} $positions {_ class method line} $pieces {
  38. + lassign $all start end
  39. + set tag [UniqueTag $w]
  40. + if {$end <= $start} { incr end }
  41. +
  42. + $w tag add $tag 1.0+${start}c 1.0+${end}c
  43. + $w tag configure $tag -foreground $COLOR(stdout)
  44. + $w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
  45. + $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
  46. + $w tag bind $tag <ButtonRelease-1> "if {!\$tk::Priv(mouseMoved)} \
  47. + {[list $OPT(edit) -attach $app -type oomethod -goto $line -- [list $class $method]]}"
  48. + }
  49. }
  50.  
  51. proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} {
  52. @@ -3847,10 +3882,11 @@
  53. variable ::tkcon::COLOR
  54. variable ::tkcon::OPT
  55.  
  56. - array set opts {-find {} -type {} -attach {} -wrap {none}}
  57. + array set opts {-find {} -type {} -attach {} -wrap {none} -goto {}}
  58. while {[string match -* [lindex $args 0]]} {
  59. switch -glob -- [lindex $args 0] {
  60. -f* { set opts(-find) [lindex $args 1] }
  61. + -g* { set opts(-goto) [lindex $args 1] }
  62. -a* { set opts(-attach) [lindex $args 1] }
  63. -t* { set opts(-type) [lindex $args 1] }
  64. -w* { set opts(-wrap) [lindex $args 1] }
  65. @@ -3970,6 +4006,14 @@
  66. [::tkcon::EvalOther $app $type dump proc [list $word]]
  67. after idle [::tkcon::Highlight $w.text tcl]
  68. }
  69. + oomethod {
  70. + # a method from TclOO
  71. + $w.text insert 1.0 \
  72. + [::tkcon::EvalOther $app $type dump oomethod [list $word]]
  73. + after idle [::tkcon::Highlight $w.text tcl]
  74. +
  75. + }
  76. +
  77. var* {
  78. $w.text insert 1.0 \
  79. [::tkcon::EvalOther $app $type dump var [list $word]]
  80. @@ -4001,6 +4045,10 @@
  81. if {[string compare $opts(-find) {}]} {
  82. ::tkcon::Find $w.text $opts(-find) -case 1
  83. }
  84. + if {[string compare $opts(-goto) {}]} {
  85. + # mark the line indicated by goto and place the cursor there
  86. + ::tkcon::Goto $w.text $opts(-goto)
  87. + }
  88. }
  89. interp alias {} ::more {} ::edit
  90. interp alias {} ::less {} ::edit
  91. @@ -4212,6 +4260,15 @@
  92. }
  93. }
  94. }
  95. + oomethod {
  96. + set classmethod [lindex $args 0 0]
  97. + lassign $classmethod class method
  98. + set code [catch {info class definition {*}$classmethod} res]
  99. + if {!$code} {
  100. + set res "oo::define [list $class] [list $method] $res"
  101. + }
  102. + }
  103. +
  104. w* {
  105. # widget
  106. ## The user should have Tk loaded
  107.