| allegro-cl archives 1996-9-10 | home index prev H thread prev K thread next J next L |
|
From: tom (Tom McClure) Subject: Re: [pcspr3863] Allegro and Netscape via DDE Date: 1996-9-10 16:47
Steven--
You wrote:
I tried the code for t.poke and receive-value, but got no
results. This works perhaps for transaction type XTYP_POKE, but I need
to do a XTYP_REQUEST and therefore the code for t.request ...
I know, that you won't support the dde-methods, and maybe it is the
best, when you send me the whole code of the dde implementation...
Enclosed please find the DDE code in its entirety.
-tom
Tom McClure - <franz.com at tomj> - Franz Inc., 1995 University Ave, Suite 275
(510) 548-3600, FAX 548-8253 - Berkeley, CA 94704-1072
ACL FAQs: www.franz.com/Support/ or ftp.franz.com/pub/*faq
**Please** cc <franz.com at pc-support> on all mail related to this matter.
Be sure to include tracking number [pcspr3863] in the subject line.
;; copyright (c) 1990-1996 Franz Inc, Berkeley, CA
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in
;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
;;
;;
;; >>> loader.lsp
;; loads the rest of the DDE source files
;; copyright (c) 1994 Franz Inc, Berkeley, CA
;; All rights reserved.
;;
;; Permission is granted only to any individual or institution which has
;; current Allegro CL license(s) to use, copy, or modify this software,
;; provided any reproduction or distribution of binary versions of this
;; software are compiled with a licensed Allegro CL, and provided
;; that this complete copyright and permission notice is maintained, intact,
;; in all copies and supporting documentation.
;;
;; Franz Incorporated provides this software "as is" without
;; express or implied warranty.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
(in-package :user)
(dolist (filename (list
"defpack.lsp"
"utils.lsp"
"main.lsp"
))
(print filename)
(load (namestring (merge-pathnames filename
*load-pathname*))
:verbose nil :print nil))
;; <<< loader.lsp
;; >>> defpack.lsp
;; define the package for the DDE facility
;; copyright (c) 1994 Franz Inc, Berkeley, CA
;; All rights reserved.
;;
;; Permission is granted only to any individual or institution which has
;; current Allegro CL license(s) to use, copy, or modify this software,
;; provided any reproduction or distribution of binary versions of this
;; software are compiled with a licensed Allegro CL, and provided
;; that this complete copyright and permission notice is maintained, intact,
;; in all copies and supporting documentation.
;;
;; Franz Incorporated provides this software "as is" without
;; express or implied warranty.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
(unless (find-package :dde)
(make-package :dde))
(in-package :dde)
(provide :dde)
(defpackage :dde
(:use :common-lisp :ct)
(:export
*server-active-p* *service-name*
*service-topics* *sysitems*
*active-server-ports*
*active-client-ports*
*case-sensitive-dde*
open-server close-server close-dde
client-port port-name
port-application port-topic
open-port close-port
port-open-p
send-request answer-request
send-command execute-command
send-value receive-value
post-advice receive-advice
list-to-tabbed-string
))
;; <<< defpack.lsp
;; >>> utils.lsp
;; miscellaneous utilities for use by the DDE facility
;; copyright (c) 1994 Franz Inc, Berkeley, CA
;; All rights reserved.
;;
;; Permission is granted only to any individual or institution which has
;; current Allegro CL license(s) to use, copy, or modify this software,
;; provided any reproduction or distribution of binary versions of this
;; software are compiled with a licensed Allegro CL, and provided
;; that this complete copyright and permission notice is maintained, intact,
;; in all copies and supporting documentation.
;;
;; Franz Incorporated provides this software "as is" without
;; express or implied warranty.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
;; Changelog
;; <1> cheetham 3/16/95
;; add an option for case-sensitive strings to see if that fixes the
;; problem in [pcspr2020]
;; <2> cheetham 6/30/95
;; make dde-warn go through the condition system, though we
;; lose the "DDE" prefix at the beginning of the message
;; <3> cheetham 3/14/96
;; default *case-sensitive-dde* to NIL rather than t, to solve the
;; problem where the OS always passes "SYSTEM" as "System". If a user
;; actually needs the case-sensitivity, they can set the variable.
;; Remember from [pcspr3263] that once a string handle is allocated
;; for "Foo", then string handles later allocated by the OS for "foo",
;; "FOO", or "foO" will be the same handle to "Foo"! So if an app
;; DOES require case-sensitivity, you have to hope that no one has
;; allocated a needed string in a different case! Also, the string
;; "System" is apparently already allocated in the string handle table
;; by the OS, and so even if someone sends us "SYSTEM"
;; or "system" what we get is always "System", and hence our server
;; topic "SYSTEM" cannot be connected to if our server is running with
;; *case-sensitive-dde* set to non-NIL!
(in-package :dde)
;; -----------------------------------------
;; variables and constants
;; ID for this lisp process
(defvar *app-id* nil)
;; The service-name that we establish for our server with open-server
(defvar *service-name* :allegro)
;; The allowed topics with which clients can connect to our server
;; A null list indicates that any topic is allowed
;; A NIL within the list indicates that the null string topic is allowed
(defparameter *service-topics* '(nil :system :eval))
(defparameter *sysitems* '(:sysitems :topics :help))
;; Whether we have established this lisp process as a DDE server
(defvar *server-active-p* nil)
(defvar *active-server-ports* nil)
(defvar *active-client-ports* nil)
(defparameter *null-string-handle*
(ct:callocate win:hsz :initial-value 0))
(defparameter null-character <) at #\Control->
(defparameter *buffer-size* 256)
(defparameter *buffer* (make-string *buffer-size*))
(defvar *dde-keys* nil)
(defparameter *initial-dde-keys*
'(:allegro :command-result :eval))
(defparameter *string-handle-to-symbol*
(make-hash-table :size 16))
(defconstant null-char-string (make-string 1
:initial-element (int-char 0)))
(defconstant crlf (format nil "~c~c" #\newline #\linefeed))
;; -------------------------------------------------
;; Automate the creation and management of "string handles" for each
;; application, topic, and item name. The user can simply pass
;; keyword symbols or strings for these, and one string handle
;; will be maintained and used for each one. If a string is used,
;; a keyword is still created for mapping from the lisp symbol to
;; the string handle via the symbol's plist. Mapping is done in
;; the other direction (from string handle to lisp keyword) via
;; a hash table.
(defparameter *case-sensitive-dde* nil ;; <1><3>
"Set this to t if you're using DDE with an application that requires case-sensitive strings. If NIL, the symbols that lisp uses for these strings may print more nicely")
(defmethod get-string-handle ((string string))
(get-string-handle (intern
(if *case-sensitive-dde* ;; <1>
string
(string-upcase string))
(symbol-package :start))))
(defmethod get-string-handle ((symbol symbol))
(or (getf (symbol-plist symbol) :string-handle)
(make-string-handle symbol)))
(defun make-string-handle (symbol)
(let ((string-handle
(win:ddecreatestringhandle
*app-id*
(if *case-sensitive-dde* ;; <1>
(symbol-name symbol)
(string-upcase (symbol-name symbol)))
win:cp_winansi))) ;; not unicode
(setf (get symbol :string-handle) string-handle)
(push symbol *dde-keys*)
(setf (gethash (handle-value win:hsz string-handle)
*string-handle-to-symbol*)
symbol)
string-handle))
(defun string-handle-to-symbol (string-handle)
(and (not (null-handle-p win:hsz string-handle))
(or (find-symbol-for-string-handle string-handle)
(make-symbol-for-string-handle string-handle))))
(defun find-symbol-for-string-handle (string-handle)
;; Find the symbol for string handle that we created
(gethash (handle-value win:hsz string-handle)
*string-handle-to-symbol*))
(defun make-symbol-for-string-handle (string-handle)
;; I guess this is needed only if we want the server to
;; report what strings clients are passing to it which the
;; server itself hasn't defined (as a server normally does
;; ahead of time)
(let* ((length (win:ddequerystring *app-id* string-handle
ct:hnull 0 win:cp_winansi))
(buffer (make-string length))
symbol)
(win:ddequerystring *app-id* string-handle buffer
(1+ length) win:cp_winansi)
(setq symbol (intern
(if *case-sensitive-dde* ;; <1>
buffer
(string-upcase buffer))
(symbol-package :start)))
(setf (gethash (handle-value win:hsz string-handle)
*string-handle-to-symbol*)
symbol)
symbol))
(defun release-string-handles ()
(let ((handle (ccallocate win:hsz)))
(maphash #'(lambda (string-handle-value symbol)
(setf (handle-value win:hsz handle)
string-handle-value)
(win:ddefreestringhandle *app-id* handle))
*string-handle-to-symbol*)
(clrhash *string-handle-to-symbol*)))
;; ------------------------------------
(defun hconv-to-server-port (hconv)
;; Find our lisp port object given its port handle
(if (null-handle-p win:hconv hconv)
nil
(dolist (c *active-server-ports* hconv)
(when (handle= win:hconv hconv (port-handle c))
(return c)))))
(defun hconv-to-client-port (hconv)
(if (null-handle-p win:hconv hconv)
nil
(dolist (c *active-client-ports* hconv)
(when (handle= win:hconv hconv (port-handle c))
(return c)))))
;; -----------------------------------
;; classes
(defclass dde-port ()
;; A DDE conversation
((name :initform nil
:initarg :name
:accessor port-name)
(topic :initform nil
:initarg :topic
:accessor port-topic)
(handle :initform nil
:initarg :handle
:accessor port-handle)
))
(defmethod object-name ((object dde-port))
(port-name object))
(defclass server-port (dde-port)
;; A conversation where this lisp is the DDE server
;; Allow the client to maintain a current package between commands
((package :initform *package*)
;; The value returned by the previous execute
(result :initform nil)
;; Items for which this port currently has
;; hot or warm links established
;; Apparently this is just for our general information, since
;; ddepostadvise will request data only where the links are
;; established anyway
(hot-links :initform nil
:accessor hot-links)
(warm-links :initform nil
:accessor warm-links)
))
(defclass client-port (dde-port)
;; A conversation where this lisp is the DDE client
((application :initform nil
:initarg :application
:accessor port-application)
))
(defmethod initialize-instance ((conv client-port)
&rest initargs)
(unless (getf initargs :name)
(setf (port-name conv)
(gensym-sequential-name :client)))
(call-next-method))
(defun port-open-p (port)
(port-handle port))
(defmethod print-object ((conv client-port) stream)
(if (port-open-p conv)
(format stream "#<Port ~a (Topic ~a of ~a)>"
(port-name conv)
(port-topic conv)
(port-application conv)
)
(format stream "#<CLOSED port ~a (Topic ~a of ~a)>"
(port-name conv)
(port-topic conv)
(port-application conv)
)))
(defmethod print-object ((conv server-port) stream)
(if (port-handle conv)
(format stream "#<port ~a (Topic ~a)>"
(port-name conv)
(port-topic conv)
)
(format stream "#<CLOSED port ~a>"
(port-name conv))))
;; -----------------------------------
;; Utility functions
(defun convert-returned-dde-string (string)
(if (position #\tab string)
(tabbed-string-to-list string)
(crlf-string-to-list string)))
#+acl3.0
(defun tabbed-string-to-list (string)
(delimited-string-to-list string #\tab))
#-acl3.0
(defun tabbed-string-to-list (string)
;; Separate items that are returned by DDE servers as
;; a string with TAB between successive items, such as Word for Windows
(do* ((s string (subseq s (1+ index)))
(index (position #\tab s)
(position #\tab s))
(list (list (subseq s 0 index))
(nconc list (list (subseq s 0 index)))))
((null index)
list)))
#+acl3.0
(defun list-to-tabbed-string (list)
(list-to-delimited-string list #\tab))
#-acl3.0
(defun list-to-tabbed-string (list)
(let ((format-string "~{~a~^x~}"))
(setf (elt format-string 6) #\tab) ;; must be a better way
(format nil format-string list)))
#+acl3.0
(defun crlf-string-to-list (string)
(delimited-string-to-list string crlf))
#-acl3.0
(defun crlf-string-to-list (string)
;; Separate items that are returned by DDE servers as
;; a string with CRLF between successive items, as Program Manager
(do* ((s string (subseq s (+ index 2)))
(index (search crlf s)
(search crlf s))
(list (list (subseq s 0 index))
(nconc list (list (subseq s 0 index)))))
((null index)
list)))
(defun dde-warning (format-string &rest format-args) ;; <2>
(apply #'warn format-string format-args))
#+old ;; 6/30/95
(defun dde-warning (format-string &rest format-args)
(apply #'format *error-output*
(concatenate 'string "~%;; DDE Warning: " format-string)
format-args))
(defun ensure-buffer-size (length)
(unless (> (length *buffer*) length)
(setq *buffer* (make-string
(setq *buffer-size* (1+ length))))))
(defun string-from-buffer (length)
(subseq *buffer* 0
(min length
(or (position null-character *buffer*)
most-positive-fixnum))))
;; <<< utils.lsp
;; >>> main.lsp
;; Generalized clossified DDE code
;; copyright (c) 1994 Franz Inc, Berkeley, CA
;; All rights reserved.
;;
;; Permission is granted only to any individual or institution which has
;; current Allegro CL license(s) to use, copy, or modify this software,
;; provided any reproduction or distribution of binary versions of this
;; software are compiled with a licensed Allegro CL, and provided
;; that this complete copyright and permission notice is maintained, intact,
;; in all copies and supporting documentation.
;;
;; Franz Incorporated provides this software "as is" without
;; express or implied warranty.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
;; Changelog
;; <1> cheetham 1/4/95
;; new code to handle DDEPoke on the client side with send-value
;; and the server side with receive value. Also combine the
;; calls to ddeclienttransaction into one place
;; <2> cheetham 3/14/96
;; where the callback function had returned t or NIL to messages from
;; a DDE client, instead return TRUE (1) or FALSE (0). I think that
;; t and NIL had actually been converted properly already (even though
;; the return value is not a boolean and is sometimes integers such
;; as win:dde_fack), but this makes it clearer exactly what is being
;; returned. I had thought that this may be the problem in [pcspr3263],
;; but that turned out to be a case-sensitivity problem.
(in-package :dde)
;; ------------------------------------------------------
;; Exported client functions
(defun open-port (port)
(ensure-dde-open)
(when (port-handle port)
(dde-warning "~a is already open" port)
(return-from open-port nil))
(let* ((application (port-application port))
(topic (port-topic port))
(application-handle (if application
(get-string-handle application)
*null-string-handle*))
(topic-handle (if topic
(get-string-handle topic)
*null-string-handle*))
(hconv (win:ddeconnect *app-id*
application-handle topic-handle ct:hnull))
error-code)
(cond ((null-handle-p win:hconv hconv)
(setq error-code (win:ddegetlasterror *app-id*))
(case error-code
(#.win:dmlerr_no_conv_established
(dde-warning "There is no application ~s running ~
that has a topic named ~s"
application topic))
(t
(error "DDE client connection failed to topic ~a of ~
application ~a. Error code = ~a"
topic application
;; ??? Interpret these error codes
error-code)))
nil)
(t
(setf (port-handle port) hconv)
(push port *active-client-ports*)
port))))
(defun close-port (client-port)
(let ((hconv (port-handle client-port)))
(cond (hconv
(win:ddedisconnect hconv)
(setf (port-handle client-port) nil)
(setq *active-client-ports*
(delete client-port
*active-client-ports*))
t)
(t
(dde-warning "Client ~a is already closed"
(port-name client-port))
nil))))
(defun send-command (client-port command-string &key (timeout 1000))
;; Does a DDE Execute
(client-transaction :command client-port nil command-string timeout))
(defun send-request (client-port item &key (link :cold)(timeout 1000))
;; Does a DDE Request (or starts or stops asking for Advice)
;; LINK can be one of (:cold :warm :hot :stop)
(let ((global-buffer-handle (client-transaction link client-port
item nil timeout))
length)
(cond ((and global-buffer-handle
(not (null-handle-p hconv global-buffer-handle)))
(setq length (win:ddegetdata global-buffer-handle ct:hnull 0 0))
(ensure-buffer-size length)
(win:ddegetdata global-buffer-handle *buffer* *buffer-size* 0)
(and (plusp length)
(convert-returned-dde-string (string-from-buffer length)))
)
(t
(lisp-warning "The DDE server did not respond the the ~
request for item ~s of topic ~s"
item (port-topic client-port))
nil))))
(defun send-value (client-port item value-string ;; <1>
&key (timeout 1000))
;; Does a DDE Poke
(let ((result (client-transaction :value client-port item
value-string timeout)))
(and (not (null-handle-p hconv result))
(handle-value hconv result))))
(defun client-transaction (transaction-type client-port item
string timeout)
(let* ((hconv (port-handle client-port))
(length 0)
(item-handle nil)
(result nil)
)
(cond ((and hconv
(not (null-handle-p hconv hconv)))
(when item
(setq item-handle (get-string-handle item)))
(when string
(setq length (length string))
(ensure-buffer-size length)
(setf (subseq *buffer* 0 length) string)
(setf (elt *buffer* length) null-character))
(setq result
(win:ddeclienttransaction
(if string *buffer* ct:hnull) ;; lpbData (the data)
(if string (1+ length) 0) ;; cbData (length of data)
hconv ;; conversation handle
(if item item-handle *null-string-handle*) ;; hszItem
;; uFmt (data format)
(if (eq transaction-type :command) 0 win:cf_text)
;; uType (type of transaction)
(case transaction-type
(:command win:xtyp_execute)
(:value win:xtyp_poke) ;; <1>
(:cold win:xtyp_request) ;; Four "request" types
(:hot win:xtyp_advstart)
(:warm (logior win:xtyp_advstart win:xtypf_nodata))
(:stop win:xtyp_advstop)
)
timeout ;; timeout in milliseconds
ct:hnull ;; ignore the return code
))
result)
(t
(dde-warning "Client port ~s is not open"
client-port)
nil))))
(defmethod receive-advice ((port dde-port) topic item
string)
;; Client receives advice from an earlier send-request with
;; a link type of :warm or :hot.
;; Define this method to receive intermittent updates.
t)
;; ------------------------------------------------------
;; Exported server functions
(defun open-server (&key (name *service-name*)
(topics *service-topics*))
;; Establish this lisp process as a DDE server. A client can connect
;; to us using the service name and topics established here
(ensure-dde-open)
(cond (*server-active-p*
(dde-warning "DDE Server is already active")
nil)
(t
(win:ddenameservice *app-id* (get-string-handle name)
*null-string-handle* win:dns_register)
(setq *service-name* name)
(setq *service-topics* topics)
(setq *server-active-p* t)
t)))
(defun close-server ()
(cond ((and *app-id* *server-active-p*)
(win:ddenameservice *app-id*
(get-string-handle *service-name*)
*null-string-handle* win:dns_unregister)
(setq *active-server-ports* nil)
(setq *server-active-p* nil)
t)
(t
(dde-warning "DDE server already closed")
nil)))
;; Modify this default method to do your own interpretation of a client
;; command, which is a string passed by a client issuing a DDE EXECUTE
(defmethod execute-command (topic command-string)
(format nil "No execute-command method supplied for topic ~s" topic))
;; For the special topic :eval, evaluate the command string as a
;; lisp form. Note that this won't work in a runtime lisp since it
;; calls eval, which invokes the compiler
(defmethod execute-command ((topic (eql :eval)) command-string)
(let ((*read-tolerant* t)
)
(eval (read-from-string command-string))))
;; Modify this default method to return a string according to the
;; keyword arguments for the topic and item passed by a
;; client's DDE REQUEST message
(defmethod answer-request (topic item command-result)
"")
;; For the special topic :eval, return the value of the symbol named
;; by the item argument, except in the current package
(defmethod answer-request ((topic (eql :eval)) item
command-result)
(format nil "~s" (symbol-value (intern (symbol-name item) *package*))))
;; For the special item :command-result, return the value that was returned
;; by the most recent execute-command method invoked for this client
(defmethod answer-request ((topic (eql :eval))(item (eql :command-result))
command-result)
(format nil "~s" command-result))
;; Some standard DDE topics and items to respond to
(defmethod answer-request ((topic (eql :system))(item (eql :sysitems))
command-result)
(list-to-tabbed-string *sysitems*))
(defmethod answer-request ((topic (eql :system))(item (eql :topics))
command-result)
(list-to-tabbed-string *service-topics*))
(defmethod answer-request ((topic (eql :system))(item (eql :help))
command-result)
"Send a DDE request for the HELP item of other topics for info on those topics")
(defmethod answer-request ((topic (eql :eval))(item (eql :help))
command-result)
#.(format nil "Send a DDE Execute using this EVAL topic ~
to evaluate an arbitrary lisp form. To get the value returned by that ~
form, send a DDE Request using this EVAL topic with the item ~
COMMAND-RESULT. To retrieve the value of any lisp symbol, send it as ~
the item in a DDE Request using this EVAL topic."))
;; Call this function whenever an item for which this lisp server handles
;; hot or warm links has changed. This will result in answer-request
;; being invoked for any items for which hot or warm links are currently
;; established
(defun post-advice (topic item)
(win:DDEPostAdvise *app-id*
(get-string-handle topic)
(get-string-handle item)))
;; Modify this default method to do your own interpretation of a
;; value that is sent (poked) by a client. This default method
;; interprets the item as the name of a symbol in the current package,
;; and sets that symbol to a value read from the value-string
(defmethod receive-value (topic item value-string) ;; <1>
(let* ((*read-tolerant* t))
(set (intern (symbol-name item) *package*)
(eval (read-from-string value-string)))))
;; ------------------------------------
;; DDE initialization and clean-up
(defun ensure-dde-open ()
(unless *app-id* ;; dde already initialized
;; Initialize the DDE library
(let* ((scratch-long (ccallocate (:long 1)))
(init-return
(progn
(setf (cref (:long 1) scratch-long 0) 0)
(win:ddeinitialize
scratch-long
(ct:get-callback-procinst 'dde-callback)
(logior win:appclass_standard
#+old win:cbf_fail_pokes ;; <1>
;; ??? I guess we should only allow self-connections
;; for testing
#+later win:cbf_fail_selfconnections
win:cbf_skip_registrations
win:cbf_skip_unregistrations)
0))))
;; DDE initialization errors
(case init-return
(#.win:dmlerr_no_error
(setq *app-id* (ct:cref (:long 1) scratch-long 0))
t)
(#.win:dmlerr_invalidparameter
(error "DML: Invalid Parameter"))
(#.win:dmlerr_dll_usage
(error "DML: Dll Usage"))
(#.win:dmlerr_sys_error
(error "DML: Sys Error"))
(t
(error "DML return code ~a" init-return))))
;; Be sure to clean up resources at lisp exit
(pushnew 'close-dde acl::*system-exit-fns*)
;; initialize the standard string-handles up front for efficiency
(dolist (key *initial-dde-keys*)
(make-string-handle key))
(setq *active-server-ports* nil)
(setq *active-client-ports* nil)
))
(defun close-dde (&rest ignore)
(declare (ignore ignore)) ;; Passed as a lisp exit function
(cond (*app-id*
(when *server-active-p*
(close-server))
(dolist (conv *active-client-ports*)
(close-port conv))
(release-string-handles)
(win:ddeuninitialize *app-id*)
(setq *app-id* nil)
t)
(t
(dde-warning "DDE already closed")
nil)))
;; ----------------------------------------
;; The DDE callback and handlers
(ct:defun-callback dde-callback
((utype win:uint)
(ufmt win:uint)
(hconv win:hconv)
(hsz1 win:hsz)
(hsz2 win:hsz)
(hdata win:hddedata)
(dwdata1 :long)
(dwdata2 :long))
(case utype
(#.win:xtyp_connect
(t.connect
(string-handle-to-symbol hsz2)
(string-handle-to-symbol hsz1) dwdata1))
(#.win:xtyp_connect_confirm
(t.connect-confirm
(string-handle-to-symbol hsz2)
(string-handle-to-symbol hsz1) hconv))
(#.win:xtyp_disconnect
(t.disconnect
(hconv-to-server-port hconv)))
(#.win:xtyp_error
(t.error
(hconv-to-server-port hconv)
dwdata1))
;; Server receives a command to execute
(#.win:xtyp_execute
(t.execute
(hconv-to-server-port hconv) ;; port
(string-handle-to-symbol hsz1) ;; topic
hdata)) ;; command string
;; Server receives a poked value
(#.win:xtyp_poke ;; <1>
(t.poke
(hconv-to-server-port hconv) ;; port
ufmt ;; data format
(string-handle-to-symbol hsz1) ;; topic
(string-handle-to-symbol hsz2) ;; item
hdata)) ;; value string
;; Server receives a request to answer (a cold link),
;; or the server's call to post-advice causes an advreq here
((#.win:xtyp_request #.win:xtyp_advreq)
(t.request
(hconv-to-server-port hconv) ;; port
ufmt ;; data format
(string-handle-to-symbol hsz1) ;; topic
(string-handle-to-symbol hsz2))) ;; item
;; Server receives a request to start advice (a hot link)
(#.win:xtyp_advstart
(t.advstart
(hconv-to-server-port hconv) ;; port
ufmt ;; data format
(string-handle-to-symbol hsz1) ;; topic
(string-handle-to-symbol hsz2) ;; item
:hot))
;; Server receives a request to start advice (a warm link)
(#.(logior win:xtyp_advstart win:xtypf_nodata)
(t.advstart
(hconv-to-server-port hconv) ;; port
ufmt ;; data format
(string-handle-to-symbol hsz1) ;; topic
(string-handle-to-symbol hsz2) ;; item
:warm))
;; Server receives a request to stop a hot or warm link
(#. win:xtyp_advstop
(t.advstop
(hconv-to-server-port hconv) ;; port
ufmt ;; data format
(string-handle-to-symbol hsz1) ;; topic
(string-handle-to-symbol hsz2))) ;; item
;; Client receives advice for a warm or hot link
(#.win:xtyp_advdata
(t.advdata
(hconv-to-client-port hconv) ;; port
(string-handle-to-symbol hsz1) ;; topic
(string-handle-to-symbol hsz2) ;; item
hdata)) ;; arbitray data
(#.win:xtyp_wildconnect
(t.wildconnect
(string-handle-to-symbol hsz2)
(string-handle-to-symbol hsz1) dwdata1))
(t
(t.unknown
hconv utype ufmt hsz1 hsz2 hdata dwdata1 dwdata1))))
(defmethod t.wildconnect (application topic context)
(cond ((and (eq application *service-name*)
(or (null *service-topics*)
(member topic *service-topics* :test #'eq)))
(lisp-message
"Accepting wild connection to application ~s and topic ~s"
application topic)
t)
(t
(dde-warning
"Refusing wild connection to application ~s and topic ~s"
application topic)
nil)))
(defmethod t.connect (application topic context)
;; Allow a connection to our lisp's service-name if one of
;; our valid topics is passed
(cond ((and (eq application *service-name*)
(or (null *service-topics*)
(member topic *service-topics* :test #'eq)))
(lisp-message
"Accepting connection to application ~s and topic ~s"
application topic)
true) ;; <2>
(t
;; Refuse connections that request other topics
(dde-warning
"Refusing connection to application ~s and topic ~s"
application topic)
false))) ;; <2>
(defmethod t.connect-confirm (application topic hconv)
(let ((port (make-instance 'server-port
:name (gensym-sequential-name :server)
:topic topic
:handle hconv))
)
(push port *active-server-ports*)
(lisp-message "DDE: Port ~s connection confirmed" port)))
(defmethod t.disconnect (port)
;; default method for unknown clients
(dde-warning "DDE: Unexpected disconnect transaction for port ~s"
port))
(defmethod t.disconnect ((port dde-port))
(lisp-message "~s disconnected" port)
(setq *active-server-ports*
(delete port *active-server-ports*)))
(defun data-buffer-to-handle (string id)
(let* ((length (length string))
(hdata (win:ddecreatedatahandle
*app-id* ct:hnull (1+ length)
0 id win:cf_text 0)))
(win:ddeadddata hdata string length 0)
(win:ddeadddata hdata null-char-string 1 length)
hdata))
(defmethod t.error (port code)
(dde-warning "DDE: Error transaction code ~s for port ~s"
code port))
(defmethod t.execute (port topic hdata)
;; default method is to refuse the execute
(dde-warning "DDE: Execute refused for unknown port")
win:dde_fnotprocessed)
(defmethod t.execute ((port dde-port) topic hdata)
;; but if we have a port going, we do it
(let ((length (win:ddegetdata hdata ct:hnull 0 0)) ; length of data
lisp-string result)
(ensure-buffer-size length)
(win:ddegetdata hdata *buffer* length 0)
(let ((*package* (slot-value port 'package)))
(setq lisp-string
(string-from-buffer length))
(setq result (execute-command topic lisp-string))
(setf (slot-value port 'result) result)
(setf (slot-value port 'package) *package*)
)
(lisp-message "DDE: Command ~s returns ~s"
lisp-string result)
)
win:dde_fack)
(defmethod t.advdata (port topic item hdata)
(dde-warning "DDE: Advice received for unknown port ~s"
port)
win:dde_fnotprocessed)
(defmethod t.advdata ((port dde-port) topic item hdata)
;; Client receives advice from the server, resulting from an
;; earlier send-request for a hot or warm link
(let ((length (win:ddegetdata hdata ct:hnull 0 0)) ; length of data
lisp-string advice)
(ensure-buffer-size length)
(win:ddegetdata hdata *buffer* length 0)
(cond ((plusp length)
;; Hot link
(receive-advice port topic item
(setq advice (convert-returned-dde-string
(string-from-buffer length))))
(lisp-message "DDE: Hot advice received for ~
application ~a topic ~a item ~a --> ~s"
(port-application port)
topic item advice)
)
(t
(receive-advice port topic item nil)
(lisp-message "DDE: Warm advice received for ~
application ~a topic ~a item ~a"
(port-application port)
topic item))))
win:dde_fack)
(defmethod t.advstart ((port dde-port) ufmt topic item type)
;; Server receives a request to begin sending advice (a hot or warm link)
(if (eq type :hot)
(push item (hot-links port))
(push item (warm-links port)))
true) ;; <2>
(defmethod t.advstop ((port dde-port) ufmt topic item)
;; Server receives a request to stop sending advice (a hot or warm link)
(delete item (hot-links port))
(delete item (warm-links port))
true) ;; <2>
(defmethod t.request ((port dde-port) ufmt topic item)
;; Server receives a standalone request (cold link)
(let* ((*package* (slot-value port 'package))
(buffer (answer-request topic item
;; For the special :command-result item, always return the value that
;; was returned by the last execute command
(slot-value port 'result)))
hdata)
(cond ((stringp buffer)
(setq hdata (data-buffer-to-handle buffer
(get-string-handle item)))
(lisp-message "DDE: Request ~s returns ~s"
item buffer)
(handle-value win:hddedata hdata))
(t
(dde-warning "DDE: Non-string returned by ~
answer-request method; returning NULL handle to the client")
nil))))
(defmethod t.poke ((port dde-port) ufmt topic item hdata) ;; <1>
;; Server receives a poked value
(let ((length (win:ddegetdata hdata ct:hnull 0 0)) ; length of data
(*package* (slot-value port 'package))
lisp-string result)
(ensure-buffer-size length)
(win:ddegetdata hdata *buffer* length 0)
(setq lisp-string
(string-from-buffer length))
(setq result (receive-value topic item lisp-string))
(cond (result
(lisp-message "DDE: Accepted value for topic ~s ~
item ~s new value ~s"
topic item lisp-string)
win:dde_fack)
(t
(lisp-warning "DDE: Rejected value for topic ~s ~
item ~s new value ~s"
topic item lisp-string)
win:dde_fnotprocessed))))
(defmethod t.unknown (port utype ufmt hsz1 hsz2 hdata dwdata1 dwdata)
(dde-warning "DDE: Unexpected transaction ~s for ~s~%"
utype port))
#.(export 'dde::free-item :dde)
(defun free-item (item-string-or-symbol)
(let* ((symbol (if (stringp item-string-or-symbol)
(find-symbol
(if *case-sensitive-dde*
item-string-or-symbol
(string-upcase item-string-or-symbol))
(symbol-package :start))
item-string-or-symbol))
handle)
(unless symbol
(error "Tried to free an unused DDE item string"))
(setq handle (get symbol :string-handle))
(when handle
(win:ddefreestringhandle *app-id* handle)
(remprop symbol :string-handle))
(unintern symbol (symbol-package symbol))))
;; <<< main.lsp
|