Tty-hacking procs when possible take stdio as a default upon which to operate.
These procs now may be applied to tty file names as well as ports and fdes.
This commit is contained in:
shivers
parent
2baee835a2
commit
3d91476f54
120
scsh/tty.scm
120
scsh/tty.scm
|
|
@ -70,6 +70,14 @@
|
|||
(define set-tty-info:min set-%tty-info:min)
|
||||
(define set-tty-info:time set-%tty-info:time)
|
||||
|
||||
(define modify-tty-info:control-chars modify-%tty-info:control-chars)
|
||||
(define modify-tty-info:input-flags modify-%tty-info:input-flags)
|
||||
(define modify-tty-info:output-flags modify-%tty-info:output-flags)
|
||||
(define modify-tty-info:control-flags modify-%tty-info:control-flags)
|
||||
(define modify-tty-info:local-flags modify-%tty-info:local-flags)
|
||||
(define modify-tty-info:min modify-%tty-info:min)
|
||||
(define modify-tty-info:time modify-%tty-info:time)
|
||||
|
||||
;;; Encode the speeds at assignment time.
|
||||
(define (set-tty-info:input-speed info speed)
|
||||
(set-%tty-info:input-speed-code info (encode-baud-rate speed))
|
||||
|
|
@ -79,6 +87,11 @@
|
|||
(set-%tty-info:output-speed-code info (encode-baud-rate speed))
|
||||
(set-%tty-info:output-speed info speed))
|
||||
|
||||
(define (modify-tty-info:input-speed info proc)
|
||||
(set-tty-info:input-speed info (proc (tty-info:input-speed info))))
|
||||
|
||||
(define (modify-tty-info:output-speed info proc)
|
||||
(set-tty-info:output-speed info (proc (tty-info:output-speed info))))
|
||||
|
||||
(define (make-tty-info iflags oflags cflags lflags ispeed ospeed min time)
|
||||
(make-%tty-info (make-string num-ttychars (ascii->char 0))
|
||||
|
|
@ -101,16 +114,23 @@
|
|||
(tty-info:time info)))
|
||||
|
||||
|
||||
;;; (tty-info fd/port)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Retrieve tty-info bits from a tty.
|
||||
|
||||
(define (tty-info fdport)
|
||||
(define (sleazy-call/file tty opener proc)
|
||||
(if (string? tty) (opener tty proc)
|
||||
(sleazy-call/fdes tty proc)))
|
||||
|
||||
;;; (tty-info [fd/port/fname])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Retrieve tty-info bits from a tty. Arg defaults to current input port.
|
||||
|
||||
(define (tty-info . maybe-tty)
|
||||
(let ((control-chars (make-string num-ttychars)))
|
||||
(receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
|
||||
cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
|
||||
ispeed-code ospeed-code)
|
||||
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
|
||||
(sleazy-call/file (:optional maybe-tty (current-input-port))
|
||||
call-with-input-file
|
||||
(lambda (fd) (%tty-info fd control-chars)))
|
||||
(make-%tty-info control-chars
|
||||
(bitwise-ior (arithmetic-shift iflag-hi8 24) iflag-lo24)
|
||||
(bitwise-ior (arithmetic-shift oflag-hi8 24) oflag-lo24)
|
||||
|
|
@ -139,14 +159,14 @@
|
|||
integer integer)
|
||||
|
||||
|
||||
;;; (set-tty-info fdport option info) [Not exported]
|
||||
;;; (set-tty-info/now fdport option info)
|
||||
;;; (set-tty-info/drain fdport option info)
|
||||
;;; (set-tty-info/flush fdport option info)
|
||||
;;; (set-tty-info tty option info) [Not exported]
|
||||
;;; (set-tty-info/now tty option info)
|
||||
;;; (set-tty-info/drain tty option info)
|
||||
;;; (set-tty-info/flush tty option info)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Assign tty-info bits to a tty.
|
||||
|
||||
(define (set-tty-info fdport option info)
|
||||
(define (set-tty-info tty option info)
|
||||
(let ((if (tty-info:input-flags info))
|
||||
(of (tty-info:output-flags info))
|
||||
(cf (tty-info:control-flags info))
|
||||
|
|
@ -162,7 +182,7 @@
|
|||
(cflag-lo24 (bitwise-and cf #xffffff))
|
||||
(lflag-hi8 (arithmetic-shift lf -24))
|
||||
(lflag-lo24 (bitwise-and lf #xffffff)))
|
||||
(sleazy-call/fdes fdport
|
||||
(sleazy-call/file tty call-with-input-file
|
||||
(lambda (fd)
|
||||
(%set-tty-info fd option
|
||||
cc
|
||||
|
|
@ -211,7 +231,7 @@
|
|||
;;; file is loaded due to the set-tty-info/foo definitions below.
|
||||
|
||||
(define (make-tty-info-setter how)
|
||||
(lambda (fdport info) (set-tty-info fdport how info)))
|
||||
(lambda (tty info) (set-tty-info tty how info)))
|
||||
|
||||
(define set-tty-info/now (make-tty-info-setter %set-tty-info/now))
|
||||
(define set-tty-info/drain (make-tty-info-setter %set-tty-info/drain))
|
||||
|
|
@ -221,10 +241,12 @@
|
|||
;;; Send a break on the serial line.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (send-tty-break fdport . maybe-duration)
|
||||
(sleazy-call/fdes fdport
|
||||
(lambda (fdes)
|
||||
(%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
|
||||
(define (send-tty-break . args) ; [tty duration]
|
||||
(let-optionals args ((tty (current-output-port))
|
||||
(duration 0))
|
||||
(sleazy-call/file tty call-with-output-file
|
||||
(lambda (fdes)
|
||||
(%send-tty-break-fdes fdes duration)))))
|
||||
|
||||
(define-errno-syscall (%send-tty-break-fdes fdes duration)
|
||||
%send-tty-break-fdes/errno)
|
||||
|
|
@ -237,12 +259,16 @@
|
|||
;;; Drain the main vein.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (drain-tty fdport)
|
||||
(cond ((integer? fdport) (%tcdrain fdport)) ; File descriptor.
|
||||
((fdport? fdport) ; Scheme port -- flush first.
|
||||
(force-output fdport)
|
||||
(sleazy-call/fdes fdport %tcdrain))
|
||||
(else (error "Illegal argument to DRAIN-TTY" fdport))))
|
||||
(define (drain-tty . maybe-tty)
|
||||
(let ((tty (:optional maybe-tty (current-output-port))))
|
||||
(cond ((integer? tty) (%tcdrain tty)) ; File descriptor.
|
||||
((fdport? tty) ; Scheme port -- flush first.
|
||||
(force-output tty)
|
||||
(sleazy-call/fdes tty %tcdrain))
|
||||
((string? tty) ; file name
|
||||
(call-with-output-file tty
|
||||
(lambda (p) (sleazy-call/fdes p %tcdrain))))
|
||||
(else (error "Illegal argument to DRAIN-TTY" tty)))))
|
||||
|
||||
(define-errno-syscall (%tcdrain fdes) %tcdrain/errno)
|
||||
(define-foreign %tcdrain/errno (tcdrain (integer fdes)) no-declare ; Ultrix
|
||||
|
|
@ -254,13 +280,21 @@
|
|||
;;; Note that the magic %flush-tty/foo constants must be defined before this
|
||||
;;; file is loaded due to the flush-tty/foo definitions below.
|
||||
|
||||
(define (make-tty-flusher flag)
|
||||
(lambda (fdport)
|
||||
(sleazy-call/fdes fdport (lambda (fdes) (%tcflush fdes flag)))))
|
||||
(define (make-input-tty-flusher flag)
|
||||
(lambda maybe-tty
|
||||
(sleazy-call/file (:optional maybe-tty (current-input-port))
|
||||
call-with-input-file
|
||||
(lambda (fdes) (%tcflush fdes flag)))))
|
||||
|
||||
(define flush-tty/input (make-tty-flusher %flush-tty/input))
|
||||
(define flush-tty/output (make-tty-flusher %flush-tty/output))
|
||||
(define flush-tty/both (make-tty-flusher %flush-tty/both))
|
||||
(define (make-output-tty-flusher flag)
|
||||
(lambda maybe-tty
|
||||
(sleazy-call/file (:optional maybe-tty (current-output-port))
|
||||
call-with-output-file
|
||||
(lambda (fdes) (%tcflush fdes flag)))))
|
||||
|
||||
(define flush-tty/input (make-input-tty-flusher %flush-tty/input))
|
||||
(define flush-tty/output (make-output-tty-flusher %flush-tty/output))
|
||||
(define flush-tty/both (make-input-tty-flusher %flush-tty/both))
|
||||
|
||||
(define-errno-syscall (%tcflush fdes flag) %tcflush/errno)
|
||||
(define-foreign %tcflush/errno (tcflush (integer fdes) (integer flag))
|
||||
|
|
@ -273,14 +307,22 @@
|
|||
;;; Note that the magic %tcflow/foo constants must be defined before this
|
||||
;;; file is loaded due to the definitions below.
|
||||
|
||||
(define (make-flow-controller action)
|
||||
(lambda (fdport)
|
||||
(sleazy-call/fdes fdport (lambda (fdes) (%tcflow fdes action)))))
|
||||
(define (make-input-flow-controller action)
|
||||
(lambda maybe-tty
|
||||
(sleazy-call/file (:optional maybe-tty (current-input-port))
|
||||
call-with-input-file
|
||||
(lambda (fdes) (%tcflow fdes action)))))
|
||||
|
||||
(define start-tty-output (make-flow-controller %tcflow/start-out))
|
||||
(define stop-tty-output (make-flow-controller %tcflow/stop-out))
|
||||
(define start-tty-input (make-flow-controller %tcflow/start-in))
|
||||
(define stop-tty-input (make-flow-controller %tcflow/stop-in))
|
||||
(define (make-output-flow-controller action)
|
||||
(lambda maybe-tty
|
||||
(sleazy-call/file (:optional maybe-tty (current-output-port))
|
||||
call-with-output-file
|
||||
(lambda (fdes) (%tcflow fdes action)))))
|
||||
|
||||
(define start-tty-output (make-output-flow-controller %tcflow/start-out))
|
||||
(define stop-tty-output (make-output-flow-controller %tcflow/stop-out))
|
||||
(define start-tty-input (make-input-flow-controller %tcflow/start-in))
|
||||
(define stop-tty-input (make-input-flow-controller %tcflow/stop-in))
|
||||
|
||||
(define-errno-syscall (%tcflow fdes action) %tcflow/errno)
|
||||
|
||||
|
|
@ -310,8 +352,8 @@
|
|||
;;; Set/Get tty process group
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (set-tty-process-group port/fd proc-group)
|
||||
(sleazy-call/fdes port/fd
|
||||
(define (set-tty-process-group tty proc-group)
|
||||
(sleazy-call/file tty call-with-input-file
|
||||
(lambda (fd)
|
||||
(%set-tty-process-group fd (if (integer? proc-group)
|
||||
proc-group
|
||||
|
|
@ -325,8 +367,8 @@
|
|||
no-declare ; Ultrix
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define (tty-process-group port/fd)
|
||||
(sleazy-call/fdes port/fd %tty-process-group))
|
||||
(define (tty-process-group tty)
|
||||
(sleazy-call/file tty call-with-input-file %tty-process-group))
|
||||
|
||||
(define-errno-syscall (%tty-process-group fd) %tty-process-group/errno
|
||||
pid)
|
||||
|
|
|
|||
Loading…
Reference in New Issue