|
0
|
1 ;;; -*- Mode: Emacs-Lisp -*-
|
|
|
2 ;;;
|
|
|
3 ;;; Registration of the default Tooltalk patterns and handlers.
|
|
|
4 ;;;
|
|
|
5 ;;; @(#)tooltalk-init.el 1.8 94/02/22
|
|
|
6
|
|
|
7
|
|
|
8 (defvar tooltalk-eval-pattern
|
|
|
9 '(category TT_HANDLE
|
|
|
10 scope TT_SESSION
|
|
|
11 op "emacs-eval"
|
|
|
12 callback tooltalk-eval-handler))
|
|
|
13
|
|
|
14 (defvar tooltalk-load-file-pattern
|
|
|
15 '(category TT_HANDLE
|
|
|
16 scope TT_SESSION
|
|
|
17 op "emacs-load-file"
|
|
|
18 args ((TT_IN "file" "string"))
|
|
|
19 callback tooltalk-load-file-handler))
|
|
|
20
|
|
|
21 (defvar tooltalk-make-client-frame-pattern
|
|
|
22 '(category TT_HANDLE
|
|
|
23 scope TT_SESSION
|
|
|
24 op "emacs-make-client-screen"
|
|
|
25 callback tooltalk-make-client-frame-handler))
|
|
|
26
|
|
|
27 (defvar tooltalk-status-pattern
|
|
|
28 '(category TT_HANDLE
|
|
|
29 scope TT_SESSION
|
|
|
30 op "emacs-status"
|
|
|
31 callback tooltalk-status-handler))
|
|
|
32
|
|
|
33
|
|
|
34 (defvar initial-tooltalk-patterns ())
|
|
|
35
|
|
|
36 (defun dispatch-initial-tooltalk-message (m)
|
|
|
37 (let ((op (get-tooltalk-message-attribute m 'op))
|
|
|
38 (patterns initial-tooltalk-patterns))
|
|
|
39 (if (stringp op)
|
|
|
40 (while patterns
|
|
|
41 (let ((p (car patterns)))
|
|
|
42 (if (eq (intern op) (tooltalk-pattern-prop-get p 'opsym))
|
|
|
43 (let ((callback (tooltalk-pattern-prop-get p 'callback)))
|
|
|
44 (if callback (funcall callback m p))
|
|
|
45 (setq patterns '()))
|
|
|
46 (setq patterns (cdr patterns))))))))
|
|
|
47
|
|
|
48 (defun make-initial-tooltalk-pattern (args)
|
|
|
49 (let ((opcdr (cdr (memq 'op args)))
|
|
|
50 (cbcdr (cdr (memq 'callback args))))
|
|
|
51 (if (and (consp opcdr) (consp cbcdr))
|
|
|
52 (let ((plist (list 'opsym (intern (car opcdr)) 'callback (car cbcdr))))
|
|
|
53 (make-tooltalk-pattern (append args (list 'plist plist))))
|
|
|
54 (make-tooltalk-pattern args))))
|
|
|
55
|
|
|
56 (defun register-initial-tooltalk-patterns ()
|
|
|
57 (mapcar #'register-tooltalk-pattern
|
|
|
58 (setq initial-tooltalk-patterns
|
|
|
59 (mapcar #'make-initial-tooltalk-pattern
|
|
|
60 (list tooltalk-eval-pattern
|
|
|
61 tooltalk-load-file-pattern
|
|
|
62 tooltalk-make-client-frame-pattern
|
|
|
63 tooltalk-status-pattern))))
|
|
|
64 (add-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
|
|
|
65
|
|
|
66
|
|
|
67 (defun unregister-initial-tooltalk-patterns ()
|
|
|
68 (mapcar 'destroy-tooltalk-pattern initial-tooltalk-patterns)
|
|
|
69 (setq initial-tooltalk-patterns ())
|
|
|
70 (remove-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
|
|
|
71
|
|
|
72
|
|
|
73 (defun tooltalk:prin1-to-string (form)
|
|
|
74 "Like prin1-to-string except: if the string contains embedded nulls (unlikely
|
|
|
75 but possible) then replace each one with \"\\000\"."
|
|
|
76 (let ((string (prin1-to-string form)))
|
|
|
77 (let ((parts '())
|
|
|
78 index)
|
|
|
79 (while (setq index (string-match "\0" string))
|
|
|
80 (setq parts
|
|
|
81 (apply 'list "\\000" (substring string 0 index) parts))
|
|
|
82 (setq string (substring string (1+ index))))
|
|
|
83 (if (not parts)
|
|
|
84 string
|
|
|
85 (setq parts (apply 'list string parts))
|
|
|
86 (apply 'concat (nreverse parts))))))
|
|
|
87
|
|
|
88 ;; Backwards compatibility
|
|
|
89 (fset 'tooltalk::prin1-to-string-carefully 'tooltalk:prin1-to-string)
|
|
|
90
|
|
|
91
|
|
|
92 (defun tooltalk:read-from-string (str)
|
|
|
93 "Like read-from-string except: an error is signalled if the entire
|
|
|
94 string can't be parsed."
|
|
|
95 (let ((res (read-from-string str)))
|
|
|
96 (if (< (cdr res) (length str))
|
|
|
97 (error "Parse of input string ended prematurely."
|
|
|
98 str))
|
|
|
99 (car res)))
|
|
|
100
|
|
|
101
|
|
|
102 (defun tooltalk::eval-string (str)
|
|
|
103 (let ((result (eval (car (read-from-string str)))))
|
|
|
104 (tooltalk:prin1-to-string result)))
|
|
|
105
|
|
|
106
|
|
|
107 (defun tooltalk-eval-handler (msg pat)
|
|
|
108 (let ((str (get-tooltalk-message-attribute msg 'arg_val 0))
|
|
|
109 (result-str nil)
|
|
|
110 (failp t))
|
|
|
111 (unwind-protect
|
|
|
112 (cond
|
|
|
113 ;; Assume That the emacs debugger will handle errors.
|
|
|
114 ;; If the user throws from the debugger to the cleanup
|
|
|
115 ;; form below, failp will remain t.
|
|
|
116 (debug-on-error
|
|
|
117 (setq result-str (tooltalk::eval-string str)
|
|
|
118 failp nil))
|
|
|
119
|
|
|
120 ;; If an error occurs as a result of evaluating
|
|
|
121 ;; the string or printing the result, then we'll return
|
|
|
122 ;; a string version of error-info.
|
|
|
123 (t
|
|
|
124 (condition-case error-info
|
|
|
125 (setq result-str (tooltalk::eval-string str)
|
|
|
126 failp nil)
|
|
|
127 (error
|
|
|
128 (let ((error-str (tooltalk:prin1-to-string error-info)))
|
|
|
129 (setq result-str error-str
|
|
|
130 failp t))))))
|
|
|
131
|
|
|
132 ;; If we get to this point and result-str is still nil, the
|
|
|
133 ;; user must have thrown out of the debuggger
|
|
|
134 (let ((reply-type (if failp 'fail 'reply))
|
|
|
135 (reply-value (or result-str "(debugger exit)")))
|
|
|
136 (set-tooltalk-message-attribute reply-value msg 'arg_val 0)
|
|
|
137 (return-tooltalk-message msg reply-type)))))
|
|
|
138
|
|
|
139
|
|
|
140 (defun tooltalk-make-client-frame-handler (m p)
|
|
|
141 (let ((nargs (get-tooltalk-message-attribute m 'args_count)))
|
|
|
142 (if (not (= 3 nargs))
|
|
|
143 (progn
|
|
|
144 (set-tooltalk-message-attribute "wrong number of arguments" m 'status_string)
|
|
|
145 (return-tooltalk-message m 'fail))))
|
|
|
146
|
|
|
147 ;; Note: relying on the fact that arg_ival is returned as a string
|
|
|
148
|
|
|
149 (let* ((name (get-tooltalk-message-attribute m 'arg_val 0))
|
|
|
150 (window (get-tooltalk-message-attribute m 'arg_ival 1))
|
|
|
151 (args (list (cons 'name name) (cons 'window-id window)))
|
|
|
152 (frame (make-frame args)))
|
|
|
153 (set-tooltalk-message-attribute (frame-name frame) m 'arg_val 2)
|
|
|
154 (return-tooltalk-message m 'reply)))
|
|
|
155
|
|
|
156
|
|
|
157
|
|
|
158 (defun tooltalk-load-file-handler (m p)
|
|
|
159 (let ((path (get-tooltalk-message-attribute m 'file)))
|
|
|
160 (condition-case error-info
|
|
|
161 (progn
|
|
|
162 (load-file path)
|
|
|
163 (return-tooltalk-message m 'reply))
|
|
|
164 (error
|
|
|
165 (let ((error-string (tooltalk:prin1-to-string error-info)))
|
|
|
166 (set-tooltalk-message-attribute error-string m 'status_string)
|
|
|
167 (return-tooltalk-message m 'fail))))))
|
|
|
168
|
|
|
169
|
|
|
170 (defun tooltalk-status-handler (m p)
|
|
|
171 (return-tooltalk-message m 'reply))
|
|
|
172
|
|
|
173
|
|
|
174 ;; Hack the command-line.
|
|
|
175
|
|
|
176 (defun command-line-do-tooltalk (arg)
|
|
|
177 "Connect to the ToolTalk server."
|
|
|
178 ; (setq command-line-args-left
|
|
|
179 ; (cdr (tooltalk-open-connection (cons (car command-line-args)
|
|
|
180 ; command-line-args-left))))
|
|
|
181 (if (tooltalk-open-connection)
|
|
|
182 (register-initial-tooltalk-patterns)
|
|
|
183 (display-warning 'tooltalk "Warning: unable to connect to a ToolTalk server.")))
|
|
|
184
|
|
|
185 (setq command-switch-alist
|
|
|
186 (append command-switch-alist
|
|
|
187 '(("-tooltalk" . command-line-do-tooltalk))))
|
|
|
188
|
|
|
189 ;; Add some selection converters.
|
|
|
190
|
|
|
191 (defun xselect-convert-to-ttprocid (selection type value)
|
|
|
192 (let* ((msg (create-tooltalk-message))
|
|
|
193 (ttprocid (get-tooltalk-message-attribute msg 'sender)))
|
|
|
194 (destroy-tooltalk-message msg)
|
|
|
195 ttprocid
|
|
|
196 ))
|
|
|
197
|
|
|
198 (defun xselect-convert-to-ttsession (selection type value)
|
|
|
199 (let* ((msg (create-tooltalk-message))
|
|
|
200 (ttsession (get-tooltalk-message-attribute msg 'session)))
|
|
|
201 (destroy-tooltalk-message msg)
|
|
|
202 ttsession
|
|
|
203 ))
|
|
|
204
|
|
|
205 (if (boundp 'selection-converter-alist)
|
|
|
206 (setq selection-converter-alist
|
|
|
207 (append
|
|
|
208 selection-converter-alist
|
|
|
209 '((SPRO_PROCID . xselect-convert-to-ttprocid)
|
|
|
210 (SPRO_SESSION . xselect-convert-to-ttsession)
|
|
|
211 )))
|
|
|
212 (setq selection-converter-alist
|
|
|
213 '((SPRO_PROCID . xselect-convert-to-ttprocid)
|
|
|
214 (SPRO_SESSION . xselect-convert-to-ttsession))))
|
|
|
215
|
