108 lines
2.9 KiB
Scheme
108 lines
2.9 KiB
Scheme
(define-record-type console :console
|
|
(really-make-console pty-in pty-out
|
|
pause-channel resume-channel
|
|
window terminal-buffer)
|
|
console?
|
|
(pty-in console-pty-in)
|
|
(pty-out console-pty-out)
|
|
(pause-channel console-pause-channel)
|
|
(resume-channel console-resume-channel)
|
|
(window console-window)
|
|
(terminal-buffer console-terminal-buffer))
|
|
|
|
(define (make-console pty-in pty-out window terminal-buffer)
|
|
(let ((pause-channel (make-channel))
|
|
(resume-channel (make-channel)))
|
|
(spawn-console-loop
|
|
pause-channel resume-channel window terminal-buffer
|
|
(make-channel-for-pty-out pty-in))
|
|
(really-make-console
|
|
pty-in pty-out pause-channel resume-channel
|
|
window terminal-buffer)))
|
|
|
|
(define (eio? condition)
|
|
(and (eq? (car condition) 'exception)
|
|
(eq? (list-ref condition 2) 'os-error)
|
|
(= (list-ref condition 3) errno/io)))
|
|
|
|
(define (read-char-pty pty)
|
|
(with-fatal-error-handler
|
|
(lambda (condition more)
|
|
(if (eio? condition)
|
|
(eof-object)
|
|
(more)))
|
|
(read-char pty)))
|
|
|
|
(define (make-channel-for-pty-out pty)
|
|
(let ((channel (make-channel)))
|
|
(spawn
|
|
(lambda ()
|
|
(debug-message "make-channel-for-pty-out " pty)
|
|
(let lp ((c (read-char-pty pty)))
|
|
(if (not (eof-object? c))
|
|
(begin
|
|
(send channel c)
|
|
(lp (read-char-pty pty)))))))
|
|
channel))
|
|
|
|
(define (spawn-console-loop
|
|
pause-channel resume-channel
|
|
window terminal-buffer pty-channel)
|
|
(spawn
|
|
(lambda ()
|
|
(let lp ((paint? #f))
|
|
(select
|
|
(wrap (receive-rv pause-channel)
|
|
(lambda (ignore)
|
|
(lp #f)))
|
|
(wrap (receive-rv resume-channel)
|
|
(lambda (ignore)
|
|
(lp #t)))
|
|
(wrap (receive-rv pty-channel)
|
|
(lambda (char)
|
|
(cond
|
|
((eof-object? char)
|
|
(lp paint?))
|
|
(else
|
|
(terminal-buffer-add-char terminal-buffer char)
|
|
(if paint?
|
|
(begin
|
|
(curses-paint-terminal-buffer
|
|
terminal-buffer window)
|
|
(wrefresh window)))
|
|
(lp paint?))))))))))
|
|
|
|
(define (pause-console-output console)
|
|
(debug-message "pause-console-output")
|
|
(send (console-pause-channel console) 'ignore))
|
|
|
|
(define (resume-console-output console)
|
|
(debug-message "resume-console-output")
|
|
(send (console-resume-channel console) 'ignore))
|
|
|
|
(define (view-console console)
|
|
(debug-message "view-console " console)
|
|
(curses-paint-terminal-buffer/complete
|
|
(console-terminal-buffer console)
|
|
(console-window console))
|
|
(resume-console-output console)
|
|
(spawn
|
|
(lambda ()
|
|
(sync
|
|
(wrap (result-buffer-other-object-has-focus-rv)
|
|
(lambda (ack-channel)
|
|
(pause-console-output console)
|
|
(send ack-channel 'ignore)))))))
|
|
|
|
(define (make-console-viewer console buffer)
|
|
(lambda (message)
|
|
(case message
|
|
((paint)
|
|
(lambda (self win buffer have-focus?)
|
|
(view-console console)))
|
|
(else
|
|
(lambda (self . more)
|
|
self)))))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-console-viewer console?)) |