Moved set/get tty process group code to tty.scm.
Added open-control-tty.
This commit is contained in:
parent
b453a05b92
commit
6ff4d51074
39
scsh/tty.c
39
scsh/tty.c
|
@ -6,6 +6,7 @@
|
||||||
#include <stdlib.h> /* For malloc. */
|
#include <stdlib.h> /* For malloc. */
|
||||||
#include "libcig.h"
|
#include "libcig.h"
|
||||||
|
|
||||||
|
#include <unistd.h>
|
||||||
#include <termios.h>
|
#include <termios.h>
|
||||||
|
|
||||||
/* Make sure foreign-function stubs interface to the C funs correctly: */
|
/* Make sure foreign-function stubs interface to the C funs correctly: */
|
||||||
|
@ -106,3 +107,41 @@ scheme_value df_tcflow(long nargs, scheme_value *args)
|
||||||
return ret1;
|
return ret1;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
scheme_value df_tcsetpgrp(long nargs, scheme_value *args)
|
||||||
|
{
|
||||||
|
extern int tcsetpgrp(int , pid_t );
|
||||||
|
scheme_value ret1;
|
||||||
|
int r1;
|
||||||
|
|
||||||
|
cig_check_nargs(2, nargs, "tcsetpgrp");
|
||||||
|
r1 = tcsetpgrp(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0]));
|
||||||
|
ret1 = errno_or_false(r1);
|
||||||
|
return ret1;
|
||||||
|
}
|
||||||
|
|
||||||
|
scheme_value df_tcgetpgrp(long nargs, scheme_value *args)
|
||||||
|
{
|
||||||
|
extern pid_t tcgetpgrp(int );
|
||||||
|
scheme_value ret1;
|
||||||
|
pid_t r1;
|
||||||
|
|
||||||
|
cig_check_nargs(2, nargs, "tcgetpgrp");
|
||||||
|
r1 = tcgetpgrp(EXTRACT_FIXNUM(args[1]));
|
||||||
|
ret1 = errno_or_false(r1);
|
||||||
|
VECTOR_REF(*args,0) = ENTER_FIXNUM(r1);
|
||||||
|
return ret1;
|
||||||
|
}
|
||||||
|
|
||||||
|
scheme_value df_open_ctty(long nargs, scheme_value *args)
|
||||||
|
{
|
||||||
|
extern int open_ctty(const char *, int );
|
||||||
|
scheme_value ret1;
|
||||||
|
int r1;
|
||||||
|
|
||||||
|
cig_check_nargs(3, nargs, "open_ctty");
|
||||||
|
r1 = open_ctty(cig_string_body(args[2]), EXTRACT_FIXNUM(args[1]));
|
||||||
|
ret1 = errno_or_false(r1);
|
||||||
|
VECTOR_REF(*args,0) = ENTER_FIXNUM(r1);
|
||||||
|
return ret1;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
57
scsh/tty.scm
57
scsh/tty.scm
|
@ -14,6 +14,7 @@
|
||||||
;;; Rehacked by Olin 8/95.
|
;;; Rehacked by Olin 8/95.
|
||||||
|
|
||||||
(foreign-source
|
(foreign-source
|
||||||
|
"#include <unistd.h>"
|
||||||
"#include <termios.h>"
|
"#include <termios.h>"
|
||||||
""
|
""
|
||||||
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
||||||
|
@ -280,3 +281,59 @@
|
||||||
|
|
||||||
(define (decode-baud-rate code) ; value of BAUD/9600 -> 9600
|
(define (decode-baud-rate code) ; value of BAUD/9600 -> 9600
|
||||||
(car (vector-ref baud-rates code)))
|
(car (vector-ref baud-rates code)))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Set/Get tty process group
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (set-tty-process-group port/fd proc-group)
|
||||||
|
(call/fdes port/fd
|
||||||
|
(lambda (fd)
|
||||||
|
(%set-tty-process-group fd (if (integer? proc-group)
|
||||||
|
proc-group
|
||||||
|
(proc:pid proc-group))))))
|
||||||
|
|
||||||
|
(define-simple-errno-syscall (%set-tty-process-group fdes pid)
|
||||||
|
%set-tty-process-group/errno)
|
||||||
|
|
||||||
|
(define-foreign %set-tty-process-group/errno (tcsetpgrp (fixnum fdes)
|
||||||
|
(pid_t pid))
|
||||||
|
(to-scheme integer errno_or_false))
|
||||||
|
|
||||||
|
(define (tty-process-group port/fd)
|
||||||
|
(call/fdes port/fd %tty-process-group))
|
||||||
|
|
||||||
|
(define-errno-syscall (%tty-process-group fd) %tty-process-group/errno
|
||||||
|
pid)
|
||||||
|
|
||||||
|
(define-foreign %tty-process-group/errno (tcgetpgrp (fixnum fdes))
|
||||||
|
(multi-rep (to-scheme pid_t errno_or_false)
|
||||||
|
pid_t))
|
||||||
|
|
||||||
|
;;; (open-control-tty fname [flags])
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;; Open a control tty, return a port.
|
||||||
|
;;; This procedure is only guaranteed to work when the process doesn't already
|
||||||
|
;;; have a control tty -- e.g., right after a (BECOME-PROCESS-LEADER) call.
|
||||||
|
;;; This limted functionality is about all we can provide portably across BSD,
|
||||||
|
;;; SunOS, and SVR4.
|
||||||
|
|
||||||
|
(define (open-control-tty ttyname maybe-flags)
|
||||||
|
(let ((flags (optional-arg maybe-flags open/read+write)))
|
||||||
|
(receive (errno fd) (open-control-tty/errno ttyname flags)
|
||||||
|
(if errno
|
||||||
|
(errno-error errno open-control-tty ttyname flags)
|
||||||
|
|
||||||
|
(let* ((access (bitwise-and flags open/access-mask))
|
||||||
|
(port ((if (or (= access open/read) (= access open/read+write))
|
||||||
|
make-input-fdport
|
||||||
|
make-output-fdport)
|
||||||
|
fd)))
|
||||||
|
(%install-port fd port)
|
||||||
|
port)))))
|
||||||
|
|
||||||
|
(define-foreign open-control-tty/errno (open_ctty (string ttyname)
|
||||||
|
(fixnum flags))
|
||||||
|
(multi-rep (to-scheme integer errno_or_false)
|
||||||
|
integer))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue