Mercurial > hg > xemacs-beta

comparison lisp/tooltalk/tooltalk-init.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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