stk/Lib/sterm.stk

108 lines
3.8 KiB
Plaintext

;;;;
;;;; s t e r m . s t k -- A simple terminal emulator written in Scheme
;;;;
;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; $Id: sterm.stk 1.3 Tue, 03 Mar 1998 23:48:24 +0100 eg $
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 2-Oct-1995 22:57
;;;; Last file update: 1-Mar-1998 12:50
(require "process")
(define (sterm)
(define prompt-color "red")
(define output-color "blue")
(define update-counter 0)
(define (close-sterm w)
(w 'insert "end" "*** EOF ***" "list-prompt")
;; Set state to "disabled" (or delete the <Return> binding). Not doing so,
;; stops the interpreter. The bugs seems to be in Tk event loop, since
;; similar code works without event.
(tk-set! w :state "disabled"))
(define (insert-prompt w file)
(let Loop ()
(when (char-ready? file)
(let ((c (read-char file)))
(cond
((eof-object? c) (when-port-readable file #f)
(close-sterm w))
(ELSE ;; Insert this char and try to read another one
(w 'insert "end" (string c) "list-prompt")
(Loop))))))
;; Add a mark to the current position
(w 'mark 'set "start_expr" "end-1c")
(w 'mark 'gravity "start_expr" "left")
(w 'see "end"))
(define (insert-line w line)
(w 'insert "insert" line "list-output" "\n" "")
(w 'see "end")
;; Force a redisplay when we have a bunch of lines to animate screen
(if (= update-counter 5)
(begin (update 'idle) (set! update-counter 0))
(set! update-counter (+ update-counter 1))))
(define (read-a-line w file)
(let Loop ()
(when (char-ready? file)
(let ((l (read-line file)))
(if (eof-object? l)
(when-port-readable file #f)
(begin
(insert-line w l)
(Loop)))))))
(define (run-shell shell)
(let ((TERM (getenv "TERM")))
(setenv! "TERM" "dumb") ; to avoid esc characters given by modern shell
(let ((res (run-process shell "-i" :input :pipe :output :pipe :error :pipe)))
(setenv! "TERM" TERM) ; reset original TERM
res)))
(define (make-term name closure . tk-args)
(let ((w (apply Tk:text (format #f "~A.t" name) tk-args))
(s (scrollbar (format #f "~A.s" name) :orient "vert")))
(pack w :expand #t :fill "both" :side "left")
(pack s :expand #f :fill "y" :side "right")
;; Associate bindings to the scrollbar
(tk-set! w :yscroll (lambda l (apply s 'set l)))
(tk-set! s :command (lambda l (apply w 'yview l)))
(bind w "<Return>" closure)
(w 'tag 'configure "list-prompt" :foreground prompt-color)
(w 'tag 'configure "list-output" :foreground output-color)
w))
(let* ((p (run-shell (or (getenv "SHELL") "/bin/sh")))
(in (process-input p))
(out (process-output p))
(err (process-error p))
(top (toplevel (gensym ".term")))
(t #f) ;; Will be set later since it needs C defined below
(C (lambda ()
(let ((txt (t 'get "start_expr" "insert")))
(display txt in) (newline in) (flush in)
'continue))))
(set! t (make-term (widget-name top) C :font "fixed" :setgrid #t))
(pack t :expand #t :fill "both")
;; Create handlers
(when-port-readable err (lambda () (insert-prompt t err)))
(when-port-readable out (lambda () (read-a-line t out)))))
(provide "sterm")