![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ipc.cl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / dist-1.3 / fi|
Return to ipc.cl CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / dist-1.3 / fi |
1.1 root 1: ;; -[Mon Nov 28 13:35:34 1988 by layer]-
2: ;;
3: ;; Allegro CL IPC interface
4: ;;
5: ;; copyright (c) 1987, 1988 Franz Inc, Berkeley, Ca.
6: ;;
7: ;; The software, data and information contained herein are proprietary
8: ;; to, and comprise valuable trade secrets of, Franz, Inc. They are
9: ;; given in confidence by Franz, Inc. pursuant to a written license
10: ;; agreement, and stored only in accordance with the terms of such license.
11: ;;
12: ;; Restricted Rights Legend
13: ;; ------------------------
14: ;; Use, duplication, and disclosure by the Government are subject to
15: ;; restrictions of Restricted Rights for Commercial Software developed
16: ;; at private expense as specified in DOD FAR 52.227-7013 (c) (1) (ii).
17: ;;
18: ;;
19: ;; $Header: ipc.cl,v 1.20 89/02/14 17:14:34 layer Exp $
20: ;; $Locker: $
21: ;;
22: ;; This code is a preliminary IPC interface for ExCL. The functionality
23: ;; will be extended apace, but right now it only implements a Common Lisp
24: ;; Server. The server can be started by a CL and it establishes a daemon
25: ;; listening to a socket. Any process wanting to talk to the lisp
26: ;; can connect to the socket and a new Lisp Listener will be started.
27:
28: (provide :ipc)
29:
30: (in-package :ipc :use '(:lisp :excl :ff :mp))
31:
32: (export '(start-lisp-listener-daemon open-network-stream
33: *unix-domain* *inet-port*))
34:
35: (require :process)
36: (require :foreign)
37: (require :cstructs)
38:
39: (defvar *unix-domain* t
40: "If non-nil then use a UNIX domain socket, otherwise use an internet
41: domain port (see *inet-port* variable).")
42:
43: (defparameter *inet-port* 6789
44: "The internet service port number on which Lisp listens for connections.
45: The value is this variable is only used when *unix-domain* is non-nil, in
46: which case a UNIX domain socket is used.")
47:
48: (defconstant *af-unix* 1
49: "The AF_UNIX constant from /usr/include/sys/socket.h.")
50:
51: (defconstant *af-inet* 2
52: "The AF_INET constant from /usr/include/sys/socket.h.")
53:
54: (defconstant *sock-stream* 1
55: "The SOCK_STREAM constant from /usr/include/sys/socket.h.")
56:
57: (defvar *junk-name* (make-array 1))
58: (defvar *junk-address* (make-array 1 :element-type '(unsigned-byte 32)))
59:
60: (defun entry-point-exists-p (string)
61: (setf (aref *junk-name* 0) string)
62: (setf (aref *junk-address* 0) 0)
63: (= 0 (get-entry-points *junk-name* *junk-address*)))
64:
65: (defvar lisp-listener-daemon-ff-loaded nil)
66: (defvar lisp-listener-daemon nil)
67:
68: (defparameter *needed-funcs*
69: (mapcar #'convert-to-lang
70: '("socket" "bind" "listen" "accept" "getsockname" "gethostbyname"
71: "connect" "bcopy" "bcmp" "bzero")))
72:
73: (eval-when (load eval)
74: (unless lisp-listener-daemon-ff-loaded
75: (unless (eql (excl::machine-code) '#.comp::machine-code-tek4300)
76: (unless (or (eq '#.comp::machine-code-apollo (excl::machine-code))
77: (dolist (name *needed-funcs* t)
78: (if (not (entry-point-exists-p name))
79: (return nil))))
80: (princ "; Loading from C library...")
81: (force-output)
82: (unless (load "" :verbose nil :unreferenced-lib-names *needed-funcs*)
83: (error "foreign load failed"))
84: (princ "done")
85: (terpri)))
86: (setq lisp-listener-daemon-ff-loaded t)
87: (defforeign-list '((getuid) (socket) (bind) (accept)
88: (getsockname) (gethostbyname) (select)
89: (connect) (bcopy) (bzero) (bcmp) (perror)
90: (unix-listen :entry-point #,(convert-to-lang "listen"))
91: (unix-close :entry-point #,(convert-to-lang "close")))
92: :print nil)))
93:
94: (defcstruct sockaddr-in
95: (family :unsigned-short)
96: (port :unsigned-short)
97: (addr :unsigned-long)
98: (zero 8 :unsigned-byte))
99:
100: (defcstruct sockaddr-un
101: (family :unsigned-short)
102: (path 109 :char))
103:
104: (defcstruct timeval
105: (sec :long)
106: (usec :long))
107:
108: (defcstruct unsigned-long
109: (unsigned-long :unsigned-long))
110:
111: ;; from /usr/include/netdb.h
112: (defcstruct (hostent :malloc)
113: (name * :char)
114: (aliases * * :char)
115: (addrtype :long)
116: (length :long)
117: (addr * :char))
118:
119: (defun start-lisp-listener-daemon ()
120: "This function starts a process which listens to a socket for attempts to
121: connect, and starts a lisp listener for each connection. If the Lisp
122: listener ever completes, it makes sure files are closed."
123: (unless lisp-listener-daemon
124: (setq lisp-listener-daemon
125: (process-run-function "TCP Listener Socket Daemon"
126: 'lisp-listener-socket-daemon))
127: (setf (getf (process-property-list lisp-listener-daemon) ':no-interrupts)
128: t)))
129:
130: (defvar *socket-pathname* nil)
131:
132: (defun lisp-listener-socket-daemon ()
133: (let (listen-socket-fd
134: (listen-sockaddr
135: (if *unix-domain*
136: (make-cstruct 'sockaddr-un)
137: (make-cstruct 'sockaddr-in)))
138: (timeval (make-cstruct 'timeval))
139: (mask-obj (make-cstruct 'unsigned-long))
140: (int (make-cstruct 'unsigned-long))
141: mask
142: stream
143: proc-name
144: fd)
145:
146: (unless *socket-pathname*
147: (format nil "~a/~a" (sys:getenv "HOME") ".excl_to_emacs"))
148:
149: (setf (timeval-sec timeval) 0
150: (timeval-usec timeval) 0)
151: (unwind-protect
152: (progn
153: (if *unix-domain* (errorset (delete-file *socket-pathname*)))
154: (setq listen-socket-fd (socket
155: (if *unix-domain* *af-unix* *af-inet*)
156: *sock-stream*
157: 0))
158: (when (< listen-socket-fd 0)
159: (perror "socket")
160: (setq listen-socket-fd nil)
161: (return-from lisp-listener-socket-daemon nil))
162: (mp::mpwatchfor listen-socket-fd)
163:
164: ;; Compute a select mask for the daemon's socket.
165: (setq mask (ash 1 listen-socket-fd))
166:
167: (if* *unix-domain*
168: then (setf (sockaddr-un-family listen-sockaddr) *af-unix*)
169: ;; Set pathname.
170: (dotimes (i (length *socket-pathname*)
171: (setf (sockaddr-un-path listen-sockaddr i) 0))
172: (setf (sockaddr-un-path listen-sockaddr i)
173: (char-int (elt *socket-pathname* i))))
174: else ;; a crock:
175: (bzero listen-sockaddr (ff::cstruct-len 'sockaddr-in))
176: (setf (sockaddr-in-family listen-sockaddr) *af-inet*
177: (sockaddr-in-port listen-sockaddr) *inet-port*))
178:
179: (unless (zerop (bind listen-socket-fd
180: listen-sockaddr
181: (if *unix-domain*
182: (+ (length *socket-pathname*) 2)
183: (ff::cstruct-len 'sockaddr-in))))
184: (perror "bind")
185: (return-from lisp-listener-socket-daemon nil))
186:
187: (unless (zerop (unix-listen listen-socket-fd 5))
188: (perror "listen")
189: (return-from lisp-listener-socket-daemon nil))
190: (loop
191: (process-wait "waiting for a connection"
192: #'(lambda (mask mask-obj timeout)
193: (setf (unsigned-long-unsigned-long mask-obj) mask)
194: (not (zerop (select 32 mask-obj 0 0 timeout))))
195: mask mask-obj timeval)
196: (setf (unsigned-long-unsigned-long int)
197: (if *unix-domain*
198: (ff::cstruct-len 'sockaddr-un)
199: (ff::cstruct-len 'sockaddr-in)))
200: (setq fd (accept listen-socket-fd listen-sockaddr int))
201: (when (< fd 0)
202: (perror "accept")
203: (return-from lisp-listener-socket-daemon nil))
204:
205: (setq stream
206: (excl::make-buffered-terminal-stream fd fd t t))
207:
208: ;; the first thing that comes over the stream is the name of the
209: ;; emacs buffer which was created--we name the process the same.
210: (setq proc-name (read stream))
211:
212: (if* *unix-domain*
213: then (process-run-function
214: proc-name
215: 'lisp-listener-with-stream-as-terminal-io stream)
216: else (let ((hostaddr (logand
217: (sockaddr-in-addr listen-sockaddr) #xff)))
218: (format t ";;; starting listener-~d (host ~d)~%" fd
219: hostaddr)
220: (if* (and nil
221: ;; the next line checks that the connection
222: ;; is coming from the current machine
223: (not (eql 1 hostaddr))
224: )
225: then (format t ";;; access denied for addr ~s~%"
226: hostaddr)
227: (refuse-connection fd)
228: else (process-run-function
229: proc-name
230: 'lisp-listener-with-stream-as-terminal-io
231: stream))))))
232: (when listen-socket-fd
233: (mp::mpunwatchfor listen-socket-fd)
234: (unix-close listen-socket-fd)
235: (setq lisp-listener-daemon nil)))))
236:
237: (defun refuse-connection (fd &aux s)
238: (setq s (excl::make-buffered-terminal-stream fd fd t t))
239: (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
240: (format s "connection refused.~%")
241: (force-output s)
242: (setf (excl::sm_bterm-out-pos s) 0)
243: (close s))
244:
245: (defun lisp-listener-with-stream-as-terminal-io (s)
246: (unwind-protect
247: (progn
248: (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
249: (tpl:start-interactive-top-level
250: s 'tpl:top-level-read-eval-print-loop nil))
251: ;; This next crock is to prevent the force-output done by close from
252: ;; signalling an error if there are characters buffered to the output
253: ;; stream, which there will be if the remote client closed the connection.
254: ;; This should be changed to a clear-output once that works on a buffered
255: ;; terminal stream.
256: (setf (excl::sm_bterm-out-pos s) 0)
257: (close s)))
258:
259: (defun open-network-stream (&key host port socket-file)
260: "Open a stream to a port, which is a TCP/IP communication channel. There
261: are two types of ports supported, UNIX and INTERNET domain. The domain is
262: chosen based on the keyword arguments actually used: HOST and PORT are for
263: internet domain ports and SOCKET-FILE is for unix domain ports."
264: (if (and (or (null host) (null port))
265: (null socket-file))
266: (error "Must either supply HOST and PORT *or* SOCKET-FILE keywords."))
267: (if* socket-file
268: then ;; UNIX domain
269: (let ((server (make-cstruct 'sockaddr-un))
270: socket-fd)
271: (setf (sockaddr-un-family server) *af-unix*)
272: (dotimes (i (length socket-file)
273: (setf (sockaddr-un-path server i) 0))
274: (setf (sockaddr-un-path server i)
275: (char-int (elt socket-file i))))
276: (setq socket-fd (socket *af-unix* *sock-stream* 0))
277: (if (< (connect socket-fd server (+ 2 (length socket-file))) 0)
278: (error "connect failed to ~s" socket-file))
279: (excl::make-buffered-terminal-stream socket-fd socket-fd t t))
280: else ;; INTERNET domain
281: (let (sock server hostaddress)
282: ;; Open a socket
283: (when (< (setf sock (socket *af-inet* *sock-stream* 0)) 0)
284: (error "couldn't open socket"))
285: ;; construct a socket address
286: (setf server (make-cstruct 'sockaddr-in))
287: (bzero server (ff::cstruct-len 'sockaddr-in))
288: (when (= (setf hostaddress (gethostbyname host)) 0)
289: (error "unknown host: ~a" host))
290: ;; This next line is what they invented the word "hack" for.
291: ;; If I knew how to pass the address of the addr field in server, I
292: ;; wouldn't have to do this.
293: ;; Be sure that this precedes writes to other fields in server.
294: (if (not (= 4 (hostent-length hostaddress)))
295: (error "address length not 4"))
296: (setf (sockaddr-in-addr server)
297: (si:memref-int (hostent-addr hostaddress) 0 0 :unsigned-long))
298: (setf (sockaddr-in-family server) *af-inet*)
299: (setf (sockaddr-in-port server) port)
300: ;; open the connection
301: (when (< (connect sock server (ff::cstruct-len 'sockaddr-in)) 0)
302: (unix-close sock)
303: (error "couldn't connect to socket"))
304: ;; build and return the stream
305: (excl::make-buffered-terminal-stream sock sock t t))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.