#!/bin/sh
# -*- tcl -*-
# The next line is executed by /bin/sh, but not tcl \
exec tclsh "$0" ${1+"$@"}

# This file is based on "example/virterm" from the expect-5.45 distribution,
# removing its script to interrogate the Cornell Library catalog.
#
#	Martin Guy <martinwguy@gmail.com>, January 2017.

package require Expect

# Name: virterm - terminal emulator using Expect, v1.0, December, 1994
# Author: Adrian Mariano <adrian@cam.cornell.edu>
#
# Derived from Don Libes' tkterm

# This is a program for interacting with applications that use terminal
# control sequences.  It is a subset of Don Libes' tkterm emulator
# with a compatible interface so that programs can be written to work
# under both.
#
# Internally, it uses arrays instead of the Tk widget.  Nonetheless, this
# code is not as fast as it should be.  I need an Expect profiler to go
# any further.
#
# standout mode is not supported like it is in tkterm.
# the only terminal widget operation that is supported for the user
# is the "get" operation.

###############################################
# Variables that must be initialized before using this:
#############################################
set rows 24		;# number of rows in term
set cols 80		;# number of columns in term
set term myterm		;# name of text widget used by term
set termcap 1		;# if your applications use termcap
set terminfo 1		;# if your applications use terminfo
			;# (you can use both, but note that
			;# starting terminfo is slow)
set term_shell $env(SHELL) ;# program to run in term

#############################################
# Readable variables of interest
#############################################
# cur_row		;# current row where insert marker is
# cur_col		;# current col where insert marker is
# term_spawn_id		;# spawn id of term

#############################################
# Procs you may want to initialize before using this:
#############################################

# term_exit is called if the associated proc exits
proc term_exit {} {
	exit
}

# term_chars_changed is called after every change to the displayed chars
# You can use if you want matches to occur in the background (a la bind)
# If you want to test synchronously, then just do so - you don't need to
# redefine this procedure.
proc term_chars_changed {} {
}

# term_cursor_changed is called after the cursor is moved
proc term_cursor_changed {} {
}

# Example tests you can make
#
# Test if cursor is at some specific location
# if {$cur_row == 1 && $cur_col == 0} ...
#
# Test if "foo" exists anywhere in line 4
# if {[string match *foo* [$term get 4.0 4.end]]}
#
# Test if "foo" exists at line 4 col 7
# if {[string match foo* [$term get 4.7 4.end]]}
#
# Return contents of screen
# $term get 1.0 end

#############################################
# End of things of interest
#############################################

# Terminal definitions are provided in both termcap and terminfo
# styles because we cannot be sure which a system might have.  The
# definitions generally follow that of xterm which in turn follows
# that of vt100.  This is useful for the most common archaic software
# which has vt100 definitions hardcoded.

set blankline ""
set env(LINES) $rows
set env(COLUMNS) $cols

if {$termcap} {
    set env(TERM) "tt"
    set env(TERMCAP) {tt:
	:am:bs:xn:
	:ks=\E[?1h\E:
	:ke=\E[?1l\E>:
	:cm=\E[%i%d;%dH:
	:le=\b:
	:up=\E[A:
	:nd=\E[C:
	:cl=\E[H\E[J:
	:ce=\E[K:
	:do=\n:
	:sf=\n:
	:cr=\r:
	:so=\E[7m:
	:se=\E[m:
	:ku=\EOA:kd=\EOB:kr=\EOC:kl=\EOD:
	:kh=\EOH:@7=\EOF:kP=\E[5~:kN=\E[6~:
	:kI=\E[2~:kD=\E[3~:
	:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:k5=\EOT:
	:k6=\EOU:k7=\EOV:k8=\EOW:k9=\EOX:k;=\EOY:
    }
}

if {$terminfo} {
    # ncurses ignores 2-char term names so use a longer name here
    set env(TERM) "virterm"
    set env(TERMINFO) /tmp
    set ttsrc "/tmp/virterm.src"
    set file [open $ttsrc w]

    puts $file {virterm|terminal emulator derived from Don Libes' tkterm,
	am,xenl,
	smkx=\E[?1h\E,
	rmkx=\E[?1l\E>,
	cup=\E[%i%p1%d;%p2%dH,
	cub1=\b,
	cuu1=\E[A,
	cuf1=\E[C,
	clear=\E[H\E[J,
	el=\E[K,
	cud1=\n,
	ind=\n,
	cr=\r,
	smso=\E[7m,
	rmso=\E[m,
	kcuu1=\EOA,kcud1=\EOB,kcuf1=\EOC,kcub1=\EOD,
	khome=\EOH,kend=\EOF,kpp=\E[5~,knp=\E[6~,
	kich1=\E[2~,kdch1=\E[3~,
	kf1=\EOP,kf2=\EOQ,kf3=\EOR,kf4=\EOS,kf5=\EOT,
	kf6=\EOU,kf7=\EOV,kf8=\EOW,kf9=\EOX,kf10=\EOY,
    }
    close $file

    set oldpath $env(PATH)
    set env(PATH) "$env(PATH):/usr/5bin:/usr/lib/terminfo"
    if {1==[catch {exec tic $ttsrc} msg]} {
	puts "WARNING: tic failed - if you don't have terminfo support on"
	puts "your system, change \"set terminfo 1\" to \"set terminfo 0\"."
	puts "Here is the original error from running tic:"
	puts $msg
    }
    set env(PATH) $oldpath

    exec rm $ttsrc
}

log_user 0

# start a shell and text widget for its output
set stty_init "-tabs"
eval spawn $term_shell
stty rows $rows columns $cols < $spawn_out(slave,name)
set term_spawn_id $spawn_id

proc term_replace {reprow repcol text} {
  global termdata
  set middle $termdata($reprow)

  # If the line is shorter than repcol, add spaces to it
  set spaces [expr $repcol - [string length $middle]]
  while { $spaces > 0 } {
    set middle "$middle "
    incr spaces -1
  }

  set termdata($reprow) \
     [string range $middle 0 [expr $repcol-1]]$text[string \
       range $middle [expr $repcol+[string length $text]] end]
}


proc parseloc {input row col} {
  upvar $row r $col c
  global rows
  switch -glob -- $input \
    end { set r $rows; set c end } \
    *.* { regexp (.*)\\.(.*) $input dummy r c
           if {$r == "end"} { set r $rows }
        }
}

proc myterm {command first second args} {
  global termdata
  if {[string compare get $command]} {
    send_error "Unknown terminal command: $command\r"
  } else {
    parseloc $first startrow startcol
    parseloc $second endrow endcol
    if {$endcol != "end"} {incr endcol -1}
    if {$startrow == $endrow} {
      set data [string range $termdata($startrow) $startcol $endcol]
    } else {
      set data [string range $termdata($startrow) $startcol end]
      for {set i [expr $startrow + 1]} {$i < $endrow} {incr i} {
        append data $termdata($i)
      }
      append data [string range $termdata($endrow) 0 $endcol]
    }
    return $data
  }
}


proc scrollup {} {
  global termdata blankline rows
  for {set i 1} {$i < $rows} {incr i} {
    set termdata($i) $termdata([expr $i+1])
  }
  set termdata($rows) $blankline
}


proc term_init {} {
	global rows cols cur_row cur_col term termdata blankline

	# initialize it with blanks to make insertions later more easily
	set blankline [format %*s $cols ""]\n
	for {set i 1} {$i <= $rows} {incr i} {
             set termdata($i) "$blankline"
	}

	set cur_row 1
	set cur_col 0
}


proc term_down {} {
	global cur_row rows cols term

	if {$cur_row < $rows} {
		incr cur_row
	} else {
                scrollup
	}
}


proc term_clr_eol {} {
	global cur_col cur_row termdata
	# Truncating the string representation of the line is enough
	set termdata($cur_row) \
	    [string range $termdata($cur_row) 0 [expr $cur_col - 1]]
}


proc term_insert {s} {
	global cols cur_col cur_row term

	set chars_rem_to_write [string length $s]
	set space_rem_on_line [expr $cols - $cur_col]

	##################
	# write first line
	##################

	if {$chars_rem_to_write <= $space_rem_on_line} {
           term_replace $cur_row $cur_col \
              [string range $s 0 [expr $space_rem_on_line-1]]
           incr cur_col $chars_rem_to_write
           term_chars_changed
           return
        }

	set chars_to_write $space_rem_on_line
	set newline 1

        term_replace $cur_row $cur_col\
            [string range $s 0 [expr $space_rem_on_line-1]]

	# discard first line already written
	incr chars_rem_to_write -$chars_to_write
	set s [string range $s $chars_to_write end]

	# update cur_col
	incr cur_col $chars_to_write
	# update cur_row
	if {$newline} {
		term_down
	}

	##################
	# write full lines
	##################
	while {$chars_rem_to_write >= $cols} {
                term_replace $cur_row 0 [string range $s 0 [expr $cols-1]]

		# discard line from buffer
		set s [string range $s $cols end]
		incr chars_rem_to_write -$cols

		set cur_col 0
		term_down
	}

	#################
	# write last line
	#################

	if {$chars_rem_to_write} {
                term_replace $cur_row 0 $s
		set cur_col $chars_rem_to_write
	}

	term_chars_changed
}

term_init

expect_background {
	-i $term_spawn_id
	-re "^\[^\x01-\x1f]+" {
		# Text
		term_insert $expect_out(0,string)
		term_cursor_changed
	} "^\r" {
		# (cr,) Go to to beginning of line
		set cur_col 0
		term_cursor_changed
	} "^\n" {
		# (ind,do) Move cursor down one line
		term_down
		term_cursor_changed
	} "^\b" {
		# Backspace nondestructively
		incr cur_col -1
		term_cursor_changed
	} "^\a" {
		# Bell with nowhere to ring it
	} "^\t" {
		# Tab, shouldn't happen
		send_error "got a tab!?"
	} eof {
		term_exit
	} "^\x1b\\\[A" {
		# (cuu1,up) Move cursor up one line
		incr cur_row -1
		term_cursor_changed
	} "^\x1b\\\[C" {
		# (cuf1,nd) Nondestructive space
		incr cur_col
		term_cursor_changed
	} -re "^\x1b\\\[(\[0-9]*);(\[0-9]*)H" {
		# (cup,cm) Move to row y col x
		set cur_row $expect_out(1,string)
		set cur_col [expr $expect_out(2,string) - 1]
		term_cursor_changed
	} "^\x1b\\\[H\x1b\\\[J" {
		# (clear,cl) Clear screen
		term_init
		term_cursor_changed
	} "^\x1b\\\[K" {
		# (el,ce) Clear to end of line
		term_clr_eol
	} "^\x1b\\\[7m" { # unsupported
		# (smso,so) Begin standout mode
		# set term_standout 1
	} "^\x1b\\\[m" {  # unsupported
		# (rmso,se) End standout mode
		# set term_standout 0
	# These do nothing, but having them in termcap/terminfo make it
	# compatible with xterm, which sends \E[D for left instead of \EOD
	# otherwise.
	} "^\x1b\\\[?1h\x1b" {
	    # (smkx,ks) start keyboard-transmit mode
	    # terminfo invokes these when going in/out of graphics mode
	    #graphicsSet 1
	} "^\x1b\\\[?1l\x1b>" {
	    # (rmkx,ke) end keyboard-transmit mode
	    #graphicsSet 0
	}
}

proc term_expect {args} {
	upvar timeout localTimeout
	upvar #0 timeout globalTimeout
	set timeout 10
	catch {set timeout $globalTimeout}
	catch {set timeout $localTimeout}

	global term_counter
	incr term_counter
	global [set strobe _data_[set term_counter]]
	global [set tstrobe _timer_[set term_counter]]

	proc term_chars_changed {} "uplevel #0 set $strobe 1"
	proc term_cursor_changed {} "uplevel #0 set $strobe 1"

	set $strobe 1
	set $tstrobe 0

	if {$timeout >= 0} {
		set mstimeout [expr 1000*$timeout]
		after $mstimeout "set $strobe 1; set $tstrobe 1"
		set timeout_act {}
	}

	set argc [llength $args]
	if {$argc%2 == 1} {
		lappend args {}
		incr argc
	}

	for {set i 0} {$i<$argc} {incr i 2} {
		set act_index [expr $i+1]
		if {[string compare timeout [lindex $args $i]] == 0} {
			set timeout_act [lindex $args $act_index]
			set args [lreplace $args $i $act_index]
			incr argc -2
			break
		}
	}

	while {![info exists act]} {
		if {![set $strobe]} {
			#tkwait var $strobe
			vwait $strobe
		}
		set $strobe 0

		if {[set $tstrobe]} {
			set act $timeout_act
		} else {
			for {set i 0} {$i<$argc} {incr i 2} {
				if {[uplevel [lindex $args $i]]} {
					set act [lindex $args [incr i]]
					break
				}
			}
		}
	}

	proc term_chars_changed {} {}
	proc term_cursor_changed {} {}

	if {$timeout >= 0} {
		after $mstimeout unset $strobe $tstrobe
	} else {
		unset $strobe $tstrobe
	}

	set code [catch {uplevel $act} string]
	if {$code >  4} {return -code $code $string}
	if {$code == 4} {return -code continue}
	if {$code == 3} {return -code break}
	if {$code == 2} {return -code return}
	if {$code == 1} {return -code error -errorinfo $::errorInfo \
				-errorcode $::errorCode $string}
	return $string
}
