src/lsp/dde.lsp

   1 ;;;;
   2 ;;;; DDE Support for XLISP-STAT
   3 ;;;; Copyright (c) 1999, by Luke Tierney
   4 ;;;; You may give out copies of this software; for conditions see the file
   5 ;;;; COPYING included with this distribution.
   6 ;;;;
   7
   8 (in-package "SYSTEM")
   9
  10 ;;;;
  11 ;;;; Client Functions
  12 ;;;;
  13
  14 (export '(dde-request dde-poke dde-execute))
  15
  16 (defun dde-execute (con cmd &key timeout)
  17   (if timeout
  18       (dde-client-transaction con :data cmd :timeout timeout)
  19     (dde-client-transaction con :data cmd)))
  20
  21 (defun dde-request (con item &key binary timeout)
  22   (if timeout
  23       (dde-client-transaction con :type :request :item item :binary binary
  24                               :timeout timeout)
  25     (dde-client-transaction con :type :request :item item :binary binary)))
  26
  27 (defun dde-poke (con item value &key timeout)
  28   (let ((vstring (if (stringp value) value (format nil "~s" value))))
  29     (if timeout
  30         (dde-client-transaction con :type :poke :item item :data vstring
  31                                 :timeout timeout)
  32       (dde-client-transaction con :type :poke :item item :data vstring))))
  33
  34 ;;**** A little example:
  35 (defun dde-eval (e)
  36   (let* ((c (dde-connect "XLISP-STAT"))
  37          (success (if c (dde-execute c (format nil "~s" e)) nil))
  38          (v (if success (dde-request c "value") nil)))
  39     (when c (dde-disconnect c))
  40     (if success
  41         (read-from-string v)
  42       (error "evaluation failed"))))
  43
  44
  45 ;;;;
  46 ;;;; Server Support
  47 ;;;;
  48
  49 (defconstant *dde-servers* (make-hash-table :test 'equal))
  50 (defconstant *dde-conversations* (make-hash-table))
  51 (defparameter *dde-debug* nil)
  52
  53 ;;**** need to be able to remove service too
  54 (defun dde-add-server (server)
  55   (let ((service (string-upcase (send server :name)))
  56         (old (gethash service *dde-servers*)))
  57     (when (or old (dde-name-service service))
  58       (setf (gethash service *dde-servers*) server)
  59       t)))
  60
  61 (defun dde-find-server (name)
  62   (values (gethash (string-upcase name) *dde-servers*)))
  63
  64 ;;**** could use a convention about getting back error info from executes
  65 (defun dde-server-callback (type fmt hconv hsz1 hsz2 data dw1 dw1)
  66   (dde-debug "Server args: ~s~%" (list type fmt hconv hsz1 hsz2 data dw1 dw1))
  67   (ignore-errors
  68    (case type
  69          (:connect
  70           (let ((server (gethash hsz2 *dde-servers*)))
  71             (and server (send server :has-topic hsz1))))
  72          (:connect-confirm
  73           (let* ((server (gethash hsz2 *dde-servers*))
  74                  (conv (send server :make-conversation hsz1)))
  75             (setf (gethash hconv *dde-conversations*) conv)))
  76          (:wildconnect
  77           (let ((val nil))
  78             (flet ((servs (servname server)
  79                           (let ((topics (send server :topics)))
  80                             (dolist (topic topics)
  81                                     (push (list servname topic) val)))))
  82                   (maphash #'servs *dde-servers*)
  83                   val)))
  84          (t (let ((conv (gethash hconv *dde-conversations*)))
  85               (case type
  86                     (:execute (send conv :execute data))
  87                     (:request (send conv :request hsz2))
  88                     (:poke (send conv :poke hsz2 data))
  89                     (:disconnect
  90                      (remhash hconv *dde-conversations*)
  91                      (send conv :disconnect))))))))
  92
  93 (defun dde-debug (fmt &rest args)
  94   (when *dde-debug* (apply #'format *debug-io* fmt args)))
  95
  96
  97 ;;;;
  98 ;;;; Standard Server
  99 ;;;;
 100
 101 (defproto dde-server-proto '(name topics))
 102
 103 (defmeth dde-server-proto :isnew (name)
 104  (setf (slot-value 'name) name))
 105
 106 (defmeth dde-server-proto :name () (slot-value 'name))
 107 (defmeth dde-server-proto :has-topic (topic)
 108   (if (assoc topic (slot-value 'topics) :test #'equal) t nil))
 109
 110 (defmeth dde-server-proto :topics ()
 111   (mapcar #'first (slot-value 'topics)))
 112
 113 (defmeth dde-server-proto :add-topic (topic factory)
 114   (let* ((topic (string-upcase topic))
 115          (entry (assoc topic (slot-value 'topics) :test #'equal)))
 116     (if entry
 117         (setf (second entry) factory)
 118       (push (list topic factory) (slot-value 'topics)))))
 119
 120 (defmeth dde-server-proto :make-conversation (topic)
 121   (let ((confac (second (assoc topic (slot-value 'topics) :test #'equal))))
 122     (if (objectp confac)
 123         (send confac :new self topic)
 124       (funcall confac self topic))))
 125
 126
 127 ;;;;
 128 ;;;; Standard Conversation
 129 ;;;;
 130
 131 (defproto dde-conversation-proto '(server topic value))
 132
 133 (defmeth dde-conversation-proto :isnew (server topic)
 134   (setf (slot-value 'server) server)
 135   (setf (slot-value 'topic) topic))
 136
 137 ;; Using the following modified readtable allows commands to be
 138 ;; enclosed in [...].  This seems to be necessary to properly handle
 139 ;; execute transactions sent by Excel.
 140 (defconstant *dde-readtable* (copy-readtable nil))
 141 (set-macro-character #\[ #'(lambda (x y) (values)) t *dde-readtable*)
 142 (set-macro-character #\] #'(lambda (x y) (values)) t *dde-readtable*)
 143
 144 (defmeth dde-conversation-proto :execute (cmd)
 145   (let ((*readtable* *dde-readtable*)
 146         (eof (cons nil nil)))
 147     (with-input-from-string (s cmd)
 148       (do ((expr (read s nil eof) (read s nil eof)))
 149           ((eq expr eof))
 150           (setf (slot-value 'value) (eval expr))))
 151     t))
 152
 153 (defmeth dde-conversation-proto :request (item)
 154   (when (equal item "VALUE")
 155     (format nil "~s" (slot-value 'value))))
 156
 157 (defmeth dde-conversation-proto :poke (item data) nil)
 158
 159 (defmeth dde-conversation-proto :disconnect () nil)
 160
 161
 162 ;;;;
 163 ;;;; Initialize the Standard Server
 164 ;;;;
 165
 166 (let ((server (send dde-server-proto :new "XLISP-STAT")))
 167  (send server :add-topic "XLISP-STAT" dde-conversation-proto)
 168  (send server :add-topic "SYSTEM" dde-conversation-proto)
 169  (setf (gethash "XLISP-STAT" system::*dde-servers*) server))
 170
 171
 172 ;;;;
 173 ;;;; Command Line Conversation Prototype
 174 ;;;;
 175
 176 (defproto cmdline-conversation-proto nil nil dde-conversation-proto)
 177
 178 ;;**** get this internally?
 179 (defconstant *banner*
 180   (format nil "XLISP-PLUS version 3.04~%~
 181                Portions Copyright (c) 1988, by David Betz.~%~
 182                Modified by Thomas Almy and others.~%~
 183                XLISP-STAT Release ~d.~d.~d.~%~
 184                Copyright (c) 1989-1999, by Luke Tierney.~%"
 185           xls-major-release
 186           xls-minor-release
 187           xls-subminor-release))
 188
 189 (defmeth cmdline-conversation-proto :isnew (server topic)
 190   (call-next-method server topic)
 191   (setf (slot-value 'value)
 192         (format nil "~a~%~a" *banner* (make-prompt-string))))
 193
 194 (defun make-prompt-string ()
 195   (if (eq (find-package "USER") *package*)
 196       "> "
 197     (format nil "~a> " (package-name *package*))))
 198
 199 (defun read-eval-print-from-string (string)
 200   (with-input-from-string (*standard-input* string)
 201     (with-output-to-string (*standard-output*)
 202       (let ((*debug-io* *standard-output*))
 203         (let ((eof (cons nil nil)))
 204           (do ((expr (read *standard-input* nil eof)
 205                      (read *standard-input* nil eof)))
 206               ((eq expr eof))
 207               (setf +++ ++ ++ + + - - expr)
 208               (multiple-value-bind (values error)
 209                                    (ignore-errors
 210                                     (multiple-value-list (eval expr)))
 211                 (cond
 212                  (error (format t "~&Error: ~a~%" error))
 213                  (t (setf *** ** ** * * (first values))
 214                     (format t "~{~&~s~%~}" values))))
 215               (format t "~&~a" (make-prompt-string))))))))
 216
 217 (defmeth cmdline-conversation-proto :execute (cmd)
 218   (setf (slot-value 'value) (read-eval-print-from-string cmd)))
 219
 220 (defmeth cmdline-conversation-proto :request (item)
 221   (when (equal item "VALUE")
 222     (let ((value (slot-value 'value)))
 223       (setf (slot-value 'value) "")
 224       value)))
 225
 226
 227 ;;;;
 228 ;;;; Add Command Line Handler to Server
 229 ;;;;
 230
 231 (send (dde-find-server "XLISP-STAT")
 232       :add-topic "CMDLINE" cmdline-conversation-proto)