![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tcplisp.el 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 tcplisp.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / dist-1.3 / fi |
1.1 root 1: ;;
2: ;; copyright (C) 1987, 1988 Franz Inc, Berkeley, Ca.
3: ;;
4: ;; The software, data and information contained herein are the property
5: ;; of Franz, Inc.
6: ;;
7: ;; This file (or any derivation of it) may be distributed without
8: ;; further permission from Franz Inc. as long as:
9: ;;
10: ;; * it is not part of a product for sale,
11: ;; * no charge is made for the distribution, other than a tape
12: ;; fee, and
13: ;; * all copyright notices and this notice are preserved.
14: ;;
15: ;; If you have any comments or questions on this interface, please feel
16: ;; free to contact Franz Inc. at
17: ;; Franz Inc.
18: ;; Attn: Kevin Layer
19: ;; 1995 University Ave
20: ;; Suite 275
21: ;; Berkeley, CA 94704
22: ;; (415) 548-3600
23: ;; or
24: ;; emacs-info%[email protected]
25: ;; ucbvax!franz!emacs-info
26: ;;
27: ;; $Header: tcplisp.el,v 1.11 88/11/21 13:37:02 layer Exp $
28: ;;
29: ;; Description:
30: ;; Implemented in this file are the backdoor lisp listener and lisp
31: ;; evalserver.
32:
33: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34: ;;;;;;;;;;;;;;;;;;;;; The Backdoor Lisp Listener ;;;;;;;;;;;;;;;;;;;;;;;;;;;
35: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36:
37: ;;;;
38: ;;; User Visibles
39: ;;;;
40:
41: (defvar fi:unix-domain t
42: "*If non-nil, then `fi:unix-domain-socket' specifies the name of the
43: socket file. It is recommended that this interface be used, and not
44: internet ports, because when internet ports are used only one process on a
45: machine may use this interface (it is a global resource). When using UNIX
46: domain sockets, communication is done through a socket file in the user's
47: home directory. But, if you really want to use internet ports, here are
48: the steps to take:
49:
50: 1. Set this variable to nil.
51: 2. Add the following line to /etc/services:
52: excl 6789/tcp
53: 3. Make sure `fi:local-host-name' is in /etc/hosts and points to the local
54: or loopback host.
55: 4. On the Common Lisp side, put the following in you .clinit.cl file:
56: (setq ipc:*inet-port* 6789) ; the number from /etc/services
57: (setq ipc:*unix-domain* nil)
58:
59: The problem with this, is that people can then use `telnet' to get a
60: listener on your lisp!")
61:
62: (defvar fi:unix-domain-socket "~/.excl_to_emacs"
63: "*The name of the socket file that lisp and emacs use to communicate.
64: This is used when fi:unix-domain is non-nil.")
65:
66: (defvar fi:local-host-name "localhost"
67: "*On 4.2 BSD the name of 127.1--usually localhost or loopback.
68: This is only used when fi:unix-domain is nil.")
69:
70: (defvar fi:excl-service-name "excl"
71: "*The service name from /etc/services (`tcp' type). This is only used
72: when fi:unix-domain is nil.")
73:
74: (defvar fi:source-info-not-found-hook 'find-tag
75: "*The value of this variable is funcalled when source information is not
76: present in Lisp for a symbol. The function is given one argument, the name
77: for which source is desired (a string). The null string means use the word
78: at the point as the search word. This allows the GNU Emacs tags facility
79: to be used when the information is not present in Lisp.")
80:
81: ;;;;
82: ;;; Internals
83: ;;;;
84:
85: (defvar fi::lisp-macroexpand-command
86: "(progn
87: (errorset
88: (let ((*print-pretty* t)(excl::*print-nickname* t)(*package* %s))
89: (with-open-file (*standard-input* \"%s\")
90: (lisp:prin1 (%s (lisp:read)))))
91: t)
92: (values))\n")
93:
94: (defvar fi::backdoor-process nil
95: "Process connected to sublist socket for fi:lisp-arglist and friends.")
96:
97: (defvar fi::backdoor-read-eval-loop
98: "(progn
99: (setf (getf (mp:process-property-list mp:*current-process*)
100: ':no-interrupts)
101: t)
102: (loop
103: (princ \"&\n\")
104: (errorset (eval (read)) t)))\n"
105: "The program executed by the backdoor lisp listener.")
106:
107: (defun fi:backdoor-eval (string &rest args)
108: "Evaluate apply format to STRING and ARGS and evaluate this in Common
109: Lisp at the other end of our socket."
110: (if (fi::background-sublisp-process)
111: (process-send-string
112: fi::backdoor-process
113: (format "(progn (format t \"\1\") %s)\n"
114: (apply 'format string args)))
115: (error "The backdoor listener to Lisp is not responding.")))
116:
117: (defun fi::background-sublisp-process ()
118: (if (or (null fi::backdoor-process)
119: (not (eq (process-status fi::backdoor-process) 'open)))
120: (progn
121: (and fi::backdoor-process
122: (delete-process fi::backdoor-process))
123: (setq fi::backdoor-process
124: (condition-case ()
125: (if fi:unix-domain
126: (open-network-stream "lisp-backdoor" nil
127: (expand-file-name fi:unix-domain-socket)
128: 0)
129: (open-network-stream "lisp-backdoor" nil fi:local-host-name
130: fi:excl-service-name))
131: (error nil)))
132: (if fi::backdoor-process
133: (progn
134: (setq fi::sublisp-returns-state nil)
135: (process-send-string ; first send the process name
136: fi::backdoor-process
137: (format "\"%s\"" "GNU Listener"))
138: (process-send-string fi::backdoor-process
139: fi::backdoor-read-eval-loop)
140: (set-process-filter fi::backdoor-process
141: 'fi::backdoor-filter)))))
142: fi::backdoor-process)
143:
144: ;; This is the filter for the back door lisp process.
145: ;; It collects output until it sees a ctl-A\n, then prints the preceding
146: ;; collected text. If the text fits on one line, it is printed to the message
147: ;; area. Otherwise it goes to a temporary pop up buffer.
148:
149: (defvar fi::sublisp-returns "")
150: (defvar fi::sublisp-returns-state nil)
151:
152: (defun fi::backdoor-filter (proc string)
153: ;; This collects everything returned until a ^A\n prompt is seen,
154: ;; then displays it. The first time is special cased to throw away
155: ;; the initial prompt without display. Someday we should use the state
156: ;; variable for detecting screwups and coordinating reset.
157: ;; The \n is part of the prompt so that a subsequent prettyprint isn't
158: ;; confused about the starting column.
159: ;;
160: ;; The first character has special meaning:
161: ;; ^A toss the output from lisp after eval (for fi:backdoor-eval)
162: ;; ^B for fi:lisp-find-tag
163: ;; ^C for fi:lisp-find-tag-other-window
164: (setq fi::sublisp-returns (concat fi::sublisp-returns string))
165: (let ((len (length fi::sublisp-returns)))
166: (if (and (= 10 (aref fi::sublisp-returns (- len 1))); newline
167: (= 1 (aref fi::sublisp-returns (- len 2))))
168: (if (eq fi::sublisp-returns-state nil); ignore the startup response
169: (setq fi::sublisp-returns-state t
170: fi::sublisp-returns "")
171: (progn (setq fi::sublisp-returns
172: (substring fi::sublisp-returns
173: (progn (string-match "\n*" fi::sublisp-returns)
174: (match-end 0))
175: -2))
176: (let ((first-char (elt fi::sublisp-returns 0)))
177: (cond
178: ((= first-char 1)
179: ;;throw away the result
180: (setq fi::sublisp-returns ""))
181: ((or (= first-char 2) (= first-char 3))
182: (fi::backdoor-find-tag-request (= first-char 3)))
183: (t
184: (if (or (> (length fi::sublisp-returns) 78)
185: ;; should be mbuf width
186: (string-match "\n" fi::sublisp-returns nil))
187: (with-output-to-temp-buffer "*CL-Help*"
188: (princ fi::sublisp-returns))
189: (message fi::sublisp-returns))
190: (setq fi::sublisp-returns "")))))))))
191:
192: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193: ;;;;;;;;;;;;;;;;;;;;;;;; The Lisp Eval Server ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
194: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
195:
196: ;;;;
197: ;;; User Visibles
198: ;;;;
199:
200: (defconst fi:lisp-evalserver-timeout 5
201: "The time which fi:eval-in-lisp will wait before timing out and
202: signalling an error. Without a timeout Emacs would potentially be locked
203: out if Lisp did not `return' a result.")
204:
205: (defconst fi:lisp-evalserver-number-reads 20
206: "The number of times the Lisp eval server tries to read from the
207: lisp-evalserver process before giving up. Without this feature Emacs would
208: hang if Lisp got into an infinite loop while printing. If the size of the
209: values returned to Emacs is large, then the value of this variable should
210: be increased.")
211:
212: (defun fi:eval-in-lisp (string &rest args)
213: "Apply format (in Emacs) to STRING and ARGS and evaluate the result
214: in the Common Lisp to which we are connected. If a lisp-eval-server has
215: not been started, then this function starts it."
216: (if (not (fi::lisp-evalserver-process))
217: (error "The Lisp Eval Server is not responding."))
218: (setq fi::lisp-evalserver-response nil)
219: (setq fi::lisp-evalserver-returns "")
220: (process-send-string fi::lisp-evalserver-process
221: (format "%s\n" (apply 'format string args)))
222: (accept-process-output fi::lisp-evalserver-process
223: fi:lisp-evalserver-timeout)
224: (let ((i 0))
225: (while (and (< i fi:lisp-evalserver-number-reads)
226: fi::lisp-evalserver-collecting)
227: (accept-process-output fi::lisp-evalserver-process
228: fi:lisp-evalserver-timeout)
229: (setq i (+ i 1))))
230: (if (null fi::lisp-evalserver-response)
231: (error "timeout (%d secs) on response from lisp!"
232: fi:lisp-evalserver-timeout))
233: (condition-case ()
234: (car (read-from-string fi::lisp-evalserver-returns))
235: (error (error "parse error: %s" fi::lisp-evalserver-returns))))
236:
237: ;;;;
238: ;;; Internals
239: ;;;;
240:
241: (defconst fi::lisp-evalserver-read-eval-loop
242: "(progn
243: (setf (getf (mp:process-property-list mp:*current-process*)
244: ':no-interrupts)
245: t)
246: (setq tpl::*prompt* \"\")
247: (loop (errorset (princ (with-output-to-string (*standard-output*)
248: (princ \"&\")
249: (prin1 (eval (read)))
250: (princ \"\")))
251: t)))\n")
252:
253: (defvar fi::lisp-evalserver-process nil)
254:
255: (defun fi::lisp-evalserver-process ()
256: (if (or (null fi::lisp-evalserver-process)
257: (not (eq (process-status fi::lisp-evalserver-process) 'open)))
258: (progn
259: (and fi::lisp-evalserver-process
260: (delete-process fi::lisp-evalserver-process))
261: (setq fi::lisp-evalserver-process
262: (condition-case ()
263: (if fi:unix-domain
264: (open-network-stream "lisp-evalserver" nil
265: (expand-file-name fi:unix-domain-socket)
266: 0)
267: (open-network-stream "lisp-evalserver" nil fi:local-host-name
268: fi:excl-service-name))
269: (error nil)))
270: (if fi::lisp-evalserver-process
271: (progn
272: (setq fi::sublisp-returns-state nil)
273: (process-send-string ; first send the process name
274: fi::lisp-evalserver-process
275: (format "\"%s\"" "Lisp Eval Server"))
276: (process-send-string fi::lisp-evalserver-process
277: fi::lisp-evalserver-read-eval-loop)
278: ;; wait for the prompt
279: (accept-process-output fi::lisp-evalserver-process)
280: (set-process-filter fi::lisp-evalserver-process
281: 'fi::lisp-evalserver-filter)))))
282: fi::lisp-evalserver-process)
283:
284: (defconst fi::lisp-evalserver-returns "")
285: (defconst fi::lisp-evalserver-response nil)
286: (defconst fi::lisp-evalserver-counter 0)
287: (defconst fi::lisp-evalserver-collecting nil)
288:
289: (defun fi::lisp-evalserver-filter (proc string)
290: (setq fi::lisp-evalserver-counter (+ 1 fi::lisp-evalserver-counter))
291: (let ((len (length string)))
292: (cond
293: ((> len 0)
294: (if (/= (elt string 0) ?&)
295: (setq string (concat fi::lisp-evalserver-returns string)))
296:
297: (setq len (length string))
298: (if (and (= (elt string 0) ?&)
299: (= (elt string (- len 1)) ?))
300: (setq fi::lisp-evalserver-returns (substring string 1 (- len 1))
301: fi::lisp-evalserver-collecting nil
302: fi::lisp-evalserver-response t)
303: (setq fi::lisp-evalserver-returns string
304: fi::lisp-evalserver-collecting t))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.