107 lines
3.7 KiB
Raw Normal View History

1996-09-27 06:29:02 -04:00
;;;; s t e r m . s t k -- A simple terminal emulator written in Scheme
1999-09-05 07:16:41 -04:00
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <>
1996-09-27 06:29:02 -04:00
1999-09-05 07:16:41 -04:00
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
1996-09-27 06:29:02 -04:00
;;;; Author: Erick Gallesio []
;;;; Creation date: 2-Oct-1995 22:57
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:55 (eg)
1996-09-27 06:29:02 -04:00
(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)))
((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")
;; 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 ()
1998-04-10 06:59:06 -04:00
(when (char-ready? file)
(let ((l (read-line file)))
(if (eof-object? l)
(when-port-readable file #f)
(insert-line w l)
(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
1996-09-27 06:29:02 -04:00
(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)
1998-04-10 06:59:06 -04:00
(let* ((p (run-shell (or (getenv "SHELL") "/bin/sh")))
1996-09-27 06:29:02 -04:00
(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)
(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")