Updated 2015-04-13 04:09:34 by APN ▲

APN 2015-04-13: Doing more TclOO stuff, I wanted to be able to expand method names interactively in the same manner that proc names are expanded. Turned out the tkcon already had that for nx, xotcl, nsf so I patched in support for TclOO.

The patch also fixes some limitations in the original code. In particular, it also expands method names when the cursor is not at the end of the line, or within a multi command line like first command ; obj methodcall or when the object is accessed via a variable like $obj methodcall.

The patch below is against tkcon.tcl CVS file version 1.122 (that is the *CVS* file version, not the tkcon version). Tested with Tcl 8.5 and 8.6. Will fail on 8.4 (no apply command) but I cannot be bothered with old Tcl versions.
*** tkcon.tcl.orig        Sat Mar 21 07:44:37 2015
--- tkcon.tcl        Mon Apr 13 09:11:42 2015
*************** proc ::tkcon::Init {args} {
*** 119,125 ****
          if {![info exists COLOR($key)]} { set COLOR($key) $default }
      }
  
-     # expandorder could also include 'Methodname' for XOTcl/NSF methods
      foreach {key default} {
          autoload        {}
          blinktime        500
--- 119,124 ----
*************** proc ::tkcon::Init {args} {
*** 131,137 ****
          debugPrompt        {(level \#$level) debug [history nextid] > }
          dead                {}
          edit                edit
!         expandorder        {Pathname Variable Procname}
          font                {}
          history                48
          hoterrors        1
--- 130,136 ----
          debugPrompt        {(level \#$level) debug [history nextid] > }
          dead                {}
          edit                edit
!         expandorder        {Methodname Pathname Variable Procname}
          font                {}
          history                48
          hoterrors        1
*************** proc ::tkcon::Init {args} {
*** 323,332 ****
                  -main - -e - -eval        { append OPT(maineval) \n$val\n }
                  -package - -load        {
                      lappend OPT(autoload) $val
-                     if {$val eq "nsf" || $val eq "nx" || $val eq "XOTcl" } {
-                         # If xotcl is loaded, prepend expand order for it
-                         set OPT(expandorder) [concat Methodname $OPT(expandorder)]
-                     }
                  }
                  -slave                { append OPT(slaveeval) \n$val\n }
                  -nontcl                { set OPT(nontcl) [regexp -nocase $truth $val]}
--- 322,327 ----
*************** proc ::tkcon::ExpandProcname str {
*** 5836,5851 ****
  #                possible further matches
  ##
  proc ::tkcon::ExpandMethodname str {
  
-     # In a first step, obtain the typed-in cmd from the console
-     set typedCmd [::tkcon::CmdGet $::tkcon::PRIV(console)]
      set obj [lindex $typedCmd 0]
      if {$obj eq $typedCmd} {
          # just a single word, can't be a method expansion
          return -code continue
      }
      # Get the full string after the object
!     set sub [string trimleft [string range $typedCmd [string length [list $obj]] end]]
      if {[EvalAttached [list info exists ::nsf::version]]} {
          # Next Scripting Framework is loaded
          if {![EvalAttached [list ::nsf::object::exists $obj]]} {return -code continue}
--- 5831,5861 ----
  #                possible further matches
  ##
  proc ::tkcon::ExpandMethodname str {
+     # Locate the start of the current command looking back from the insert
+     # cursor to the end of the prompt (mark "limit"). Note the start of the
+     # command may be following a ";", "[", not necessarily the beginning.
+     set start [$::tkcon::PRIV(console) search -backwards -regexp {^|[;\[]\s*} insert-1c limit-1c]
+     if {[string compare {} $start]} {
+         append start +1c
+     } else {
+         set start limit
+     }
+     set typedCmd [string trimleft [$::tkcon::PRIV(console) get $start insert]]
  
      set obj [lindex $typedCmd 0]
      if {$obj eq $typedCmd} {
          # just a single word, can't be a method expansion
          return -code continue
      }
      # Get the full string after the object
!     set sub [string trimleft [string range $typedCmd [string length $obj] end]]
! 
!     # Deal with cases where the object is actually stored in a variable
!     # extract the real object name (ie. $x methodcall).
!     if {[string index $obj 0] eq "\$"} {
!         set obj [EvalAttached [list set [string range $obj 1 end]]]
!     }
! 
      if {[EvalAttached [list info exists ::nsf::version]]} {
          # Next Scripting Framework is loaded
          if {![EvalAttached [list ::nsf::object::exists $obj]]} {return -code continue}
*************** proc ::tkcon::ExpandMethodname str {
*** 5860,5870 ****
          # XOTcl < 2.* is loaded
          if {![EvalAttached [list ::xotcl::Object isobject $obj]]} {return -code continue}
          set cmd [list $obj info methods $sub*]
      } else {
          # No NSF/XOTcl loaded
          return -code continue
      }
- 
      set match [EvalAttached $cmd]
      if {[llength $match] > 1} {
          regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } bestMatch
--- 5870,5893 ----
          # XOTcl < 2.* is loaded
          if {![EvalAttached [list ::xotcl::Object isobject $obj]]} {return -code continue}
          set cmd [list $obj info methods $sub*]
+     } elseif {[llength [EvalAttached [list ::info commands oo::define]]]} {
+         if {![EvalAttached "::info object isa object $obj"]} {
+             return -code continue
+         }
+         set cmd [list apply {
+             {obj sub} {
+                 set matches {}
+                 foreach meth [::info object methods $obj -all] {
+                     if {[string match $sub* $meth]} {
+                         lappend matches $meth
+                     }
+                 }
+                 return $matches
+             }} $obj $sub]
      } else {
          # No NSF/XOTcl loaded
          return -code continue
      }
      set match [EvalAttached $cmd]
      if {[llength $match] > 1} {
          regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } bestMatch

Category Application