source: release/1.9/source/library/pty.lisp @ 15706

Last change on this file since 15706 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2002-2009 Clozure Associates.
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; (very) preliminary support for dealing with TTYs (and PTYs).
18
19(in-package "CCL")
20
21;;; Open a (connected) pair of pty file descriptors, such that anything
22;;; written to one can be read from the other.
23#+linuxppc-target
24(eval-when (:load-toplevel :execute)
25  (open-shared-library "libutil.so"))
26
27(defun open-pty-pair ()
28  (rlet ((alphap :unsigned 0)
29         (betap :unsigned 0))
30    (let* ((status (#_openpty alphap betap (%null-ptr) (%null-ptr) (%null-ptr))))
31      (if (eql status 0)
32        (values (pref alphap :unsigned) (pref betap :unsigned))
33        (%errno-disp (%get-errno))))))
34
35
36(defun %get-tty-attributes (tty-fd &optional control-chars)
37  (if (and control-chars
38           (not (and (typep control-chars 'simple-string)
39                     (= (length control-chars) #$NCCS))))
40    (report-bad-arg control-chars '(or null (simple-string #.#$NCCS))))
41  (rlet ((attr :termios))
42    (let* ((result (#_tcgetattr tty-fd attr)))
43      (if (< result 0)
44        (values nil nil nil nil nil nil nil)
45        (progn
46          (if control-chars
47            (%str-from-ptr (pref attr :termios.c_cc) #$NCCS control-chars))
48          (values
49           (pref attr :termios.c_iflag)
50           (pref attr :termios.c_oflag)
51           (pref attr :termios.c_cflag)
52           (pref attr :termios.c_lflag)
53           #+darwin-target 0
54           #-darwin-target
55           (pref attr :termios.c_line)
56           control-chars
57           (pref attr :termios.c_ispeed)
58           (pref attr :termios.c_ospeed)))))))
59
60(defun %set-tty-attributes (tty &key
61                                input-modes
62                                output-modes
63                                control-modes
64                                local-modes
65                                control-chars
66                                input-speed
67                                output-speed)
68  (if (and control-chars
69           (not (and (typep control-chars 'simple-string)
70                     (= (length control-chars) #$NCCS))))
71    (report-bad-arg control-chars '(or null (simple-string #.#$NCCS))))
72  (rlet ((attr :termios))
73        (let* ((get-ok (#_tcgetattr tty attr))
74               (write-back nil))
75          (when (eql 0 get-ok)
76            (when input-modes
77              (setf (pref attr :termios.c_iflag) input-modes)
78              (setq write-back t))
79            (when output-modes
80              (setf (pref attr :termios.c_oflag) output-modes)
81              (setq write-back t))
82            (when control-modes
83              (setf (pref attr :termios.c_cflag) control-modes)
84              (setq write-back t))
85            (when local-modes
86              (setf (pref attr :termios.c_lflag) local-modes)
87              (setq write-back t))
88            (when control-chars
89              (%cstr-pointer control-chars (pref attr :termios.c_cc) nil)
90              (setq write-back t))
91            (when input-speed
92              (setf (pref attr :termios.c_ispeed) input-speed)
93              (setq write-back t))
94            (when output-speed
95              (setf (pref attr :termios.c_ospeed) output-speed)
96              (setq write-back t))
97            (and write-back
98                 (eql 0 (#_tcsetattr tty #$TCSAFLUSH attr)))))))
99
100(defun enable-tty-input-modes (tty mask)
101  (let* ((old (nth-value 0 (%get-tty-attributes tty))))
102    (when old
103      (%set-tty-attributes tty :input-modes (logior old mask)))))
104
105(defun disable-tty-input-modes (tty mask)
106  (let* ((old (nth-value 0 (%get-tty-attributes tty))))
107    (when old
108      (%set-tty-attributes tty :input-modes (logand old (lognot mask))))))
109
110(defun enable-tty-output-modes (tty mask)
111  (let* ((old (nth-value 1 (%get-tty-attributes tty))))
112    (when old
113      (%set-tty-attributes tty :output-modes (logior old mask)))))
114
115(defun disable-tty-output-modes (tty mask)
116  (let* ((old (nth-value 1 (%get-tty-attributes tty))))
117    (when old
118      (%set-tty-attributes tty :output-modes (logand old (lognot mask))))))
119
120(defun enable-tty-control-modes (tty mask)
121  (let* ((old (nth-value 2 (%get-tty-attributes tty))))
122    (when old
123      (%set-tty-attributes tty :control-modes (logior old mask)))))
124
125(defun disable-tty-control-modes (tty mask)
126  (let* ((old (nth-value 2 (%get-tty-attributes tty))))
127    (when old
128      (%set-tty-attributes tty :control-modes (logand old (lognot mask))))))
129
130(defun enable-tty-local-modes (tty mask)
131  (let* ((old (nth-value 3 (%get-tty-attributes tty))))
132    (when old
133      (%set-tty-attributes tty :local-modes (logior old mask)))))
134
135(defun disable-tty-local-modes (tty mask)
136  (let* ((old (nth-value 3 (%get-tty-attributes tty))))
137    (when old
138      (%set-tty-attributes tty :local-modes (logand old (lognot mask))))))
139
140(defun set-tty-raw (tty)
141  (rlet ((attr :termios))
142    (#_cfmakeraw attr)
143    (eql 0 (#_tcsetattr tty #$TCSAFLUSH attr))))
Note: See TracBrowser for help on using the repository browser.