![[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 |
BSD 4.3reno
;;
;; copyright (C) 1987, 1988 Franz Inc, Berkeley, Ca.
;;
;; The software, data and information contained herein are the property
;; of Franz, Inc.
;;
;; This file (or any derivation of it) may be distributed without
;; further permission from Franz Inc. as long as:
;;
;; * it is not part of a product for sale,
;; * no charge is made for the distribution, other than a tape
;; fee, and
;; * all copyright notices and this notice are preserved.
;;
;; If you have any comments or questions on this interface, please feel
;; free to contact Franz Inc. at
;; Franz Inc.
;; Attn: Kevin Layer
;; 1995 University Ave
;; Suite 275
;; Berkeley, CA 94704
;; (415) 548-3600
;; or
;; emacs-info%[email protected]
;; ucbvax!franz!emacs-info
;;
;; $Header: /var/lib/cvsd/repos/CSRG/43BSDReno/contrib/emacs-18.55/dist-1.3/fi/tcplisp.el,v 1.1.1.1 2018/04/24 16:12:57 root Exp $
;;
;; Description:
;; Implemented in this file are the backdoor lisp listener and lisp
;; evalserver.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;; The Backdoor Lisp Listener ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;; User Visibles
;;;;
(defvar fi:unix-domain t
"*If non-nil, then `fi:unix-domain-socket' specifies the name of the
socket file. It is recommended that this interface be used, and not
internet ports, because when internet ports are used only one process on a
machine may use this interface (it is a global resource). When using UNIX
domain sockets, communication is done through a socket file in the user's
home directory. But, if you really want to use internet ports, here are
the steps to take:
1. Set this variable to nil.
2. Add the following line to /etc/services:
excl 6789/tcp
3. Make sure `fi:local-host-name' is in /etc/hosts and points to the local
or loopback host.
4. On the Common Lisp side, put the following in you .clinit.cl file:
(setq ipc:*inet-port* 6789) ; the number from /etc/services
(setq ipc:*unix-domain* nil)
The problem with this, is that people can then use `telnet' to get a
listener on your lisp!")
(defvar fi:unix-domain-socket "~/.excl_to_emacs"
"*The name of the socket file that lisp and emacs use to communicate.
This is used when fi:unix-domain is non-nil.")
(defvar fi:local-host-name "localhost"
"*On 4.2 BSD the name of 127.1--usually localhost or loopback.
This is only used when fi:unix-domain is nil.")
(defvar fi:excl-service-name "excl"
"*The service name from /etc/services (`tcp' type). This is only used
when fi:unix-domain is nil.")
(defvar fi:source-info-not-found-hook 'find-tag
"*The value of this variable is funcalled when source information is not
present in Lisp for a symbol. The function is given one argument, the name
for which source is desired (a string). The null string means use the word
at the point as the search word. This allows the GNU Emacs tags facility
to be used when the information is not present in Lisp.")
;;;;
;;; Internals
;;;;
(defvar fi::lisp-macroexpand-command
"(progn
(errorset
(let ((*print-pretty* t)(excl::*print-nickname* t)(*package* %s))
(with-open-file (*standard-input* \"%s\")
(lisp:prin1 (%s (lisp:read)))))
t)
(values))\n")
(defvar fi::backdoor-process nil
"Process connected to sublist socket for fi:lisp-arglist and friends.")
(defvar fi::backdoor-read-eval-loop
"(progn
(setf (getf (mp:process-property-list mp:*current-process*)
':no-interrupts)
t)
(loop
(princ \"\n\")
(errorset (eval (read)) t)))\n"
"The program executed by the backdoor lisp listener.")
(defun fi:backdoor-eval (string &rest args)
"Evaluate apply format to STRING and ARGS and evaluate this in Common
Lisp at the other end of our socket."
(if (fi::background-sublisp-process)
(process-send-string
fi::backdoor-process
(format "(progn (format t \"\1\") %s)\n"
(apply 'format string args)))
(error "The backdoor listener to Lisp is not responding.")))
(defun fi::background-sublisp-process ()
(if (or (null fi::backdoor-process)
(not (eq (process-status fi::backdoor-process) 'open)))
(progn
(and fi::backdoor-process
(delete-process fi::backdoor-process))
(setq fi::backdoor-process
(condition-case ()
(if fi:unix-domain
(open-network-stream "lisp-backdoor" nil
(expand-file-name fi:unix-domain-socket)
0)
(open-network-stream "lisp-backdoor" nil fi:local-host-name
fi:excl-service-name))
(error nil)))
(if fi::backdoor-process
(progn
(setq fi::sublisp-returns-state nil)
(process-send-string ; first send the process name
fi::backdoor-process
(format "\"%s\"" "GNU Listener"))
(process-send-string fi::backdoor-process
fi::backdoor-read-eval-loop)
(set-process-filter fi::backdoor-process
'fi::backdoor-filter)))))
fi::backdoor-process)
;; This is the filter for the back door lisp process.
;; It collects output until it sees a ctl-A\n, then prints the preceding
;; collected text. If the text fits on one line, it is printed to the message
;; area. Otherwise it goes to a temporary pop up buffer.
(defvar fi::sublisp-returns "")
(defvar fi::sublisp-returns-state nil)
(defun fi::backdoor-filter (proc string)
;; This collects everything returned until a ^A\n prompt is seen,
;; then displays it. The first time is special cased to throw away
;; the initial prompt without display. Someday we should use the state
;; variable for detecting screwups and coordinating reset.
;; The \n is part of the prompt so that a subsequent prettyprint isn't
;; confused about the starting column.
;;
;; The first character has special meaning:
;; ^A toss the output from lisp after eval (for fi:backdoor-eval)
;; ^B for fi:lisp-find-tag
;; ^C for fi:lisp-find-tag-other-window
(setq fi::sublisp-returns (concat fi::sublisp-returns string))
(let ((len (length fi::sublisp-returns)))
(if (and (= 10 (aref fi::sublisp-returns (- len 1))); newline
(= 1 (aref fi::sublisp-returns (- len 2))))
(if (eq fi::sublisp-returns-state nil); ignore the startup response
(setq fi::sublisp-returns-state t
fi::sublisp-returns "")
(progn (setq fi::sublisp-returns
(substring fi::sublisp-returns
(progn (string-match "\n*" fi::sublisp-returns)
(match-end 0))
-2))
(let ((first-char (elt fi::sublisp-returns 0)))
(cond
((= first-char 1)
;;throw away the result
(setq fi::sublisp-returns ""))
((or (= first-char 2) (= first-char 3))
(fi::backdoor-find-tag-request (= first-char 3)))
(t
(if (or (> (length fi::sublisp-returns) 78)
;; should be mbuf width
(string-match "\n" fi::sublisp-returns nil))
(with-output-to-temp-buffer "*CL-Help*"
(princ fi::sublisp-returns))
(message fi::sublisp-returns))
(setq fi::sublisp-returns "")))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;; The Lisp Eval Server ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;; User Visibles
;;;;
(defconst fi:lisp-evalserver-timeout 5
"The time which fi:eval-in-lisp will wait before timing out and
signalling an error. Without a timeout Emacs would potentially be locked
out if Lisp did not `return' a result.")
(defconst fi:lisp-evalserver-number-reads 20
"The number of times the Lisp eval server tries to read from the
lisp-evalserver process before giving up. Without this feature Emacs would
hang if Lisp got into an infinite loop while printing. If the size of the
values returned to Emacs is large, then the value of this variable should
be increased.")
(defun fi:eval-in-lisp (string &rest args)
"Apply format (in Emacs) to STRING and ARGS and evaluate the result
in the Common Lisp to which we are connected. If a lisp-eval-server has
not been started, then this function starts it."
(if (not (fi::lisp-evalserver-process))
(error "The Lisp Eval Server is not responding."))
(setq fi::lisp-evalserver-response nil)
(setq fi::lisp-evalserver-returns "")
(process-send-string fi::lisp-evalserver-process
(format "%s\n" (apply 'format string args)))
(accept-process-output fi::lisp-evalserver-process
fi:lisp-evalserver-timeout)
(let ((i 0))
(while (and (< i fi:lisp-evalserver-number-reads)
fi::lisp-evalserver-collecting)
(accept-process-output fi::lisp-evalserver-process
fi:lisp-evalserver-timeout)
(setq i (+ i 1))))
(if (null fi::lisp-evalserver-response)
(error "timeout (%d secs) on response from lisp!"
fi:lisp-evalserver-timeout))
(condition-case ()
(car (read-from-string fi::lisp-evalserver-returns))
(error (error "parse error: %s" fi::lisp-evalserver-returns))))
;;;;
;;; Internals
;;;;
(defconst fi::lisp-evalserver-read-eval-loop
"(progn
(setf (getf (mp:process-property-list mp:*current-process*)
':no-interrupts)
t)
(setq tpl::*prompt* \"\")
(loop (errorset (princ (with-output-to-string (*standard-output*)
(princ \"\")
(prin1 (eval (read)))
(princ \"\")))
t)))\n")
(defvar fi::lisp-evalserver-process nil)
(defun fi::lisp-evalserver-process ()
(if (or (null fi::lisp-evalserver-process)
(not (eq (process-status fi::lisp-evalserver-process) 'open)))
(progn
(and fi::lisp-evalserver-process
(delete-process fi::lisp-evalserver-process))
(setq fi::lisp-evalserver-process
(condition-case ()
(if fi:unix-domain
(open-network-stream "lisp-evalserver" nil
(expand-file-name fi:unix-domain-socket)
0)
(open-network-stream "lisp-evalserver" nil fi:local-host-name
fi:excl-service-name))
(error nil)))
(if fi::lisp-evalserver-process
(progn
(setq fi::sublisp-returns-state nil)
(process-send-string ; first send the process name
fi::lisp-evalserver-process
(format "\"%s\"" "Lisp Eval Server"))
(process-send-string fi::lisp-evalserver-process
fi::lisp-evalserver-read-eval-loop)
;; wait for the prompt
(accept-process-output fi::lisp-evalserver-process)
(set-process-filter fi::lisp-evalserver-process
'fi::lisp-evalserver-filter)))))
fi::lisp-evalserver-process)
(defconst fi::lisp-evalserver-returns "")
(defconst fi::lisp-evalserver-response nil)
(defconst fi::lisp-evalserver-counter 0)
(defconst fi::lisp-evalserver-collecting nil)
(defun fi::lisp-evalserver-filter (proc string)
(setq fi::lisp-evalserver-counter (+ 1 fi::lisp-evalserver-counter))
(let ((len (length string)))
(cond
((> len 0)
(if (/= (elt string 0) ?)
(setq string (concat fi::lisp-evalserver-returns string)))
(setq len (length string))
(if (and (= (elt string 0) ?)
(= (elt string (- len 1)) ?))
(setq fi::lisp-evalserver-returns (substring string 1 (- len 1))
fi::lisp-evalserver-collecting nil
fi::lisp-evalserver-response t)
(setq fi::lisp-evalserver-returns string
fi::lisp-evalserver-collecting t))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.