slebetman: I've been using the console editor form Linux Console Text Editor In Pure TCL a lot and have modified it to suit my needs. The first thing I did was to add syntax hilighting mainly because I wanted to easily distinguish lines that I have commented out at a glance. Later I added other features and changed a lot of the underlaying engine. Rather than backport my changes to the original code I decided to post my code here and leave the original code alone.
The following are some of the features of the editor:
The code is quite messy. A lot of the procs here are not functions but merely act like macros which are upleveled and evaluated in the caller's context. I simply moved them to procs to make it easier for me to see the program logic. The syntax hilighting rules are also hardcoded into the code but is easy enough to modify.
The control character and escape sequence handling have been re-written to be more general and to report unhandled cases. This is to make it easier to add new features to the code. For example, if you want to implement a feature and bind it to ^k just run the editor and press ^k. It will tell you "Unhandled control character:0xb" so that you know you should add the code as a \u000b case in handleControls. The same goes for escape sequences. For example, pressing F12 will generate the message "Unhandled sequence:[24~"
slebetman 21 June 2006: An updated version with improved tab handling. Added some more key bindings to support xterm, rxvt and Hyperterminal (yes, I really did test it on Hyperterminal). I also back-ported SRIV's unique long-line editing method to this code which simplified my rendering engine.
#! /usr/bin/env tclsh
# con-editor.tcl a linux console based editor in pure tcl
set filename [lindex $argv 0]
set searchpattern ""
set statusmessage ""
set modified 0
set tabstop 4
array set bg {
black 40 red 41 green 42 yellow 43
blue 44 magenta 45 cyan 46 white 47
}
array set fg {
black 30 red 31 green 32 yellow 33
blue 34 magenta 35 cyan 36 white 37
}
array set style {
none 0 bright 1 dim 2
underline 4 blink 5 reverse 7
}
# Syntax hilighting:
set syntaxRules {
# The syntax rules is in the form:
# {regexp} {formatting}
# Each rule must be on a single line.
# Comments will be ignored.
# Strings & numbers:
{".*?"} {$fg(magenta)}
{[0-9]+} {$fg(magenta)}
# Script comments/C preprocessing
{^#!.*$} {$style(bright);$fg(green);$bg(blue)}
{(?:^|;)\s*#.*$} {$fg(green)}
# Script style variables:
{(?i)\$[a-z_][a-z0-9_]*} {$style(bright);$fg(cyan)}
{(?i)[\@\%][a-z_][a-z0-9_]*} {$style(bright);$fg(yellow)}
# Tcl variables after a set command:
{(?:set|append|incr) ([a-zA-Z_][a-zA-Z0-9_]*)} {$fg(cyan)}
# Email address:
{(?i)(?:[a-z0-9-]+\.)*[a-z0-9-]+\@(?:[a-z0-9-]+\.)*[a-z0-9-]+} {$style(bright)}
# Backtick exec:
{`.*?`} {$bg(yellow);$fg(black)}
}
foreach rule [split $syntaxRules "\n"] {
set rule [string trim $rule]
if {$rule != "" && [string index $rule 0] != "#"} {
foreach {pattern attr} $rule break
lappend hilight $pattern [subst $attr]
}
}
proc readbuf {txt} {
upvar 1 $txt STRING
upvar 1 fid fid
set ret [string index $STRING 0]
set STRING [string range $STRING 1 end]
if {$STRING == ""} {
append STRING [read $fid]
}
return $ret
}
proc endLine {} {
global BUFFER
upvar 1 bufRow bufRow
upvar 1 bufCol bufCol
set x [string length [lindex $BUFFER $bufRow]]
if {$bufCol > $x} {
set bufCol $x
}
}
proc getSpaces {line} {
global tabstop
set ret [lindex [regexp -inline {^[[:space:]]+} $line] 0]
string map [list [string repeat " " $tabstop] "\t"] $ret
}
proc handleDelete {dir} {
global BUFFER
upvar 1 bufCol bufCol
upvar 1 bufRow bufRow
upvar 1 line line
set line [lindex $BUFFER $bufRow]
if {$dir == "-"} {
if {$bufCol == 0 && $bufRow > 0} {
uplevel 1 {
set upRow [expr {$bufRow-1}]
set line [lindex $BUFFER $upRow]
set bufCol [string length $line]
append line [lindex $BUFFER $bufRow]
set BUFFER [lreplace $BUFFER $upRow $bufRow $line]
incr viewRow -1
set bufRow $upRow
handleRedraw partial
}
return
}
incr bufCol -1
} else {
if {$bufCol == [string length $line] && $bufRow < [llength $BUFFER]} {
uplevel 1 {
set downRow [expr {$bufRow+1}]
append line [lindex $BUFFER $downRow]
set BUFFER [lreplace $BUFFER $bufRow $downRow $line]
handleRedraw partial
}
return
}
}
uplevel 1 {
set line [string replace $line $bufCol $bufCol]
set BUFFER [lreplace $BUFFER $bufRow $bufRow $line]
handleRedraw edit
}
return
}
proc syntaxHilight {line start {charmap ""}} {
global hilight IDX
set tabmap "\t"
if {$charmap != ""} {
set tabmap $charmap
}
set matches ""
set end [expr {$start+$IDX(COLMAX)-1}]
foreach {pattern color} $hilight {
set ps 0
set pn 0
foreach m [regexp -inline -all -indices -- $pattern $line] {
foreach {s n} $m break
lappend m $color
if {$s <= $pn && $s >= $ps && $n <= $pn} {
set matches [lreplace $matches end end $m]
} else {
lappend matches $m
}
set ps $s
set pn $n
}
}
set oldline [string range $line $start $end]
set line {}
set prev 0
foreach m [lsort -integer -index 0 $matches] {
foreach {s n color} $m break
if {$s < $start} {
set s 0
} else {
set s [expr {$s-$start}]
}
set n [expr {$n-$start}]
if {$n > $end} {set n $end}
if {$s < $prev} continue
append line [string range $oldline $prev [expr {$s-1}]]
set prev [expr {$n+1}]
append line "\033\[${color}m"
append line [string range $oldline $s $n]
if {$n != $end} {
append line "\033\[0m"
}
}
append line [string range $oldline $prev end]
append line "\033\[0m"
#string map [list "\377" $charmap "\t" $tabmap] $line
return $line
}
proc handleSearch {} {
uplevel 1 {
global searchpattern
status "Search: $searchpattern"
if {$searchpattern != ""} {
if {[catch {lsearch -regexp [lrange $BUFFER \
[expr {$bufRow+1}] end] $searchpattern} found]} {
# Regexp error:
status $found
} else {
if {$found == -1} {
set found [lsearch -regexp $BUFFER $searchpattern]
if {$found != -1} {
set bufRow $found
}
} else {
incr bufRow $found
incr bufRow
}
if {$found != -1} {
set C [regexp -indices -inline $searchpattern \
[lindex $BUFFER $bufRow]]
set bufCol [lindex [lindex $C 0] 0]
if {$bufRow < $viewRow} {
set viewRow 0
}
} else {
status "Search: $searchpattern (not found!)"
}
}
} else {
status ""
}
handleRedraw
}
}
proc getInput {buffer {txt ""}} {
upvar 1 $buffer keybuffer
upvar 1 fid fid
upvar 1 viewRow viewRow
upvar 1 viewCol viewCol
status ""
goto end 1
puts -nonewline "\033\[7m$txt "
flush stdout
set ret ""
while {[set ch [readbuf keybuffer]] != "\n" && $ch != "\r"} {
if {$ch == ""} {
after 40
continue
}
if {$ch == "\u0003"} {
doExit
} elseif {$ch == "\u001b"} {
# escape:
if {$keybuffer == ""} {
return
}
# need to ignore escapes sequences:
while {[set ch [readbuf keybuffer]] != "~"
&& $keybuffer != ""} {}
continue
} elseif {$ch == "\u007f"} {
# handle backspace:
set ret [string range $ret 0 end-1]
} elseif {[string is print $ch]} {
append ret $ch
}
set stat "$txt $ret"
set len [expr [string length $stat]+1]
status $stat
goto end $len
flush stdout
}
return $ret
}
proc handleEscapes {} {
uplevel 1 {
set seq ""
set found 1
while {[set ch [readbuf keybuffer]] != ""} {
append seq $ch
set found 1
switch -exact -- $seq {
"\[A" { ;# Cursor Up (cuu1,up)
if {$bufRow > 0} {
set tmp $bufCol
set bufCol 0
handleRedraw line
set bufCol $tmp
incr bufRow -1
incr viewRow -1
}
endLine
handleRedraw
break
}
"\[B" { ;# Cursor Down
if {$bufRow < [expr {[llength $BUFFER] - 1}]} {
set tmp $bufCol
set bufCol 0
handleRedraw line
set bufCol $tmp
incr bufRow 1
incr viewRow 1
}
endLine
handleRedraw
break
}
"\[C" { ;# Cursor Right (cuf1,nd)
if {$bufCol < [string length [lindex $BUFFER $bufRow]]} {
incr bufCol 1
}
handleRedraw line
break
}
"\[D" { ;# Cursor Left
if {$bufCol > 0} {
incr bufCol -1
}
handleRedraw line
break
}
"\[H" -
"\[7~" -
"\[1~" { ;# home
set line [lindex $BUFFER $bufRow]
set homeCol [regexp \
-indices -inline -- \
{^[[:space:]]*} $line]
set homeCol [lindex [lindex $homeCol 0] 1]
incr homeCol
if {$bufCol != $homeCol} {
set bufCol $homeCol
} else {
set bufCol 0
}
handleRedraw line
break
}
"\[3~" { ;# delete
handleDelete +
break
}
"\[K" -
"\[8~" -
"\[4~" { ;# end
set bufCol [string length [lindex $BUFFER $bufRow]]
handleRedraw line
break
}
"\[5~" { ;# 5 Prev screen
set size [expr {$IDX(ROWMAX) - 1}]
if {$bufRow < $size} {
set bufRow 0
set viewRow 1
} else {
incr bufRow -$size
incr viewRow -$size
}
endLine
handleRedraw
break
}
"\[6~" { ;# 6 Next screen
set size [expr {$IDX(ROWMAX) - 1}]
incr bufRow $size
incr viewRow $size
if {$bufRow >= [llength $BUFFER]} {
set viewRow [llength $BUFFER]
set bufRow [expr {$viewRow - 1}]
}
endLine
handleRedraw
break
}
"OR" -
"\[13~" { ;# F3
handleSearch
break
}
default {
set found 0
}
}
}
if {$found == 0} {
status "Unhandled sequence:$seq ([string length $seq])"
flush stdout
}
}
}
proc handleNewline {} {
uplevel 1 {
# The getSpaces is for auto-indenting:
set newline [getSpaces $line]
set currline [string range $line 0 [expr {$bufCol - 1}]]
set line [string range $line $bufCol end]
set BUFFER [lreplace $BUFFER $bufRow $bufRow $currline]
incr bufRow
if {$keybuffer == "" && [regexp {^\s} $line] == 0} {
set len [string length $newline]
append newline $line
set bufCol $len
} else {
set newline $line
set bufCol 0
}
set BUFFER [linsert $BUFFER $bufRow $newline]
handleRedraw partial
incr viewRow
handleRedraw
}
}
proc handleControls {} {
uplevel 1 {
# Control chars start at a == \u0001 and count up.
switch -exact -- $char {
\u0011 { ;# ^q - quit
return done
}
\u0001 { ;# ^a - beginning of line
set bufCol 0
handleRedraw line
}
\u0003 { ;# ^c
doExit 1
}
\u0004 { ;# ^d - delete line
if {$bufRow < [llength $BUFFER]} {
set BUFFER [lreplace $BUFFER $bufRow $bufRow]
handleRedraw partial
}
}
\u0005 { ;# ^e - end of line
set bufCol [string length $line]
handleRedraw line
}
\u0006 { ;# ^f - find/search
global searchpattern
set searchpattern [getInput keybuffer "Search:"]
handleSearch
}
\u0007 { ;# ^g - goto line
if {[set n [getInput keybuffer "Goto Line:"]] != "" &&
[string is integer $n]
} {
set bufRow [expr {$n-1}]
if {$bufRow < $viewRow} {
set viewRow 0
} else {
set len [llength $BUFFER]
if {$bufRow > $len} {
set bufRow [expr {$len-1}]
}
}
} else {
status ""
}
handleRedraw
}
\u0013 { ;# ^s - save file
saveFile
}
\u0008 -
\u007f { ;# ^h && backspace ?
handleDelete -
}
\u001b { ;# ESC - handle escape sequences
handleEscapes
}
default {
binary scan $char c ch
status "Unhandled control character:[format 0x%x $ch]"
flush stdout
}
}
# Rate limiter:
set keybuffer ""
}
}
proc handleInsert {} {
uplevel 1 {
set line [lindex $BUFFER $bufRow]
set oldline $line
set line [string range $oldline 0 [expr $bufCol - 1]]
append line [getSpaces $printbuffer]
append line [string trimleft $printbuffer]
append line [string range $oldline $bufCol end]
set BUFFER [lreplace $BUFFER $bufRow $bufRow $line]
set len [string length $printbuffer]
incr bufCol $len
}
}
proc linerange {} {
global BUFFER tabstop
upvar 1 col col
upvar 1 row row
upvar 1 bufCol bufCol
# translate viewCol to proper index (account for tabs)
# let's just brute force over the line
set col 0
set i 0
set line ""
foreach c [split [lindex $BUFFER $row] ""] {
if {$c == "\t"} {
set n [expr {$tabstop-$col%$tabstop}] ;# align to tabs
if {$i < $bufCol} {incr col $n}
append line [string repeat " " $n]
} else {
if {$i < $bufCol} {incr col}
append line $c
}
incr i
}
incr col
return $line
}
proc handleRedraw {{mode "full"}} {
# Valid modes are: full(default), line, edit, partial
global IDX BUFFER tabstop
upvar 1 viewRow viewRow
upvar 1 viewCol viewCol
upvar 1 bufRow bufRow
upvar 1 bufCol bufCol
cursor off
# Constrain current view idx
set inview 1
if {$viewRow <= 1} {set viewRow 1}
if {$viewRow >= ($IDX(ROWMAX) - 1)} {
set viewRow [expr {$IDX(ROWMAX) - 1}]
set inview 0
}
set startRow [expr {$bufRow + 1 - $viewRow}]
# start and end view area to display
if {$mode == "partial" && $inview} {
set start $bufRow
goto $viewRow 1
} else {
set start $startRow
home
}
#flush stdout
set row $bufRow
if {$mode == "full" || $mode == "partial"} {
if {$IDX(ROWLAST) != $startRow || $mode == "partial"} {
# Add display size to get end points
set endRow [expr {$startRow + $IDX(ROWMAX) - 1}]
# set endCol [expr {$startCol + $IDX(COLMAX) - 1}]
for {set row $start} {$row < $endRow} {incr row} {
if {$row == $bufRow} {
puts ""
} else {
set line [linerange]
# puts -nonewline "\u001b\[K" ; # erase current line
clearline
puts [syntaxHilight $line 0]
if {$row%24 == 0} {
# Some ttys can't handle large dumps so we
# limit each dump to around 20 lines:
flush stdout
}
}
}
}
}
set row $bufRow
set line [linerange]
set viewCol $col
if {$viewCol >= $IDX(COLMAX)} {set viewCol $IDX(COLMAX)}
if {$IDX(ROWLAST) != $startRow ||
$mode == "line" ||
$mode == "edit" ||
$mode == "partial"
} {
set startCol [expr {$col - $viewCol}]
if {$mode != "line" || $IDX(COLLAST) != $startCol} {
goto $viewRow 1
clearline
puts [syntaxHilight $line $startCol " "]
set IDX(COLLAST) $startCol
}
}
if {$IDX(ROWLAST) != $startRow} {
set IDX(ROWLAST) $startRow
}
idx [expr {$bufRow + 1}] [expr {$bufCol+1}]
goto $viewRow $viewCol
cursor on
flush stdout
}
proc edittext {fid} {
global BUFFER IDX
set viewRow 1 ; # row idx into view area, 1-based
set viewCol 1 ; # col idx into view area, 1-based
set bufRow 0 ; # row idx into full buffer, 0-based
set bufCol 0 ; # col idx into full buffer, 0-based
set IDX(ROWLAST) -1 ; # last row most recently displayed in view
set IDX(COLLAST) -1
set char "" ; # last char received
set line [lindex $BUFFER $bufRow] ; # line data of current line
handleRedraw
home; flush stdout
set keybuffer ""
set printbuffer ""
set timestamp [clock seconds]
set prevRow $bufRow
while {$char != "\u0011"} {
append keybuffer [read $fid]
if {[eof $fid]} {return done}
if {$keybuffer == ""} {
set now [clock seconds]
if {$now != $timestamp} {
set timestamp $now
set changed 0
getRowColMax
if {$changed} {
handleRedraw
}
}
if {$printbuffer != ""} {
handleInsert
if {$prevRow != $bufRow} {
set prevRow $bufRow
handleRedraw
}
handleRedraw edit
set printbuffer ""
}
after 40
continue
}
set char [readbuf keybuffer]
if {[string is print $char] || $char == "\t"} {
append printbuffer $char
} elseif {$char == "\n" || $char == "\r"} {
handleInsert
handleNewline
if {$keybuffer == ""} {
handleRedraw
}
set printbuffer ""
} else {
handleControls
set prevRow $bufRow
}
}
}
proc status {args} {
global IDX statusmessage
if {[llength $args] != 0} {
set statusmessage [join $args " "]
}
set len $IDX(ROWCOL)
set str [format "%-${len}.${len}s" $statusmessage]
puts -nonewline "\033\[7m\u001b\[$IDX(ROWMAX);00H$str\033\[0m"
#flush stdout
}
proc idx {row col} {
global IDX BUFFER
set c $IDX(ROWCOL)
set r $IDX(ROWMAX)
set str [format " L:%-9s C:%-4d\033\[0m" "$row/[llength $BUFFER]" $col]
# the string must not exceed $IDX(ROWCOLLEN) length
set str [string range $str 0 $IDX(ROWCOLLEN)]
puts -nonewline "\033\[7m\u001b\[${r};${c}H${str}\033\[0m"
#flush stdout
}
proc home {} { goto 1 1 }
proc goto {row col} {
global IDX
if {$row == "end"} {
set row $IDX(ROWMAX)
}
puts -nonewline "\u001b\[${row};${col}H"
}
proc clear {} {
puts -nonewline "\u001b\[2J"
flush stdout
}
proc clearline {} {
puts -nonewline "\u001b\[2K"
}
proc cursor {bool} {
puts -nonewline "\u001b\[?[expr \
{$::IDX(ROWMAX)+1}][expr {$bool ? "h" : "j"}]"
}
#start of console editor program
proc getRowColMax {} {
uplevel 1 {
if {![catch {exec stty -a} err]
&& [regexp {rows (\d+); columns (\d+)} $err -> rows cols]} {
if {$rows != 0 && $cols != 0} {
if {$rows != $IDX(ROWMAX)} {
set IDX(ROWMAX) $rows
set changed 1
}
if {$cols != $IDX(COLMAX)} {
set IDX(COLMAX) $cols
set changed 1
}
}
}
if {$changed} {
set IDX(ROWCOL) [expr {$IDX(COLMAX) - $IDX(ROWCOLLEN)}]
status
idx $bufRow $bufCol
set IDX(ROWLAST) -1 ;# force redraw
}
}
}
proc saveFile {} {
global filename BUFFER modified
if {!$modified} return
status "Save '$filename'? Y/n"
flush stdout
fconfigure stdin -blocking 1
while 1 {
set line [read stdin 1]
if {$line == "y" || $line == "Y" || $line == "\n"} {
set outfile [open $filename w ]
for {set i 0} {$i<[expr [llength $BUFFER]-1]} {incr i} {
puts $outfile [lindex $BUFFER $i]
}
puts -nonewline $outfile [lindex $BUFFER end]
close $outfile
status " Saved '$filename' ([llength $BUFFER] lines)"
set modified 0
break
} elseif {$line == "n" || $line == "N"} {
status " Aborted"
break
}
}
flush stdout
fconfigure stdin -blocking 0
}
proc bufferModified {args} {
global modified
set modified 1
}
proc console_edit {fileName} {
global BUFFER IDX tabstop
# Script-Edit by Steve Redler IV 5-30-2001
set IDX(ROWMAX) 24
set IDX(COLMAX) 80
set IDX(ROWCOLLEN) 18
set changed 1
set bufRow 0
set bufCol 0
set infile [open $fileName RDWR]
set BUFFER [split [read $infile] "\n"]
close $infile
trace variable BUFFER w bufferModified
getRowColMax
clear ; home
status "$fileName loaded"
idx [llength $BUFFER] 1
fconfigure stdin -buffering none -blocking 0 -encoding iso8859-1
fconfigure stdout -buffering full -translation crlf -encoding iso8859-1
flush stdout
exec stty raw -echo
set err [catch {edittext stdin}]
if {$err == 0} {
saveFile
}
doExit $err
}
proc doExit {{err 0}} {
# Reset terminal:
puts -nonewline "\033c"
if {$err} {
global errorInfo
puts $errorInfo
}
flush stdout
exec stty -raw echo
after 100
exit 0
}
if {$filename == ""} {
puts "\nPlease specify a filename"
gets stdin filename
if {$filename == ""} {exit}
}
console_edit $filenameSRIV I really like the addition of color. The one issue I found was that the editor consumes 100% cpu while waiting for a keystoke. Easily noticable for me since I'm on a notebook.
slebetman Yeah, this implementation uses busy polling the non-blocking stdin. In lieu of Tk's event loop this was the quickest hack I could think of to get the auto-resizing and fast-pasting to work. Of course we can reduce CPU consumption by using after and vwait. In fact, something like after 100 is responsive and fast enough for a human to not notice yet will reduce CPU consumption by more than 85% (depending on your CPU MHz of course).
slebetman I've added a couple of after 50 in the input loops which should limit the polling rate down to 20Hz max. This is still an ugly hack but on my machine it brought down CPU usage from 75%-99.9% to 0.2%-5%.