======
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::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].

----
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.

----
[tb] - 2009-12-16 - I just sourced this code into a tclkit-8.5.1 and noticed I had to escape the star in:

 info proc ::TclReadLine::\*

[AM} Yes, I can confirm that. Though: 

 info proc ::TclReadLine::g*

or
 
 info proc ::TclReadline::*g*

does work, so it seems to be a problem with a bare asterisk only. (The command that is stored contains the list of files that are present ...)


----
'''[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.

----
'''[arjen] - 2009-12-18 05:48:42'''

I copied the code verbatim and had no problem whatsoever.

Nice work! (It really acts as an interactive shell, so that you can run external commands like ls and vi)

<<categories>>Category Dev. Tools