package provide TclReadLine 1.1
#! /usr/bin/env tclsh
# tclline: An attempt at a pure tcl readline.
# Use Tclx if available:
catch {
ggpackage 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 COMPLETION_MATCH ""
variable CMDLINE ""
variable CMDLINE_CURSOR 0
variable CMDLINE_LINES 0
variable ALIASES
array set ALIASES {}
variable forever 0
# Resource and history files:
variable HISTORY_SIZE 100
variable HISTORY_LEVEL 0
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 HISTORY_SIZE
variable CMDLINE
variable CMDLINE_CURSOR
set lastid [expr [history nextid] - 1]
# puts "$lastid $HISTORY_LEVEL \n [history]"
if {$lastid > 0} {
if {$lastid > $HISTORY_SIZE} {
set cmdoffset [expr $HISTORY_LEVEL % $HISTORY_SIZE]
} else {
set cmdoffset [expr $HISTORY_LEVEL % $lastid]
}
set id [expr $lastid - $cmdoffset]
set cmd [history event $id]
set CMDLINE $cmd
set CMDLINE_CURSOR [string length $cmd]
set HISTORY_LEVEL [incr HISTORY_LEVEL $x]
}
}
################################
# History handling functions
################################
proc TclReadLine::getHistory {} {
variable HISTORY_SIZE
set l [list]
set e [history nextid]
set i [expr $e - $HISTORY_SIZE]
if {$i <= 0} {
set i 1
}
for {} {$i < $e} {incr i} {
lappend l [history event $i]
}
return $l
}
proc TclReadLine::setHistory {hlist} {
foreach event $hlist {
history add $event
}
}
################################
# 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]
#
# Get rid of the TclReadLine::doExit, shouldn't be more than one
#
set indice [lsearch $hlist "TclReadLine::doExit"]
set hlist [lreplace $hlist $indice $indice]
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 {[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
}
variable HISTORY_SIZE
history keep $HISTORY_SIZE
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"
}
# Reset HISTORY_LEVEL before next command
set TclReadLine::HISTORY_LEVEL 0
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::interactI 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} resI 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.
2009-06-18 pn0 I came up with idea of a little shorter TclReadLine::handleHistory.
proc TclReadLine::handleHistory {x} {
variable HISTORY_LEVEL
variable CMDLINE
variable CMDLINE_CURSOR
set len [expr {[history nextid] -1}]
set index [expr {$len - ($len + $HISTORY_LEVEL + $x) % ($len + 1)}]
set HISTORY_LEVEL [expr {$len + 1 -$index }]
if {$index == 0 } {
set cmd ""
} else {
set cmd [history event $index]
}
set CMDLINE $cmd
set CMDLINE_CURSOR [string length $cmd]
}That requres initialization of HISTORY_LEVEL in the namespace eval and resetting it to 0 after command is executed.
2009-11-01 MJS
The regexp for parsing the output of stty -a doesn't work for BSD flavours (e.g. Darwin). This is marginally more portable:
proc TclReadLine::getColumns {} {
set cols 0
if {![catch {exec stty -a} err]} {
# match for BSD stty
regexp {(\d+) rows; (\d+) columns;} $err junk rows cols
if {$cols == 0} {
# match for Linux (etc) stty
regexp {rows (= )?(\d+); columns (= )?(\d+)} $err junk i1 rows i2 cols
}
}
return $cols
}It might be faster to use scan vs. firing up the regex engine, especially as this is called for every character input. Alternatively, if Tclx is available it makes more sense to trap SIGWINCH and update COLUMNS in the handler.
wdb works fine. How to manage that it is executed automatically on invoking tclsh?
LV See tclshrc for a suggestion.
RLH Does this mean readline can now work in tclsh?
LV I think it means that the code on this page works in tclsh. As long as that is what you mean by readline, then sure.
LVwikignome - 2009-12-16 08:33:33
If this code appears to be working well, perhaps it would be worthwhile considering adding it to tcllib or some similar commonly distributed package so that it is available readily.