diff options
Diffstat (limited to 'example/xkibitz')
| -rwxr-xr-x | example/xkibitz | 219 |
1 files changed, 219 insertions, 0 deletions
diff --git a/example/xkibitz b/example/xkibitz new file mode 100755 index 0000000..b61a22f --- /dev/null +++ b/example/xkibitz @@ -0,0 +1,219 @@ +#!/bin/sh +# -*- tcl -*- +# The next line is executed by /bin/sh, but not tcl \ +exec tclsh "$0" ${1+"$@"} + +package require Expect + + +# share an xterm with other users +# See xkibitz(1) man page for complete info. +# Compare with kibitz. +# Author: Don Libes, NIST +# Version: 1.2 + +proc help {} { + puts "Commands Meaning" + puts "-------- -------" + puts "return return to program" + puts "= list" + puts "+ <display> add" + puts "- <tag> drop" + puts "where <display> is an X display name such as nist.gov or nist.gov:0.0" + puts "and <tag> is a tag from the = command." + puts "+ and - require whitespace before argument." + puts {return command must be spelled out ("r", "e", "t", ...).} +} + +proc prompt1 {} { + return "xkibitz> " +} + +proc h {} help +proc ? {} help + +# disable history processing - there seems to be some incestuous relationship +# between history and unknown in Tcl 8.0 +proc history {args} {} +proc unknown {args} { + puts "$args: invalid command" + help +} + +set tag2pid(0) [pid] +set pid2tty([pid]) "/dev/tty" +if {[info exists env(DISPLAY)]} { + set pid2display([pid]) $env(DISPLAY) +} else { + set pid2display([pid]) "" +} + +# small int allowing user to more easily identify display +# maxtag always points at highest in use +set maxtag 0 + +proc + {display} { + global ids pid2display pid2tag tag2pid maxtag pid2sid + global pid2tty env + + if {![string match *:* $display]} { + append display :0.0 + } + + if {![info exists env(XKIBITZ_XTERM_ARGS)]} { + set env(XKIBITZ_XTERM_ARGS) "" + } + + set dummy1 [open /dev/null] + set dummy2 [open /dev/null] + spawn -pty -noecho + close $dummy1 + close $dummy2 + + stty raw -echo < $spawn_out(slave,name) + # Linux needs additional stty, sounds like a bug in its stty to me. + # raw should imply this stuff, no? + stty -icrnl -icanon < $spawn_out(slave,name) + + regexp ".*(.)(.)" $spawn_out(slave,name) dummy c1 c2 + if {[string compare $c1 "/"] == 0} { + # On Pyramid and AIX, ttynames such as /dev/pts/1 + # requre suffix to be padded with a 0 + set c1 0 + } + + set pid [eval exec xterm \ + -display $display \ + -geometry [stty columns]x[stty rows] \ + -S$c1$c2$spawn_out(slave,fd) \ + $env(XKIBITZ_XTERM_ARGS) &] + close -slave + + # xterm first sends back window id, discard + log_user 0 + expect { + eof {wait;return} + \n + } + log_user 1 + + lappend ids $spawn_id + set pid2display($pid) $display + incr maxtag + set tag2pid($maxtag) $pid + set pid2tag($pid) $maxtag + set pid2sid($pid) $spawn_id + set pid2tty($pid) $spawn_out(slave,name) + return +} + +proc = {} { + global pid2display tag2pid pid2tty + + puts "Tag Size Display" + foreach tag [lsort -integer [array names tag2pid]] { + set pid $tag2pid($tag) + set tty $pid2tty($pid) + + puts [format "%3d [stty columns < $tty]x[stty rows < $tty] $pid2display($pid)" $tag] + } +} + +proc - {tag} { + global tag2pid pid2tag pid2display maxtag ids pid2sid + global pid2tty + + if {![info exists tag2pid($tag)]} { + puts "no such tag" + return + } + if {$tag == 0} { + puts "cannot drop self" + return + } + + set pid $tag2pid($tag) + + # close and remove spawn_id from list + set spawn_id $pid2sid($pid) + set index [lsearch $ids $spawn_id] + set ids [lreplace $ids $index $index] + + exec kill -9 $pid + close + wait + + unset tag2pid($tag) + unset pid2tag($pid) + unset pid2display($pid) + unset pid2sid($pid) + unset pid2tty($pid) + + # lower maxtag if possible + while {![info exists tag2pid($maxtag)]} { + incr maxtag -1 + } +} + +rename exit exitReal + +proc exit {} { + global pid2display + + unset pid2display([pid]) ;# avoid killing self + + foreach pid [array names pid2display] { + catch {exec kill -9 $pid} + } + exitReal +} + +trap exit HUP + +trap { + set r [stty rows] + set c [stty columns] + stty rows $r columns $c < $app_tty + foreach pid [array names pid2tty] { + if {$pid == [pid]} continue + stty rows $r columns $c < $pid2tty($pid) + } +} WINCH + +set escape \035 ;# control-right-bracket +set escape_printable "^\]" + +while {[llength $argv]>0} { + set flag [lindex $argv 0] + switch -- $flag \ + "-escape" { + set escape [lindex $argv 1] + set escape_printable $escape + set argv [lrange $argv 2 end] + } "-display" { + + [lindex $argv 1] + set argv [lrange $argv 2 end] + } default { + break + } +} + +if {[llength $argv]>0} { + eval spawn -noecho $argv +} else { + spawn -noecho $env(SHELL) +} +set prog $spawn_id +set app_tty $spawn_out(slave,name) + +puts "Escape sequence is $escape_printable" + +interact { + -input $user_spawn_id -reset $escape { + puts "\nfor help enter: ? or h or help" + interpreter -eof exit + } -output $prog + -input ids -output $prog + -input $prog eof exit -output $user_spawn_id -output ids +} + |