1#!/depot/path/expectk 2 3# Name: tkterm - terminal emulator using Expect and Tk text widget, v3.0 4# Author: Don Libes, July '94 5# Last updated: Mar '04 6 7# This is primarily for regression testing character-graphic applications. 8# You can certainly use it as a terminal emulator - however many features 9# in a real terminal emulator are not supported (although I'll probably 10# add some of them later). 11 12# A paper on the implementation: Libes, D., Automation and Testing of 13# Interactive Character Graphic Programs", Software - Practice & 14# Experience, John Wiley & Sons, West Sussex, England, Vol. 27(2), 15# p. 123-137, February 1997. 16 17############################### 18# Quick overview of this emulator 19############################### 20# Very good attributes: 21# Understands both termcap and terminfo 22# Understands meta-key (zsh, emacs, etc work) 23# Is fast 24# Understands X selections 25# Looks best with fixed-width font but doesn't require it 26# Supports scrollbars 27# Good-enough-for-starters attributes: 28# Understands one kind of standout mode (reverse video) 29# Should-be-fixed-soon attributes: 30# Does not support resize 31# Probably-wont-be-fixed-soon attributes: 32# Assumes only one terminal exists 33 34############################################### 35# To try out this package, just run it. Using it in 36# your scripts is simple. Here are directions: 37############################################### 38# 0) make sure Expect is linked into your Tk-based program (or vice versa) 39# 1) modify the variables/procedures below these comments appropriately 40# 2) source this file 41# 3) pack the text widget ($term) if you have so configured it (see 42# "term_alone" below). As distributed, it packs into . automatically. 43 44############################################# 45# Variables that must be initialized before using this: 46############################################# 47set rows 24 ;# number of rows in term 48set rowsDumb $rows ;# number of rows in term when in dumb mode - this can 49 ;# increase during runtime 50set cols 80 ;# number of columns in term 51set term .t ;# name of text widget used by term 52set sb .sb ;# name of scrollbar used by term in dumb mode 53set term_alone 1 ;# if 1, directly pack term into . 54 ;# else you must pack 55set termcap 1 ;# if your applications use termcap 56set terminfo 1 ;# if your applications use terminfo 57 ;# (you can use both, but note that 58 ;# starting terminfo is slow) 59set term_shell $env(SHELL) ;# program to run in term 60 61############################################# 62# Readable variables of interest 63############################################# 64# cur_row ;# current row where insert marker is 65# cur_col ;# current col where insert marker is 66# term_spawn_id ;# spawn id of term 67 68############################################# 69# Procs you may want to initialize before using this: 70############################################# 71 72# term_exit is called if the spawned process exits 73proc term_exit {} { 74 exit 75} 76 77# term_chars_changed is called after every change to the displayed chars 78# You can use if you want matches to occur in the background (a la bind) 79# If you want to test synchronously, then just do so - you don't need to 80# redefine this procedure. 81proc term_chars_changed {} { 82} 83 84# term_cursor_changed is called after the cursor is moved 85proc term_cursor_changed {} { 86} 87 88# Example tests you can make 89# 90# Test if cursor is at some specific location 91# if {$cur_row == 1 && $cur_col == 0} ... 92# 93# Test if "foo" exists anywhere in line 4 94# if {[string match *foo* [$term get 4.0 4.end]]} 95# 96# Test if "foo" exists at line 4 col 7 97# if {[string match foo* [$term get 4.7 4.end]]} 98# 99# Test if a specific character at row 4 col 5 is in standout 100# if {-1 != [lsearch [$term tag names 4.5] standout]} ... 101# 102# Return contents of screen 103# $term get 1.0 end 104# 105# Return indices of first string on lines 4 to 6 that is in standout mode 106# $term tag nextrange standout 4.0 6.end 107# 108# Replace all occurrences of "foo" with "bar" on screen 109# for {set i 1} {$i<=$rows} {incr i} { 110# regsub -all "foo" [$term get $i.0 $i.end] "bar" x 111# $term delete $i.0 $i.end 112# $term insert $i.0 $x 113# } 114 115############################################# 116# End of things of interest 117############################################# 118 119# Terminal definitions are provided in both termcap and terminfo 120# styles because we cannot be sure which a system might have. The 121# definitions generally follow that of xterm which in turn follows 122# that of vt100. This is useful for the most common archaic software 123# which has vt100 definitions hardcoded. 124 125unset env(DISPLAY) 126set env(LINES) $rows 127set env(COLUMNS) $cols 128 129if {$termcap} { 130 set env(TERM) "tt" 131 set env(TERMCAP) {tt: 132 :ks=\E[?1h\E: 133 :ke=\E[?1l\E>: 134 :cm=\E[%d;%dH: 135 :up=\E[A: 136 :nd=\E[C: 137 :cl=\E[H\E[J: 138 :ce=\E[K: 139 :do=^J: 140 :so=\E[7m: 141 :se=\E[m: 142 :k1=\EOP: 143 :k2=\EOQ: 144 :k3=\EOR: 145 :k4=\EOS: 146 :k5=\EOT: 147 :k6=\EOU: 148 :k7=\EOV: 149 :k8=\EOW: 150 :k9=\EOX: 151 } 152} 153 154if {$terminfo} { 155 # ncurses ignores 2-char term names so use a longer name here 156 set env(TERM) "tkterm" 157 set env(TERMINFO) /tmp 158 set ttsrc "/tmp/tt.src" 159 set file [open $ttsrc w] 160 161 puts $file {tkterm|Don Libes' tk text widget terminal emulator, 162 smkx=\E[?1h\E, 163 rmkx=\E[?1l\E>, 164 cup=\E[%p1%d;%p2%dH, 165 cuu1=\E[A, 166 cuf1=\E[C, 167 clear=\E[H\E[J, 168 el=\E[K, 169 ind=\n, 170 cr=\r, 171 smso=\E[7m, 172 rmso=\E[m, 173 kf1=\EOP, 174 kf2=\EOQ, 175 kf3=\EOR, 176 kf4=\EOS, 177 kf5=\EOT, 178 kf6=\EOU, 179 kf7=\EOV, 180 kf8=\EOW, 181 kf9=\EOX, 182 } 183 close $file 184 185 set oldpath $env(PATH) 186 set env(PATH) "$env(PATH):/usr/5bin:/usr/lib/terminfo" 187 if {1==[catch {exec tic $ttsrc} msg]} { 188 puts "WARNING: tic failed - if you don't have terminfo support on" 189 puts "your system, change \"set terminfo 1\" to \"set terminfo 0\"." 190 puts "Here is the original error from running tic:" 191 puts $msg 192 } 193 set env(PATH) $oldpath 194 195 exec rm $ttsrc 196} 197 198set term_standout 0 ;# if in standout mode or not 199 200log_user 0 201 202# start a shell and text widget for its output 203set stty_init "-tabs" 204eval spawn $term_shell 205stty rows $rows columns $cols < $spawn_out(slave,name) 206set term_spawn_id $spawn_id 207 208# this shouldn't be needed if Ousterhout fixes text bug 209text $term \ 210 -yscroll "$sb set" \ 211 -relief sunken -bd 1 -width $cols -height $rows -wrap none -setgrid 1 212 213# define scrollbars 214scrollbar .sb -command "$term yview" 215 216proc graphicsGet {} {return $::graphics(mode)} 217proc graphicsSet {mode} { 218 set ::graphics(mode) $mode 219 220 if {$mode} { 221 # in graphics mode, no scroll bars 222 grid forget $::sb 223 } else { 224 grid $::sb -column 0 -row 0 -sticky ns 225 } 226} 227 228if {$term_alone} { 229 grid $term -column 1 -row 0 -sticky nsew 230 # let text box only expand 231 grid rowconfigure . 0 -weight 1 232 grid columnconfigure . 1 -weight 1 233} 234 235$term tag configure standout -background black -foreground white 236 237proc term_clear {} { 238 global term 239 240 $term delete 1.0 end 241 term_init 242} 243 244# pine is the only program I know that requires clear_to_eol, sigh 245proc term_clear_to_eol {} { 246 global cols cur_col cur_row 247 248 # save current col/row 249 set col $cur_col 250 set row $cur_row 251 252 set space_rem_on_line [expr $cols - $cur_col] 253 term_insert [format %[set space_rem_on_line]s ""] 254 255 # restore current col/row 256 set cur_col $col 257 set cur_row $row 258} 259 260proc term_init {} { 261 global rows cols cur_row cur_col term 262 263 # initialize it with blanks to make insertions later more easily 264 set blankline [format %*s $cols ""]\n 265 for {set i 1} {$i <= $rows} {incr i} { 266 $term insert $i.0 $blankline 267 } 268 269 set cur_row 1 270 set cur_col 0 271 272 $term mark set insert $cur_row.$cur_col 273 274 set ::rowsDumb $rows 275} 276 277proc term_down {} { 278 global cur_row rows cols term 279 280 if {$cur_row < $rows} { 281 incr cur_row 282 } else { 283 if {[graphicsGet]} { 284 # in graphics mode 285 286 # already at last line of term, so scroll screen up 287 $term delete 1.0 "1.end + 1 chars" 288 289 # recreate line at end 290 $term insert end [format %*s $cols ""]\n 291 } else { 292 # in dumb mode 293 incr cur_row 294 295 if {$cur_row > $::rowsDumb} { 296 set ::rowsDumb $cur_row 297 } 298 299 $term insert $cur_row.0 [format %*s $cols ""]\n 300 $term see $cur_row.0 301 } 302 } 303} 304 305proc term_up {} { 306 global cur_row rows cols term 307 308 set cur_rowOld $cur_row 309 incr cur_row -1 310 311 if {($cur_rowOld > $rows) && ($cur_rowOld == $::rowsDumb)} { 312 if {[regexp "^ *$" [$::term get $cur_rowOld.0 $cur_rowOld.end]]} { 313 # delete line 314 $::term delete $cur_rowOld.0 end 315 } 316 incr ::rowsDumb -1 317 } 318} 319 320proc term_insert {s} { 321 global cols cur_col cur_row 322 global term term_standout 323 324 set chars_rem_to_write [string length $s] 325 set space_rem_on_line [expr $cols - $cur_col] 326 327 if {$term_standout} { 328 set tag_action "add" 329 } else { 330 set tag_action "remove" 331 } 332 333 ################## 334 # write first line 335 ################## 336 337 if {$chars_rem_to_write > $space_rem_on_line} { 338 set chars_to_write $space_rem_on_line 339 set newline 1 340 } else { 341 set chars_to_write $chars_rem_to_write 342 set newline 0 343 } 344 345 $term delete $cur_row.$cur_col $cur_row.[expr $cur_col + $chars_to_write] 346 $term insert $cur_row.$cur_col [ 347 string range $s 0 [expr $space_rem_on_line-1] 348 ] 349 350 $term tag $tag_action standout $cur_row.$cur_col $cur_row.[expr $cur_col + $chars_to_write] 351 352 # discard first line already written 353 incr chars_rem_to_write -$chars_to_write 354 set s [string range $s $chars_to_write end] 355 356 # update cur_col 357 incr cur_col $chars_to_write 358 # update cur_row 359 if {$newline} { 360 term_down 361 } 362 363 ################## 364 # write full lines 365 ################## 366 while {$chars_rem_to_write >= $cols} { 367 $term delete $cur_row.0 $cur_row.end 368 $term insert $cur_row.0 [string range $s 0 [expr $cols-1]] 369 $term tag $tag_action standout $cur_row.0 $cur_row.end 370 371 # discard line from buffer 372 set s [string range $s $cols end] 373 incr chars_rem_to_write -$cols 374 375 set cur_col 0 376 term_down 377 } 378 379 ################# 380 # write last line 381 ################# 382 383 if {$chars_rem_to_write} { 384 $term delete $cur_row.0 $cur_row.$chars_rem_to_write 385 $term insert $cur_row.0 $s 386 $term tag $tag_action standout $cur_row.0 $cur_row.$chars_rem_to_write 387 set cur_col $chars_rem_to_write 388 } 389 390 term_chars_changed 391} 392 393proc term_update_cursor {} { 394 global cur_row cur_col term 395 396 $term mark set insert $cur_row.$cur_col 397 398 term_cursor_changed 399} 400 401term_init 402graphicsSet 0 403 404set flush 0 405proc screen_flush {} { 406 global flush 407 incr flush 408 if {$flush == 24} { 409 update idletasks 410 set flush 0 411 } 412} 413 414expect_background { 415 -i $term_spawn_id 416 -re "^\[^\x01-\x1f]+" { 417 # Text 418 term_insert $expect_out(0,string) 419 term_update_cursor 420 } "^\r" { 421 # (cr,) Go to beginning of line 422 screen_flush 423 set cur_col 0 424 term_update_cursor 425 } "^\n" { 426 # (ind,do) Move cursor down one line 427 term_down 428 term_update_cursor 429 } "^\b" { 430 # Backspace nondestructively 431 incr cur_col -1 432 term_update_cursor 433 } "^\a" { 434 bell 435 } "^\t" { 436 # Tab, shouldn't happen 437 send_error "got a tab!?" 438 } eof { 439 term_exit 440 } "^\x1b\\\[A" { 441 # (cuu1,up) Move cursor up one line 442 term_up 443 term_update_cursor 444 } "^\x1b\\\[C" { 445 # (cuf1,nd) Non-destructive space 446 incr cur_col 447 term_update_cursor 448 } -re "^\x1b\\\[(\[0-9]*);(\[0-9]*)H" { 449 # (cup,cm) Move to row y col x 450 set cur_row [expr $expect_out(1,string)+1] 451 set cur_col $expect_out(2,string) 452 term_update_cursor 453 } "^\x1b\\\[H\x1b\\\[J" { 454 # (clear,cl) Clear screen 455 term_clear 456 term_update_cursor 457 } "^\x1b\\\[K" { 458 # (el,ce) Clear to end of line 459 term_clear_to_eol 460 term_update_cursor 461 } "^\x1b\\\[7m" { 462 # (smso,so) Begin standout mode 463 set term_standout 1 464 } "^\x1b\\\[m" { 465 # (rmso,se) End standout mode 466 set term_standout 0 467 } "^\x1b\\\[?1h\x1b" { 468 # (smkx,ks) start keyboard-transmit mode 469 # terminfo invokes these when going in/out of graphics mode 470 graphicsSet 1 471 } "^\x1b\\\[?1l\x1b>" { 472 # (rmkx,ke) end keyboard-transmit mode 473 graphicsSet 0 474 } 475} 476 477bind $term <Any-Enter> { 478 focus %W 479} 480 481bind $term <Meta-KeyPress> { 482 if {"%A" != ""} { 483 exp_send -i $term_spawn_id "\033%A" 484 } 485} 486 487bind $term <KeyPress> { 488 exp_send -i $term_spawn_id -- %A 489 break 490} 491 492bind $term <Control-space> {exp_send -null} 493bind $term <Control-at> {exp_send -null} 494 495bind $term <F1> {exp_send -i $term_spawn_id "\033OP"} 496bind $term <F2> {exp_send -i $term_spawn_id "\033OQ"} 497bind $term <F3> {exp_send -i $term_spawn_id "\033OR"} 498bind $term <F4> {exp_send -i $term_spawn_id "\033OS"} 499bind $term <F5> {exp_send -i $term_spawn_id "\033OT"} 500bind $term <F6> {exp_send -i $term_spawn_id "\033OU"} 501bind $term <F7> {exp_send -i $term_spawn_id "\033OV"} 502bind $term <F8> {exp_send -i $term_spawn_id "\033OW"} 503bind $term <F9> {exp_send -i $term_spawn_id "\033OX"} 504 505set term_counter 0 506proc term_expect {args} { 507 upvar timeout localTimeout 508 upvar #0 timeout globalTimeout 509 set timeout 10 510 catch {set timeout $globalTimeout} 511 catch {set timeout $localTimeout} 512 513 global term_counter 514 incr term_counter 515 global [set strobe _data_[set term_counter]] 516 global [set tstrobe _timer_[set term_counter]] 517 518 proc term_chars_changed {} "uplevel #0 set $strobe 1" 519 520 set $strobe 1 521 set $tstrobe 0 522 523 if {$timeout >= 0} { 524 set mstimeout [expr 1000*$timeout] 525 after $mstimeout "set $strobe 1; set $tstrobe 1" 526 set timeout_act {} 527 } 528 529 set argc [llength $args] 530 if {$argc%2 == 1} { 531 lappend args {} 532 incr argc 533 } 534 535 for {set i 0} {$i<$argc} {incr i 2} { 536 set act_index [expr $i+1] 537 if {[string compare timeout [lindex $args $i]] == 0} { 538 set timeout_act [lindex $args $act_index] 539 set args [lreplace $args $i $act_index] 540 incr argc -2 541 break 542 } 543 } 544 545 while {![info exists act]} { 546 if {![set $strobe]} { 547 tkwait var $strobe 548 } 549 set $strobe 0 550 551 if {[set $tstrobe]} { 552 set act $timeout_act 553 } else { 554 for {set i 0} {$i<$argc} {incr i 2} { 555 if {[uplevel [lindex $args $i]]} { 556 set act [lindex $args [incr i]] 557 break 558 } 559 } 560 } 561 } 562 563 proc term_chars_changed {} {} 564 565 if {$timeout >= 0} { 566 after $mstimeout unset $strobe $tstrobe 567 } else { 568 unset $strobe $tstrobe 569 } 570 571 set code [catch {uplevel $act} string] 572 if {$code > 4} {return -code $code $string} 573 if {$code == 4} {return -code continue} 574 if {$code == 3} {return -code break} 575 if {$code == 2} {return -code return} 576 if {$code == 1} {return -code error -errorinfo $errorInfo \ 577 -errorcode $errorCode $string} 578 return $string 579} 580 581################################################## 582# user-supplied code goes below here 583################################################## 584 585set timeout 200 586 587# for example, wait for a shell prompt 588term_expect {regexp "%" [$term get 1.0 3.end]} 589 590# invoke game of rogue 591exp_send "myrogue\r" 592 593# wait for strength of 18 594term_expect \ 595 {regexp "Str: 18" [$term get 24.0 24.end]} { 596 # do something 597 } {timeout} { 598 puts "ulp...timed out!" 599 } {regexp "Str: 16" [$term get 24.0 24.end]} 600 601# and so on... 602 603