cgit.sxemacs.org Git - packages/blob - xemacs-packages/tooltalk/tooltalk-init.el

   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 debugger
 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 \f
 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