package provide TclReadLine 1.1

  #! /usr/bin/env tclsh
  # tclline: An attempt at a pure tcl readline.

  # Use Tclx if available:
  catch {
      package require Tclx

      # Prevent sigint from killing our shell:
      signal ignore SIGINT
  }

  namespace eval TclReadLine {
  
      namespace export interact
  
    # Initialise our own env variables:
      variable PROMPT ">"
      variable HISTORY ""
      variable HISTORY_BUFFER 100
      variable COMPLETION_MATCH ""
  
      variable CMDLINE ""
      variable CMDLINE_CURSOR 0
      variable CMDLINE_LINES 0
  
      variable ALIASES
      array set ALIASES {}
  
      variable forever 0
  
      # Resource & history files:
      variable HISTFILE $env(HOME)/.tclline_history
      variable  RCFILE $env(HOME)/.tcllinerc
  }
  
  proc TclReadLine::ESC {} {
      return "\033"
  }
  
  proc TclReadLine::shift {ls} {
      upvar 1 $ls LIST
      set ret [lindex $LIST 0]
      set LIST [lrange $LIST 1 end]
      return $ret
  }
  
  proc TclReadLine::readbuf {txt} {
      upvar 1 $txt STRING
  
      set ret [string index $STRING 0]
      set STRING [string range $STRING 1 end]
      return $ret
  }
  
  proc TclReadLine::goto {row {col 1}} {
      switch -- $row {
          "home" {set row 1}
      }
      print "[ESC]\[${row};${col}H" nowait
  }
  
  proc TclReadLine::gotocol {col} {
      print "\r" nowait
      if {$col > 0} {
          print "[ESC]\[${col}C" nowait
      }
  }
  
  proc TclReadLine::clear {} {
      print "[ESC]\[2J" nowait
      goto home
  }
  
  proc TclReadLine::clearline {} {
      print "[ESC]\[2K\r" nowait
  }
  
  proc TclReadLine::getColumns {} {
      set cols 0
      if {![catch {exec stty -a} err]} {
          regexp {rows (= )?(\d+); columns (= )?(\d+)} $err junk i1 rows i2 cols
      }
      return $cols
  }
  
  proc TclReadLine::localInfo {args} {
      set v [uplevel _info $args]
      if { [string equal "script" [lindex $args 0]] } {
          if { [string equal $v $TclReadLine::ThisScript] } {
              return ""
          } 
      }
      return $v
  }
  
  proc TclReadLine::localPuts {args} {
  
      set l [llength $args]
      if { 3 < $l } {
          return -code error "Error: wrong \# args"
      }
      
      if { 1 < $l } {
          if { [string equal "-nonewline" [lindex $args 0]] } {
              if { 2 < $l } {
                  # we don't send to channel...
                  eval _origPuts $args
              } else {
                  set str [lindex $args 1]
                  append TclReadLine::putsString $str ;# no newline...
              }
          } else {
              # must be a channel
              eval _origPuts $args
          }
      } else {
          append TclReadLine::putsString [lindex $args 0] "\n"
      }
  }
  
  proc TclReadLine::prompt {{txt ""}} {
  
      if { "" != [info var ::tcl_prompt1] } {
          rename ::puts ::_origPuts
          rename TclReadLine::localPuts ::puts
          variable putsString
          set putsString ""
          eval [set ::tcl_prompt1]
          set prompt $putsString
          rename ::puts TclReadLine::localPuts
          rename ::_origPuts ::puts
      } else {
          variable PROMPT
          set prompt [subst $PROMPT]
      }
      set txt "$prompt$txt"
      variable CMDLINE_LINES
      variable CMDLINE_CURSOR
      variable COLUMNS
      foreach {end mid} $CMDLINE_LINES break
  
      # Calculate how many extra lines we need to display.
      # Also calculate cursor position:
      set n -1
      set totalLen 0
      set cursorLen [expr {$CMDLINE_CURSOR+[string length $prompt]}]
      set row 0
      set col 0
  
      # Render output line-by-line to $out then copy back to $txt:
      set found 0
      set out [list]
      foreach line [split $txt "\n"] {
          set len [expr {[string length $line]+1}]
          incr totalLen $len
          if {$found == 0 && $totalLen >= $cursorLen} {
              set cursorLen [expr {$cursorLen - ($totalLen - $len)}]
              set col [expr {$cursorLen % $COLUMNS}]
              set row [expr {$n + ($cursorLen / $COLUMNS) + 1}]
  
              if {$cursorLen >= $len} {
                  set col 0
                  incr row
              }
              set found 1
          }
          incr n [expr {int(ceil(double($len)/$COLUMNS))}]
          while {$len > 0} {
              lappend out [string range $line 0 [expr {$COLUMNS-1}]]
              set line [string range $line $COLUMNS end]
              set len [expr {$len-$COLUMNS}]
          }
      }
      set txt [join $out "\n"]
      set row [expr {$n-$row}]
  
      # Reserve spaces for display:
      if {$end} {
          if {$mid} {
              print "[ESC]\[${mid}B" nowait
          }
          for {set x 0} {$x < $end} {incr x} {
              clearline
              print "[ESC]\[1A" nowait
          }
      }
      clearline
      set CMDLINE_LINES $n
  
      # Output line(s):
      print "\r$txt"
  
      if {$row} {
          print "[ESC]\[${row}A" nowait
      }
      gotocol $col
      lappend CMDLINE_LINES $row
    }
  
  proc TclReadLine::print {txt {wait wait}} {
      # Sends output to stdout chunks at a time.
      # This is to prevent the terminal from
      # hanging if we output too much:
      while {[string length $txt]} {
          puts -nonewline [string range $txt 0 2047]
          set txt [string range $txt 2048 end]
          if {$wait == "wait"} {
              after 1
          }
      }
  }
  
  proc TclReadLine::unknown {args} {
  
      set name [lindex $args 0]
      set cmdline $TclReadLine::CMDLINE
      set cmd [string trim [regexp -inline {^\s*[^\s]+} $cmdline]]
      if {[info exists TclReadLine::ALIASES($cmd)]} {
          set cmd [regexp -inline {^\s*[^\s]+} $TclReadLine::ALIASES($cmd)]
      }
  
      set new [auto_execok $name]
      if {$new != ""} {
          set redir ""
          if {$name == $cmd && [info command $cmd] == ""} {
              set redir ">&@ stdout <@ stdin"
          }
          if {[catch {
              uplevel 1 exec $redir $new [lrange $args 1 end]} ret]
          } {
              return
          }
          return $ret
      }
  
      uplevel _unknown $args
  }
  
  proc TclReadLine::alias {word command} {
      variable ALIASES
      set ALIASES($word) $command
  }
  
  proc TclReadLine::unalias {word} {
      variable ALIASES
      array unset ALIASES $word
  }
  
  ################################
  # Key bindings
  ################################
  proc TclReadLine::handleEscapes {} {
  
      variable CMDLINE
      variable CMDLINE_CURSOR
  
      upvar 1 keybuffer keybuffer
      set seq ""
      set found 0
      while {[set ch [readbuf keybuffer]] != ""} {
          append seq $ch
  
          switch -exact -- $seq {
              "\[A" { ;# Cursor Up (cuu1,up)
                  handleHistory 1
                  set found 1; break
              }
              "\[B" { ;# Cursor Down
                  handleHistory -1
                  set found 1; break
              }
              "\[C" { ;# Cursor Right (cuf1,nd)
                  if {$CMDLINE_CURSOR < [string length $CMDLINE]} {
                      incr CMDLINE_CURSOR
                  }
                  set found 1; break
              }
              "\[D" { ;# Cursor Left
                  if {$CMDLINE_CURSOR > 0} {
                      incr CMDLINE_CURSOR -1
                  }
                  set found 1; break
              }
              "\[H" -
              "\[7~" -
              "\[1~" { ;# home
                  set CMDLINE_CURSOR 0
                  set found 1; break
              }
              "\[3~" { ;# delete
                  if {$CMDLINE_CURSOR < [string length $CMDLINE]} {
                      set CMDLINE [string replace $CMDLINE \
                                       $CMDLINE_CURSOR $CMDLINE_CURSOR]
                  }
                  set found 1; break
              }
              "\[F" -
              "\[K" -
              "\[8~" -
              "\[4~" { ;# end
                  set CMDLINE_CURSOR [string length $CMDLINE]
                  set found 1; break
              }
              "\[5~" { ;# Page Up
              }
              "\[6~" { ;# Page Down
              }
          }
      }
      return $found
    }
  
  proc TclReadLine::handleControls {} {
  
      variable CMDLINE
      variable CMDLINE_CURSOR
  
      upvar 1 char char
      upvar 1 keybuffer keybuffer
  
      # Control chars start at a == \u0001 and count up.
      switch -exact -- $char {
          \u0001 { ;# ^a
              set CMDLINE_CURSOR 0
          }
          \u0002 { ;# ^b
              if { $CMDLINE_CURSOR > 0 } {
                  incr CMDLINE_CURSOR -1
              }
          }
          \u0004 { ;# ^d
              # should exit - if this is the EOF char, and the
              #   cursor is at the end-of-input
              if { 0 == [string length $CMDLINE] } {
                  doExit
              }
              set CMDLINE [string replace $CMDLINE \
                               $CMDLINE_CURSOR $CMDLINE_CURSOR]
          }
          \u0005 { ;# ^e
              set CMDLINE_CURSOR [string length $CMDLINE]
          }
          \u0006 { ;# ^f
              if {$CMDLINE_CURSOR < [string length $CMDLINE]} {
                  incr CMDLINE_CURSOR
              }
          }
          \u0007 { ;# ^g
              set CMDLINE ""
              set CMDLINE_CURSOR 0
          }
          \u000b { ;# ^k
              variable YANK
              set YANK  [string range $CMDLINE [expr {$CMDLINE_CURSOR  } ] end ]
              set CMDLINE [string range $CMDLINE 0 [expr {$CMDLINE_CURSOR - 1 } ]]
          }
          \u0019 { ;# ^y
              variable YANK
              if { [ info exists YANK ] } {
                  set CMDLINE \
                      "[string range $CMDLINE 0 [expr {$CMDLINE_CURSOR - 1 }]]$YANK[string range $CMDLINE $CMDLINE_CURSOR end]"
              }
          }
          \u000e { ;# ^n
              handleHistory -1
          }
          \u0010 { ;# ^p
              handleHistory 1
          }
          \u0003 { ;# ^c
              # clear line
              set CMDLINE ""
              set CMDLINE_CURSOR 0
          }
          \u0008 -
          \u007f { ;# ^h && backspace ?
              if {$CMDLINE_CURSOR > 0} {
                  incr CMDLINE_CURSOR -1
                  set CMDLINE [string replace $CMDLINE \
                                        $CMDLINE_CURSOR $CMDLINE_CURSOR]
              }
          }
          \u001b { ;# ESC - handle escape sequences
              handleEscapes
          }
      }
        # Rate limiter:
      set keybuffer ""
  }
  
  proc TclReadLine::shortMatch {maybe} {
      # Find the shortest matching substring:
      set maybe [lsort $maybe]
      set shortest [lindex $maybe 0]
      foreach x $maybe {
          while {![string match $shortest* $x]} {
              set shortest [string range $shortest 0 end-1]
          }
      }
      return $shortest
  }
  
  proc TclReadLine::handleCompletion {} {
      variable CMDLINE
      variable CMDLINE_CURSOR
  
      set vars ""
      set cmds ""
      set execs ""
      set files ""
  
      # First find out what kind of word we need to complete:
      set wordstart [string last " " $CMDLINE [expr {$CMDLINE_CURSOR-1}]]
      incr wordstart
      set wordend [string first " " $CMDLINE $wordstart]
      if {$wordend == -1} {
          set wordend end
      } else {
          incr wordend -1
      }
      set word [string range $CMDLINE $wordstart $wordend]
  
      if {[string trim $word] == ""} return
  
      set firstchar [string index $word 0]
  
      # Check if word is a variable:
      if {$firstchar == "\$"} {
          set word [string range $word 1 end]
          incr wordstart
          
          # Check if it is an array key:proc 
  
          set x [string first "(" $word]
          if {$x != -1} {
              set v [string range $word 0 [expr {$x-1}]]
              incr x
              set word [string range $word $x end]
              incr wordstart $x
              if {[uplevel \#0 "array exists $v"]} {
                  set vars [uplevel \#0 "array names $v $word*"]
              }
          } else {
              foreach x [uplevel \#0 {info vars}] {
                  if {[string match $word* $x]} {
                      lappend vars $x
                  }
              }
          }
      } else {
          # Check if word is possibly a path:
          if {$firstchar == "/" || $firstchar == "." || $wordstart != 0} {
              set files [glob -nocomplain -- $word*]
          }
          if {$files == ""} {
              # Not a path then get all possibilities:
              if {$firstchar == "\[" || $wordstart == 0} {
                  if {$firstchar == "\["} {
                      set word [string range $word 1 end]
                      incr wordstart
                  }
                  # Check executables:
                  foreach dir [split $env(PATH) :] {
                      foreach f [glob -nocomplain -directory $dir -- $word*] {
                          set exe [string trimleft [string range $f \
                                [string length $dir] end] "/"]
  
                          if {[lsearch -exact $execs $exe] == -1} {
                              lappend execs $exe
                          }
                      }
                  }
                  # Check commands:
                  foreach x [info commands] {
                      if {[string match $word* $x]} {
                          lappend cmds $x
                      }
                  }
              } else {
                  # Check commands anyway:
                  foreach x [info commands] {
                      if {[string match $word* $x]} {
                          lappend cmds $x
                      }
                  }
              }
          }
          if {$wordstart != 0} {
              # Check variables anyway:
              set x [string first "(" $word]
              if {$x != -1} {
                  set v [string range $word 0 [expr {$x-1}]]
                  incr x
                  set word [string range $word $x end]
                  incr wordstart $x
                  if {[uplevel \#0 "array exists $v"]} {
                      set vars [uplevel \#0 "array names $v $word*"]
                  }
              } else {
                  foreach x [uplevel \#0 {info vars}] {
                      if {[string match $word* $x]} {
                          lappend vars $x
                      }
                  }
              }
          }
      }
  
      variable COMPLETION_MATCH
      set maybe [concat $vars $cmds $execs $files]
      set shortest [shortMatch $maybe]
      if {"$word" == "$shortest"} {
          if {[llength $maybe] > 1 && $COMPLETION_MATCH != $maybe} {
              set COMPLETION_MATCH $maybe
              clearline
              set temp ""
              foreach {match format} {
                  vars  "35"
                  cmds  "1;32"
                  execs "32"
                  files "0"
              } {
                  if {[llength [set $match]]} {
                      append temp "[ESC]\[${format}m"
                      foreach x [set $match] {
                          append temp "[file tail $x] "
                      }
                      append temp "[ESC]\[0m"
                  }
              }
              print "\n$temp\n"
          }
      } else {
          if {[file isdirectory $shortest] &&
              [string index $shortest end] != "/"} {
              append shortest "/"
          }
          if {$shortest != ""} {
              set CMDLINE \
                  [string replace $CMDLINE $wordstart $wordend $shortest]
              set CMDLINE_CURSOR \
                  [expr {$wordstart+[string length $shortest]}]
          } elseif { $COMPLETION_MATCH != " not found "} {
              set COMPLETION_MATCH " not found "
              print "\nNo match found.\n"
          }
      }
  }
  
  proc TclReadLine::handleHistory {x} {
      variable HISTORY_LEVEL
      variable CMDLINE
      variable CMDLINE_CURSOR
      
      set len [expr {[history nextid] -1}]
      if { $len > 0 } {
          if { [catch {incr HISTORY_LEVEL $x} index] } {
              set index [expr { $x==1 ? 0 : $len-1 }]
              set HISTORY_LEVEL $index
          }
          if { $len == 1 } {
              set cmd [history event 1]
          } else {
              set index [expr { int(fmod( $index, $len)) }]
              set id [expr {$len - $index}]
              set HISTORY_LEVEL $id
              set cmd [history event $id]
          }
          set CMDLINE $cmd
          set CMDLINE_CURSOR [string length $cmd]
      }
  }
  
  ################################
  # History handling functions
  ################################
  
  proc TclReadLine::getHistory {} {
      set l [list]
      set e [history nextid]
      for { set i 1 } {$i < $e} {incr i} {
          lappend l [history event $i]
      }
      return $l
  }
  
  proc TclReadLine::setHistory {hlist} {
      global env
      set env(HISTORY) $hlist
  }
  
  ################################
  # main()
  ################################
  
  proc TclReadLine::rawInput {} {
      fconfigure stdin -buffering none -blocking 0
      fconfigure stdout -buffering none -translation crlf
      exec stty raw -echo
  }
  
  proc TclReadLine::lineInput {} {
      fconfigure stdin -buffering line -blocking 1
      fconfigure stdout -buffering line
      exec stty -raw echo
  }
  
  proc TclReadLine::doExit {{code 0}} {
      variable HISTFILE
      
      # Reset terminal:
      #print "[ESC]c[ESC]\[2J" nowait
  
      restore ;# restore "info' command - 
      lineInput
  
      set hlist [getHistory]
      if {[llength $hlist] > 0} {
          set f [open $HISTFILE w]
          foreach x $hlist {
              # Escape newlines:
              puts $f [string map {
                  \n "\\n"
                  "\\" "\\b"
              } $x]
          }
          close $f
      }
  
      exit $code
  }
  
  proc TclReadLine::restore {} {
      lineInput
      rename ::unknown TclReadLine::unknown
      rename ::_unknown ::unknown
  }
  
  proc TclReadLine::interact {} {
  
      rename ::unknown ::_unknown
      rename TclReadLine::unknown ::unknown
  
      variable RCFILE
      if {[file exists $RCFILE]} {
          source $RCFILE
      }
  
      # Load history if available:
      variable HISTORY
      variable HISTFILE
  
      if { [info exists HISTORY] &&
           [llength $HISTORY] == 0} {
          if {[file exists $HISTFILE]} {
              set f [open $HISTFILE r]
              set hlist [list]
              foreach x [split [read $f] "\n"] {
                  if {$x != ""} {
                      # Undo newline escapes:
                      lappend hlist [string map {
                          "\\n" \n
                          "\\\\" "\\"
                          "\\b" "\\"
                      } $x]
                  }
              }
              setHistory $hlist
              unset hlist
              close $f
          }
      }
  
      rawInput
  
      # This is to restore the environment on exit:
      # Do not unalias this!
      alias exit TclReadLine::doExit
  
      variable ThisScript [info script]
  
      tclline ;# emit the first prompt
      
      fileevent stdin readable TclReadLine::tclline
      variable forever
      vwait TclReadLine::forever
  
      restore
  }
  
  proc TclReadLine::tclline {} {
      variable COLUMNS
      variable CMDLINE_CURSOR
      variable CMDLINE
  
      set char ""
      set keybuffer [read stdin]
      set COLUMNS [getColumns]
  
      while {$keybuffer != ""} {
          if {[eof stdin]} return
          set char [readbuf keybuffer]
          if {$char == ""} {
              # Sleep for a bit to reduce CPU overhead:
              after 40
              continue
          }
  
          if {[string is print $char]} {
              set x $CMDLINE_CURSOR
  
              if {$x < 1 && [string trim $char] == ""} continue
  
              set trailing [string range $CMDLINE $x end]
              set CMDLINE [string replace $CMDLINE $x end]
              append CMDLINE $char
              append CMDLINE $trailing
              incr CMDLINE_CURSOR
          } elseif {$char == "\t"} {
              handleCompletion
          } elseif {$char == "\n" || $char == "\r"} {
              if {[info complete $CMDLINE] &&
                  [string index $CMDLINE end] != "\\"} {
                  lineInput
                  print "\n" nowait
                  uplevel \#0 {
  
                      # Handle aliases:
                      set cmdline $TclReadLine::CMDLINE
                      set cmd [string trim [regexp -inline {^\s*[^\s]+} $cmdline]]
                      if {[info exists TclReadLine::ALIASES($cmd)]} {
                          regsub -- "(?q)$cmd" $cmdline $TclReadLine::ALIASES($cmd) cmdline
                      }
  
                      # Perform glob substitutions:
                      set cmdline [string map {
                          "\\*" \0
                          "\\~" \1
                      } $cmdline]
                      while {[regexp -indices \
                                  {([\w/\.]*(?:~|\*)[\w/\.]*)+} $cmdline x]
                         } {
                          foreach {i n} $x break
                          set s [string range $cmdline $i $n]
                          set x [glob -nocomplain -- $s]
                          
                          # If glob can't find anything then don't do
                          # glob substitution, pass * or ~ as literals:
                          if {$x == ""} {
                              set x [string map {
                                  "*" \0
                                  "~" \1
                              } $s]
                          }
                          set cmdline [string replace $cmdline $i $n $x]
                      }
                      set cmdline [string map {
                          \0 "*"
                          \1 "~"
                      } $cmdline]
  
                      rename ::info ::_info
                      rename TclReadLine::localInfo ::info
                      # Run the command:
                      catch {history add $cmdline exec} res
                      rename ::info TclReadLine::localInfo
                      rename ::_info ::info
                      if {$res != ""} {
                          TclReadLine::print "$res\n"
                      }
                      # Append HISTORY:
                      catch {unset TclReadLine::HISTORY_LEVEL}
  
                      set TclReadLine::CMDLINE ""
                      set TclReadLine::CMDLINE_CURSOR 0
                      set TclReadLine::CMDLINE_LINES {0 0}
                  } ;# end uplevel
                  rawInput
              } else {
                  set x $CMDLINE_CURSOR
  
                  if {$x < 1 && [string trim $char] == ""} continue
  
                  set trailing [string range $CMDLINE $x end]
                  set CMDLINE [string replace $CMDLINE $x end]
                  append CMDLINE $char
                  append CMDLINE $trailing
                  incr CMDLINE_CURSOR
              }
          } else {
              handleControls
          }
      }
      prompt $CMDLINE
  }
  
  TclReadLine::interact

----

I had issues with this code on Tcl 8.3. It looks like history command was adding empty lines to the history list. I have implemented a bandaid check for that:

In TclReadLine::tclline instead of: 

  catch {history add $cmdline exec} res

I put:

  if {$cmdline == "" } {
    set res ""
  } elseif { [regexp -- "^ +$" $cmdline]} {
    set res ""
  } else {
    catch {history add $cmdline exec} res
  }

Maybe it's too many checks but it started working for me after this change. [pn0].
----

[Category Dev. Tools]