#########################################################################
# term.tcl - basic terminal manipulation and line editing.
#           (Hacked from the uparrow package written by Tom Holroyd.)
#
# Copyright (C) 1997-1999 Mark Patton
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#########################################################################

namespace eval term {
    array set rl {
        chars      {}
        cursor     0
        hist_loc   1
        hist_cur   ""
	history    {""}
	clearonhit 0
    }
    
    array set bind {
        "\x0A"      rl_newline
	"\x04"      exit
	"\x01"      rl_goto_beg
        "\x05"      rl_goto_end
        "\x15"      rl_clear_tobeg
        "\x0B"      rl_clear_toend
	"\x7F"      rl_delete
	"\x08"      rl_backspace
	"\x1B"      rl_esc
        "\x1B\[A"   rl_histup
        "\x1B\[B"   rl_histdown
        "\x1B\[C"   rl_right
        "\x1B\[D"   rl_left
        "\x1BOA"    rl_histup
        "\x1BOB"    rl_histdown
        "\x1BOC"    rl_right
        "\x1BOD"    rl_left
    }

    if {[string equal $env(TERM) "linux"]} {
        array set bind {
    	    "\x7F"      rl_backspace
    	}
    }
}

proc term::save_pos {} {
    puts -nonewline \0337
    return
}

proc term::restore_pos {} {
    puts -nonewline \0338
    return
}

proc term::goto_rowcol {row cursor} {
    puts -nonewline \033\[${row}\;${cursor}f
    return
}

proc term::erase_screen {{n ""}} {
    puts -nonewline \033\[${n}J
    return
}

proc term::erase_line {{n ""}} {
    puts -nonewline \033\[${n}K
    return
}

proc term::reset {} {
    puts -nonewline \033c
    return
}

proc term::scroll_region {top bottom} {
    puts -nonewline \033\[${top}\;${bottom}r
    return
}

proc term::move_right {{n ""}} {
    puts -nonewline \033\[${n}C
    return
}

proc term::move_left {{n ""}} {
    puts -nonewline \033\[${n}D
    return
}

proc term::delete {{n ""}} {
    puts -nonewline \033\[${n}P
    return
}

proc term::bell {} {
    puts -nonewline \a
    return
}

proc term::rows {} {
    global env

    if {[info exists env(LINES)]} {
	set rows $env(LINES)
    } else {
	if {[catch {lindex [exec stty size] 0} rows]} {
	    if {[catch {exec tput lines <@stdin} rows]} {
		set rows 24	
	    }
	}
    }
    
    return $rows
}

# turn one-character-at-a-time mode on or off (Unix only)

proc term::cbreak {bool} {
    if {$bool} {
	exec stty -icanon -echo min 1 <@ stdin
    } else {
	exec stty icanon echo min 4 <@ stdin
    }

    return
}

proc term::rl_insert {c} {
    variable rl 

    puts -nonewline \x1B\[@$c
    set rl(chars) [linsert $rl(chars) $rl(cursor) $c]
    incr rl(cursor)

    return
}

proc term::rl_goto_beg {} {
    variable rl 

    if {$rl(cursor) > 0} {
        move_left $rl(cursor)
        set rl(cursor) 0
    }
    
    return
}

proc term::rl_goto_end {} {
    variable rl

    if {$rl(cursor) < [llength $rl(chars)]} {
        move_right [expr {[llength $rl(chars)] - $rl(cursor)}]
        set rl(cursor) [llength $rl(chars)]
    }
    
    return
}

proc term::rl_backspace {} {
    variable rl

    if {$rl(cursor) > 0} {
        move_left
	delete
	incr rl(cursor) -1
        set rl(chars) [lreplace $rl(chars) $rl(cursor) $rl(cursor)]
    }

    return
}

proc term::rl_delete {} {
    variable rl 

    if {$rl(cursor) < [llength $rl(chars)]} {
        delete
        set rl(chars) [lreplace $rl(chars) $rl(cursor) $rl(cursor)]
    }

    return
}

# esc begins a two-character subcommand.

proc term::rl_esc {} {
    variable bind

    append code \x1B [read stdin 2]
    if {[info exists bind($code)]} {
        $bind($code)
    }
    
    return
}

proc term::rl_right {} {
    variable rl

    if {$rl(cursor) < [llength $rl(chars)]} {
        move_right 
        incr rl(cursor) 1
    }

    return
}

proc term::rl_left {} {
    variable rl 

    if {0 < $rl(cursor)} {
        move_left 
        incr rl(cursor) -1
    }

    return
}

proc term::rl_set {line} {
    variable rl

    rl_goto_beg
    rl_clear_toend
    puts -nonewline $line
    set rl(chars) [split $line ""]
    set rl(cursor) [llength $rl(chars)]
    
    return
}

proc term::rl_get {} {
    variable rl

    return [join $rl(chars) ""]
}

proc term::rl_history {} {
    variable rl
    
    return $rl(history)
}

proc term::rl_histup {} {
    variable rl

    if {$rl(hist_loc)} {
	if {$rl(hist_loc) == [llength $rl(history)]} {
	    set rl(hist_cur)  [join $rl(chars) ""]
	}
	rl_set [lindex $rl(history) [incr rl(hist_loc) -1]]
    }
    
    return
}

proc term::rl_set_cursor {pos} {
    variable rl

    if {$rl(cursor) > $pos} {
	move_left [expr {$rl(cursor) - $pos}]
    } elseif {$rl(cursor) < $pos} {
	move_right [expr {$rl(cursor) - $pos}]
    }

    set rl(cursor) $pos

    return
}

proc term::rl_histdown {} {
    variable rl

    if {[incr rl(hist_loc)] == [llength $rl(history)]} {
	rl_set $rl(hist_cur)
    } elseif {$rl(hist_loc) > [llength $rl(history)]} {
	incr rl(hist_loc) -1
    } else {
	rl_set [lindex $rl(history) $rl(hist_loc)]
    }
    
    return
}

proc term::rl_clear_tobeg {} {
    variable rl

    if {$rl(cursor) > 0} {
        move_left $rl(cursor)
        delete $rl(cursor)
        set rl(chars) [lrange $rl(chars) $rl(cursor) end]
        set rl(cursor) 0
    }
    
    return
}

proc term::rl_clear_toend {} {
    variable rl
    
    erase_line
    set rl(chars) [lrange $rl(chars) 0 [expr {$rl(cursor) - 1}]]

    return
}

proc term::rl_newline {} {
    variable rl
	
    $rl(proc) [join $rl(chars) ""]

    return
}

proc term::rl_hist_add {input max} {
    variable rl

    set rl(history) [lreplace $rl(history) 0 \
	    [expr {[llength $rl(history)] - $max}]]
    lappend rl(history) $input
    set rl(hist_loc) [llength $rl(history)]

    return
}

proc term::rl_cursor {} {
    variable rl

    return $rl(cursor)
}

# clear the line on the next key
# that isn't bound
proc term::rl_clearonhit {bool} {
    variable rl

    set rl(clearonhit) $bool
    return
}

# loop forever doing command line editing and
# calling proc when newline occurs.

proc term::rl_loop {proc} {
    variable rl

    set rl(proc) $proc 
    
    fconfigure stdin -buffering none    
    fconfigure stdout -buffering none
    cbreak 1
     
    fileevent stdin readable term::rl_readchar
}

rename exit _exit
proc exit {{code 0}} {
    term::cbreak 0
    term::reset
    _exit $code
}

proc term::rl_readchar {} {
    variable rl
    variable bind

    set c [read stdin 1] 
    
    if {[info exists bind($c)]} {
	$bind($c)
    } else {
        if {$rl(clearonhit)} {
            rl_goto_beg
            rl_clear_toend
	    set rl(clearonhit) 0
        }
	rl_insert $c
    }

     return
}
