Posted to tcl by auriocus at Sat Dec 06 14:10:53 GMT 2014view raw
- --- tkcon.tcl 2014-12-06 13:39:41.000000000 +0100
- +++ tkcon_patched.tcl 2014-12-06 15:07:30.000000000 +0100
- @@ -2156,6 +2156,21 @@
- return [expr {[llength [$w tag ranges find]]/2}]
- }
- +## ::tkcon::Goto - highlights a line in the text widget
- +## If $str is empty, it just deletes any highlighting
- +# ARGS: w - text widget
- +# pos - line to highlight
- +##
- +proc ::tkcon::Goto {w pos} {
- + $w tag remove gotopos 1.0 end
- + set truth {^(1|yes|true|on)$}
- + if {$pos eq ""} { return }
- +
- + $w tag add gotopos ${pos}.0 ${pos}.end
- + $w tag configure gotopos -background $::tkcon::COLOR(blink)
- + catch {$w see gotopos.first}
- +}
- +
- ## ::tkcon::Attach - called to attach tkcon to an interpreter
- # ARGS: name - application name to which tkcon sends commands
- # This is either a slave interperter name or tk appname.
- @@ -3105,6 +3120,26 @@
- {[list $OPT(edit) -attach $app -type proc -- $cmd]}"
- }
- }
- +
- + # do voodoo for class methods, less vodoo than for procs
- + set info [$w get 1.0 end-1c]
- + # Check for specific line error in a proc
- + set exp(method) {\(class\s+"([^"]*)"\s+method\s+"([^"]*)"\s+line\s+(\d+)\)}
- + set positions [regexp -inline -all -indices $exp(method) $info]
- + set pieces [regexp -inline -all $exp(method) $info]
- +
- + foreach {all _ _ _} $positions {_ class method line} $pieces {
- + lassign $all start end
- + set tag [UniqueTag $w]
- + if {$end <= $start} { incr end }
- +
- + $w tag add $tag 1.0+${start}c 1.0+${end}c
- + $w tag configure $tag -foreground $COLOR(stdout)
- + $w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
- + $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
- + $w tag bind $tag <ButtonRelease-1> "if {!\$tk::Priv(mouseMoved)} \
- + {[list $OPT(edit) -attach $app -type oomethod -goto $line -- [list $class $method]]}"
- + }
- }
- proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} {
- @@ -3847,10 +3882,11 @@
- variable ::tkcon::COLOR
- variable ::tkcon::OPT
- - array set opts {-find {} -type {} -attach {} -wrap {none}}
- + array set opts {-find {} -type {} -attach {} -wrap {none} -goto {}}
- while {[string match -* [lindex $args 0]]} {
- switch -glob -- [lindex $args 0] {
- -f* { set opts(-find) [lindex $args 1] }
- + -g* { set opts(-goto) [lindex $args 1] }
- -a* { set opts(-attach) [lindex $args 1] }
- -t* { set opts(-type) [lindex $args 1] }
- -w* { set opts(-wrap) [lindex $args 1] }
- @@ -3970,6 +4006,14 @@
- [::tkcon::EvalOther $app $type dump proc [list $word]]
- after idle [::tkcon::Highlight $w.text tcl]
- }
- + oomethod {
- + # a method from TclOO
- + $w.text insert 1.0 \
- + [::tkcon::EvalOther $app $type dump oomethod [list $word]]
- + after idle [::tkcon::Highlight $w.text tcl]
- +
- + }
- +
- var* {
- $w.text insert 1.0 \
- [::tkcon::EvalOther $app $type dump var [list $word]]
- @@ -4001,6 +4045,10 @@
- if {[string compare $opts(-find) {}]} {
- ::tkcon::Find $w.text $opts(-find) -case 1
- }
- + if {[string compare $opts(-goto) {}]} {
- + # mark the line indicated by goto and place the cursor there
- + ::tkcon::Goto $w.text $opts(-goto)
- + }
- }
- interp alias {} ::more {} ::edit
- interp alias {} ::less {} ::edit
- @@ -4212,6 +4260,15 @@
- }
- }
- }
- + oomethod {
- + set classmethod [lindex $args 0 0]
- + lassign $classmethod class method
- + set code [catch {info class definition {*}$classmethod} res]
- + if {!$code} {
- + set res "oo::define [list $class] [list $method] $res"
- + }
- + }
- +
- w* {
- # widget
- ## The user should have Tk loaded