Enhanced DDE Support for XLISP-STAT on Windows

Introduction

<dde.lsp>=
(in-package "SYSTEM")
(export '(dde-request dde-poke dde-execute))
<dde client functions>
<server support variables>
<server support functions>
<standard server objects>
<standard conversation objects>
<initializing the standard server>
<command line conversation objects>

DDE Client Functions

The function dde-execute taxes a connection identifier, a command string, and an optional timeout value as a keyword argument and performs an execute transaction.

<dde client functions>= (<-U) [D->]
(defun dde-execute (con cmd &key timeout)
  (if timeout
      (dde-client-transaction con :data cmd :timeout timeout)
    (dde-client-transaction con :data cmd)))

Defines dde-execute (links are to index).

The function dde-request takes a connection identifier and an item string and processes a request transaction. A timeout can be specified as a keyword argument. The :binary keyword can be used to indicate that the result should be a string of all the data transmitted; otherwise, the results consists of a string terminated by the first NULL character.

<dde client functions>+= (<-U) [<-D->]
(defun dde-request (con item &key binary timeout)
  (if timeout
      (dde-client-transaction con :type :request :item item :binary binary
                              :timeout timeout)
    (dde-client-transaction con :type :request :item item :binary binary)))

Defines dde-request (links are to index).

The function dde-poke takes a connection identifier, an item string, and a value string and executes a poke transaction. Again, a timeout can be specified with a keyword argument.

<dde client functions>+= (<-U) [<-D->]
(defun dde-poke (con item value &key timeout)
  (let ((vstring (if (stringp value) value (format nil "~s" value))))
    (if timeout
        (dde-client-transaction con :type :poke :item item :data vstring
                                :timeout timeout)
      (dde-client-transaction con :type :poke :item item :data vstring))))

Defines dde-poke (links are to index).

As a simple example, here is a function that does an eval using DDE:

<dde client functions>+= (<-U) [<-D]
(defun dde-eval (e)
  (let* ((c (dde-connect "XLISP-STAT"))
         (success (if c (dde-execute c (format nil "~s" e)) nil))
         (v (if success (dde-request c "value") nil)))
    (when c (dde-disconnect c))
    (if success
        (read-from-string v)
      (error "evaluation failed"))))

Defines dde-eval (links are to index).

A Customizable DDE Server

The Server Interface

• --:name. A string naming the service is returned.
• --:has-topic topic. Returns true if the topic named by the string topic is supported.
• --:make-conversation topic. Returns a new conversation object for the topic argument.
• --:topics. Returns a list of the topic names that are supported.

Connections are also assumed to be objects responding to certain messages:

• --:execute data. Handles an execute transaction with the provided data string. Should return nil on failure and true on success.
• --:request item. Return a string corresponding to the requested item or nil for failure.
• --:poke item data. Process a poke request with data for item. Should return nil on failure and true on success.
• --:disconnect. Called when the client disconnects; can be used for cleanup operations.

Server Support Functions

Hash Tables

<server support variables>= (<-U) [D->]
(defconstant *dde-servers* (make-hash-table :test 'equal))
(defconstant *dde-conversations* (make-hash-table))

Defines *dde-conversations*, *dde-servers* (links are to index).

Adding and Finding Servers

<server support functions>= (<-U) [D->]
;;**** need to be able to remove service too
(defun dde-add-server (server)
  (let ((service (string-upcase (send server :name)))
        (old (gethash service *dde-servers*)))
    (when (or old (dde-name-service service))
      (setf (gethash service *dde-servers*) server)
      t)))

Defines dde-add-server (links are to index).

The function dde-find-server looks up the server for the service name argument in the hash table.

<server support functions>+= (<-U) [<-D->]
(defun dde-find-server (name)
  (values (gethash (string-upcase name) *dde-servers*)))

Defines dde-find-server (links are to index).

The Server Callback Function

<server support functions>+= (<-U) [<-D->]
;;**** could use a convention about getting back error info from executes
(defun dde-server-callback (type fmt hconv hsz1 hsz2 data dw1 dw1)
  (dde-debug "Server args: ~s~%" (list type fmt hconv hsz1 hsz2 data dw1 dw1))
  (ignore-errors
   (case type
         (:connect
          <handle :connect request>)
         (:connect-confirm
          <handle :connect-confirm request>)
         (:wildconnect
          <handle :wildconnect request>)
         (t <handle conversation transaction>))))

Connect requests are handled by finding a server and asking the server whether it supports the specified topic.

<handle :connect request>= (<-U)
(let ((server (gethash hsz2 *dde-servers*)))
  (and server (send server :has-topic hsz1)))

Connect-confirm requests are received after a successful connect request. The server is asked to create the connection object, which is then registered under the connection handle.

<handle :connect-confirm request>= (<-U)
(let* ((server (gethash hsz2 *dde-servers*))
       (conv (send server :make-conversation hsz1)))
  (setf (gethash hconv *dde-conversations*) conv))

Wildconnect requests are used by the system to ask for information about supported services. Each server is asked for its list of topics, a list of service name-topic name lists is constructed and returned. The internal dde-services function can be used to query for available services.

<handle :wildconnect request>= (<-U)
(let ((val nil))
  (flet ((servs (servname server)
                (let ((topics (send server :topics)))
                  (dolist (topic topics)
                          (push (list servname topic) val)))))
        (maphash #'servs *dde-servers*)
        val))

Conversation transactions are handled by looking up the conversation object corresponding to the internal conversation handle and sending the object the appropriate message for handling the requested transaction.

<handle conversation transaction>= (<-U)
(let ((conv (gethash hconv *dde-conversations*)))
  (case type
        (:execute (send conv :execute data))
        (:request (send conv :request hsz2))
        (:poke (send conv :poke hsz2 data))
        (:disconnect
         (remhash hconv *dde-conversations*)
         (send conv :disconnect))))

When the variable *dde-debug* is not nil, the callback uses the dde-debug function to print its call information to debug output.

<server support variables>+= (<-U) [<-D]
(defparameter *dde-debug* nil)

Defines *dde-debug* (links are to index).

<server support functions>+= (<-U) [<-D]
(defun dde-debug (fmt &rest args)
  (when *dde-debug* (apply #'format *debug-io* fmt args)))

Defines dde-debug (links are to index).

Standard Server and Conversation Objects

The Standard Server

<standard server objects>= (<-U) [D->]
(defproto dde-server-proto '(name topics))

Defines dde-server-proto (links are to index).

The initialization method takes a service name argument and installs it in the name slot.

<standard server objects>+= (<-U) [<-D->]
(defmeth dde-server-proto :isnew (name)
 (setf (slot-value 'name) name))

Defines :isnew (links are to index).

The :name method returns the contents of the name slot.

<standard server objects>+= (<-U) [<-D->]
(defmeth dde-server-proto :name () (slot-value 'name))

Defines :name (links are to index).

The topics slot uses an association list to map topic names to conversation factories. The :has-topic method just checks whether the topic requested has an entry; the :topics method returns a list of the association keys. The :add-topic method adds a topic and its corresponding factory to the list.

<standard server objects>+= (<-U) [<-D->]
(defmeth dde-server-proto :has-topic (topic)
  (if (assoc topic (slot-value 'topics) :test #'equal) t nil))

(defmeth dde-server-proto :topics ()
  (mapcar #'first (slot-value 'topics)))

(defmeth dde-server-proto :add-topic (topic factory)
  (let* ((topic (string-upcase topic))
         (entry (assoc topic (slot-value 'topics) :test #'equal)))
    (if entry
        (setf (second entry) factory)
      (push (list topic factory) (slot-value 'topics)))))

Defines :add-topic, :has-topic, :topics (links are to index).

The :make-conversation method looks up the topic's conversation factory and uses it to construct a conversation. If the factory is a prototype, then it is sent the :new message with the server and the topic as arguments. If it is a function, it is called with those arguments.

<standard server objects>+= (<-U) [<-D]
(defmeth dde-server-proto :make-conversation (topic)
  (let ((confac (second (assoc topic (slot-value 'topics) :test #'equal))))
    (if (objectp confac)
        (send confac :new self topic)
      (funcall confac self topic))))

Standard Conversations

<standard conversation objects>= (<-U) [D->]
(defproto dde-conversation-proto '(server topic value))

Defines dde-conversation-proto (links are to index).

The initialization method installs the server and the topic names in their respective slots.

<standard conversation objects>+= (<-U) [<-D->]
(defmeth dde-conversation-proto :isnew (server topic)
  (setf (slot-value 'server) server)
  (setf (slot-value 'topic) topic))

Defines :isnew (links are to index).

The :execute method treats its argument as a sequence of Lisp expressions in a string. The expressions are evaluated and their results are stored in the value slot for retrieval by a subsequent request transaction. Some clients---Excel in particular---seem to assume that execute expressions will be enclosed in square brackets. Following a suggestion of Russell Lenth, to allow this, the :execute method uses a read table in which the right and left square brackets are ignored.

<standard conversation objects>+= (<-U) [<-D->]
;; Using the following modified readtable allows commands to be
;; enclosed in [...].  This seems to be necessary to properly handle
;; execute transactions sent by Excel.
(defconstant *dde-readtable* (copy-readtable nil))
(set-macro-character #\[ #'(lambda (x y) (values)) t *dde-readtable*)
(set-macro-character #\] #'(lambda (x y) (values)) t *dde-readtable*)

(defmeth dde-conversation-proto :execute (cmd)
  (let ((*readtable* *dde-readtable*)
        (eof (cons nil nil)))
    (with-input-from-string (s cmd)
      (do ((expr (read s nil eof) (read s nil eof)))
          ((eq expr eof))
          (setf (slot-value 'value) (eval expr))))
    t))

Defines *dde-readtable*, :execute (links are to index).

The standard conversation responds to requests for the VALUE item by returning the contents of its value slot formatted as a string with prin1 formatting.

<standard conversation objects>+= (<-U) [<-D->]
(defmeth dde-conversation-proto :request (item)
  (when (equal item "VALUE")
    (format nil "~s" (slot-value 'value))))

Defines :request (links are to index).

The standard conversation does not accept poke requests and does not do any cleanup on disconnects.

<standard conversation objects>+= (<-U) [<-D]
(defmeth dde-conversation-proto :poke (item data) nil)
(defmeth dde-conversation-proto :disconnect () nil)

Initializing the Standard Server

<initializing the standard server>= (<-U)
(let ((server (send dde-server-proto :new "XLISP-STAT")))
 (send server :add-topic "XLISP-STAT" dde-conversation-proto)
 (send server :add-topic "SYSTEM" dde-conversation-proto)
 (setf (gethash "XLISP-STAT" system::*dde-servers*) server))

Command Line Conversation Objects

Creation and Initialization

<command line conversation objects>= (<-U) [D->]
(defproto cmdline-conversation-proto nil nil dde-conversation-proto)

Defines cmdline-conversation-proto (links are to index).

The initialization method uses the banner

<command line conversation objects>+= (<-U) [<-D->]
;;**** get this internally?
(defconstant *banner*
  (format nil "XLISP-PLUS version 3.04~%~
               Portions Copyright (c) 1988, by David Betz.~%~
               Modified by Thomas Almy and others.~%~
               XLISP-STAT Release ~d.~d.~d.~%~
               Copyright (c) 1989-1999, by Luke Tierney.~%"
          xls-major-release
          xls-minor-release
          xls-subminor-release))

Defines *banner* (links are to index).

and installs it in the value slot for retrieval by the first request for the VALUE item. The banner is followed by an initial prompt.

<command line conversation objects>+= (<-U) [<-D->]
(defmeth cmdline-conversation-proto :isnew (server topic)
  (call-next-method server topic)
  (setf (slot-value 'value)
        (format nil "~a~%~a" *banner* (make-prompt-string))))

Defines :isnew (links are to index).

The prompt is constructed by

<command line conversation objects>+= (<-U) [<-D->]
(defun make-prompt-string ()
  (if (eq (find-package "USER") *package*)
      "> "
    (format nil "~a> " (package-name *package*))))

Defines make-prompt-string (links are to index).

Processing Commands

<command line conversation objects>+= (<-U) [<-D->]
(defun read-eval-print-from-string (string)
  (with-input-from-string (*standard-input* string)
    (with-output-to-string (*standard-output*)
      (let ((*debug-io* *standard-output*))
        <command line read-eval-print loop>))))

Defines read-eval-print-from-string (links are to index).

The read-eval-print loop reads commands, evaluates with a check for errors, prints the values or the error condition, and finally prints a prompt. The loop continues until the end of string results in an end of file on the stream.

<command line read-eval-print loop>= (<-U)
(let ((eof (cons nil nil)))
  (do ((expr (read *standard-input* nil eof)
             (read *standard-input* nil eof)))
      ((eq expr eof))
      (setf +++ ++ ++ + + - - expr)
      (multiple-value-bind (values error)
                           (ignore-errors
                            (multiple-value-list (eval expr)))
        (cond
         (error (format t "~&Error: ~a~%" error))
         (t (setf *** ** ** * * (first values))
            (format t "~{~&~s~%~}" values))))
      (format t "~&~a" (make-prompt-string))))

The conversation :execute method is then simply

<command line conversation objects>+= (<-U) [<-D->]
(defmeth cmdline-conversation-proto :execute (cmd)
  (setf (slot-value 'value) (read-eval-print-from-string cmd)))

Defines :execute (links are to index).

The :request method returns the string in the value slot and sets the value slot to the empty string (**** is this still necessary?).

<command line conversation objects>+= (<-U) [<-D->]
(defmeth cmdline-conversation-proto :request (item)
  (when (equal item "VALUE")
    (let ((value (slot-value 'value)))
      (setf (slot-value 'value) "")
      value)))

Defines :request (links are to index).

Installing the CMDLINE Topic Handler

<command line conversation objects>+= (<-U) [<-D]
(send (dde-find-server "XLISP-STAT")
      :add-topic "CMDLINE" cmdline-conversation-proto)

References

Indices

Chunks

• <command line conversation objects>: U1, D2, D3, D4, D5, D6, D7, D8, D9
• <command line read-eval-print loop>: U1, D2
• <dde client functions>: U1, D2, D3, D4, D5
• <dde.lsp>: D1
• <handle :connect request>: U1, D2
• <handle :connect-confirm request>: U1, D2
• <handle conversation transaction>: U1, D2
• <handle :wildconnect request>: U1, D2
• <initializing the standard server>: U1, D2
• <server support functions>: U1, D2, D3, D4, D5
• <server support variables>: U1, D2, D3
• <standard conversation objects>: U1, D2, D3, D4, D5, D6
• <standard server objects>: U1, D2, D3, D4, D5, D6

Identifiers

• :add-topic: D1, U2, U3
• *banner*: D1, U2
• cmdline-conversation-proto: D1, U2, U3, U4, U5
• dde-add-server: D1
• dde-conversation-proto: D1, U2, U3, U4, U5, U6, U7
• *dde-conversations*: D1, U2, U3
• *dde-debug*: D1, U2
• dde-debug: U1, U2, D3
• dde-eval: D1
• dde-execute: U1, D2, U3
• dde-find-server: D1, U2
• dde-poke: U1, D2
• *dde-readtable*: D1
• dde-request: U1, D2, U3
• dde-server-proto: D1, U2, U3, U4, U5, U6
• *dde-servers*: D1, U2, U3, U4, U5, U6
• :execute: U1, D2, D3
• :has-topic: U1, D2
• :isnew: D1, D2, D3
• make-prompt-string: U1, D2, U3
• :name: U1, D2
• read-eval-print-from-string: D1, U2
• :request: U1, U2, D3, D4
• :topics: U1, D2