Subversion Repositories or1k

#!../expectk -f

# Name: tkterm - terminal emulator using Expect and Tk text widget, v1.0
# Author: Don Libes, July '94

# This is primarily for regression testing character-graphic applications.
# You can certainly use it as a terminal emulator - however many features
# in a real terminal emulator are not supported (although I'll probably
# add some of them later).

# A paper on the implementation: Libes, D., Automation and Testing of
# Interactive Character Graphic Programs", Software - Practice &
# Experience, John Wiley & Sons, West Sussex, England, Vol. 27(2),
# p. 123-137, February 1997.

###############################
# Quick overview of this emulator
###############################
# Very good attributes:
#   Understands both termcap and terminfo   
#   Understands meta-key (zsh, emacs, etc work)
#   Is fast
#   Understands X selections
#   Looks best with fixed-width font but doesn't require it
# Good-enough-for-starters attributes:
#   Understands one kind of standout mode (reverse video)
# Should-be-fixed-soon attributes:
#   Does not support scrollbar or resize
# Probably-wont-be-fixed-soon attributes:
#   Assumes only one terminal exists

###############################################
# To try out this package, just run it.  Using it in
# your scripts is simple.  Here are directions:
###############################################
# 0) make sure Expect is linked into your Tk-based program (or vice versa)
# 1) modify the variables/procedures below these comments appropriately
# 2) source this file
# 3) pack the text widget ($term) if you have so configured it (see
#    "term_alone" below).  As distributed, it packs into . automatically.

#############################################
# 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 .t             ;# name of text widget used by term
set term_alone 1        ;# if 1, directly pack term into .
                        ;# else you must pack
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 spawned process 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]]}
#
# Test if a specific character at row 4 col 5 is in standout
# if {-1 != [lsearch [$term tag names 4.5] standout]} ...
#
# Return contents of screen
# $term get 1.0 end
#
# Return indices of first string on lines 4 to 6 that is in standout mode
# $term tag nextrange standout 4.0 6.end
#
# Replace all occurrences of "foo" with "bar" on screen
# for {set i 1} {$i<=$rows} {incr i} {
#       regsub -all "foo" [$term get $i.0 $i.end] "bar" x
#       $term delete $i.0 $i.end
#       $term insert $i.0 $x
# }

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


unset env(DISPLAY)
set env(LINES) $rows
set env(COLUMNS) $cols

set env(TERM) "tt"
if $termcap {
    set env(TERMCAP) {tt:
        :cm=\E[%d;%dH:
        :up=\E[A:
        :nd=\E[C:
        :cl=\E[H\E[J:
        :do=^J:
        :so=\E[7m:
        :se=\E[m:
        :k1=\EOP:
        :k2=\EOQ:
        :k3=\EOR:
        :k4=\EOS:
        :k5=\EOT:
        :k6=\EOU:
        :k7=\EOV:
        :k8=\EOW:
        :k9=\EOX:
    }
}

if $terminfo {
    set env(TERMINFO) /tmp
    set ttsrc "/tmp/tt.src"
    set file [open $ttsrc w]

    puts $file {tt|textterm|Don Libes' tk text widget terminal emulator,
        cup=\E[%p1%d;%p2%dH,
        cuu1=\E[A,
        cuf1=\E[C,
        clear=\E[H\E[J,
        ind=\n,
        cr=\r,
        smso=\E[7m,
        rmso=\E[m,
        kf1=\EOP,
        kf2=\EOQ,
        kf3=\EOR,
        kf4=\EOS,
        kf5=\EOT,
        kf6=\EOU,
        kf7=\EOV,
        kf8=\EOW,
        kf9=\EOX,
    }
    close $file

    set oldpath $env(PATH)
    set 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
}

set term_standout 0     ;# if in standout mode or not

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

# this shouldn't be needed if Ousterhout fixes text bug
text $term -relief sunken -bd 1 -width $cols -height $rows -wrap none

if {$term_alone} {
        pack $term
}

$term tag configure standout -background  black -foreground white

proc term_clear {} {
        global term

        $term delete 1.0 end
        term_init
}

proc term_init {} {
        global rows cols cur_row cur_col term

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

        set cur_row 1
        set cur_col 0

        $term mark set insert $cur_row.$cur_col
}

proc term_down {} {
        global cur_row rows cols term

        if {$cur_row < $rows} {
                incr cur_row
        } else {
                # already at last line of term, so scroll screen up
                $term delete 1.0 "1.end + 1 chars"

                # recreate line at end
                $term insert end [format %*s $cols ""]\n
        }
}

proc term_insert {s} {
        global cols cur_col cur_row
        global term term_standout

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

        if {$term_standout} {
                set tag_action "add"
        } else {
                set tag_action "remove"
        }

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

        if {$chars_rem_to_write > $space_rem_on_line} {
                set chars_to_write $space_rem_on_line
                set newline 1
        } else {
                set chars_to_write $chars_rem_to_write
                set newline 0
        }

        $term delete $cur_row.$cur_col $cur_row.[expr $cur_col + $chars_to_write]
        $term insert $cur_row.$cur_col [
                string range $s 0 [expr $space_rem_on_line-1]
        ]

        $term tag $tag_action standout $cur_row.$cur_col $cur_row.[expr $cur_col + $chars_to_write]

        # 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 delete $cur_row.0 $cur_row.end
                $term insert $cur_row.0 [string range $s 0 [expr $cols-1]]
                $term tag $tag_action standout $cur_row.0 $cur_row.end

                # 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 delete $cur_row.0 $cur_row.$chars_rem_to_write
                $term insert $cur_row.0 $s
                $term tag $tag_action standout $cur_row.0 $cur_row.$chars_rem_to_write
                set cur_col $chars_rem_to_write
        }

        term_chars_changed
}

proc term_update_cursor {} {
        global cur_row cur_col term

        $term mark set insert $cur_row.$cur_col

        term_cursor_changed
}

term_init

set flush 0
proc screen_flush {} {
        global flush
        incr flush
        if {$flush == 24} {
                update idletasks
                set flush 0
        }
#       update idletasks
#       after 1000 a
}



expect_background {
        -i $term_spawn_id
        -re "^\[^\x01-\x1f]+" {
                # Text
                term_insert $expect_out(0,string)
                term_update_cursor
        } "^\r" {
                # (cr,) Go to beginning of line
                screen_flush
                set cur_col 0
                term_update_cursor
        } "^\n" {
                # (ind,do) Move cursor down one line
                term_down
                term_update_cursor
        } "^\b" {
                # Backspace nondestructively
                incr cur_col -1
                term_update_cursor
        } "^\a" {
                bell
        } "^\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_update_cursor
        } "^\x1b\\\[C" {
                # (cuf1,nd) Non-destructive space
                incr cur_col
                term_update_cursor
        } -re "^\x1b\\\[(\[0-9]*);(\[0-9]*)H" {
                # (cup,cm) Move to row y col x
                set cur_row [expr $expect_out(1,string)+1]
                set cur_col $expect_out(2,string)
                term_update_cursor
        } "^\x1b\\\[H\x1b\\\[J" {
                # (clear,cl) Clear screen
                term_clear
                term_update_cursor
        } "^\x1b\\\[7m" {
                # (smso,so) Begin standout mode
                set term_standout 1
        } "^\x1b\\\[m" {
                # (rmso,se) End standout mode
                set term_standout 0
        }
}

bind $term <Any-Enter> {
        focus %W
}
bind $term <Meta-KeyPress> {
        if {"%A" != ""} {
                exp_send -i $term_spawn_id "\033%A"
        }
}

bind $term <KeyPress> {
        exp_send -i $term_spawn_id -- %A
        break
}

bind $term <Control-space>      {exp_send -null}
bind $term <Control-at>         {exp_send -null}

bind $term <F1> {exp_send -i $term_spawn_id "\033OP"}
bind $term <F2> {exp_send -i $term_spawn_id "\033OQ"}
bind $term <F3> {exp_send -i $term_spawn_id "\033OR"}
bind $term <F4> {exp_send -i $term_spawn_id "\033OS"}
bind $term <F5> {exp_send -i $term_spawn_id "\033OT"}
bind $term <F6> {exp_send -i $term_spawn_id "\033OU"}
bind $term <F7> {exp_send -i $term_spawn_id "\033OV"}
bind $term <F8> {exp_send -i $term_spawn_id "\033OW"}
bind $term <F9> {exp_send -i $term_spawn_id "\033OX"}