MCL2 <--> HC2 via AppleEvents: source

[cressy!mts (Martin Stanley)]

I wrote here earlier that I had received some working code that implements
AppleEvent communication between HyperCard2 and MCL2.  By popular demand
(> 15 requests that I post the code) I enclose herein some sample code
written by Malcolm Pradhan at the University of Adelaide, South Australia.

I have made a few minor cosmetic changes to Malcolm's code and am sending
this with his permission.  If anyone improves on this, could you let me (as
well as Malcolm) know, please?

Martin 

-------------------------------------------------------------------------------
Martin Stanley                                  Department of Computer Science
mts@ai.toronto.edu  -or-                        University of Toronto
mts@ai.utoronto.ca                              Kings College Circle
                                                Toronto, Ontario
-------------------------------------------------------------------------------


------ code begins ------
;;;
;;;  THIS CODE IS GENERALLY UNTESTED AND DOES LITTLE ERROR CHECKING, IT IS
;;;  MEANT TO ILLUSTRATE THE TECHNIQUES OF RECEIVING AND SENDING APPLEEVENTS.
;;;
;;;    Malcolm Pradhan                               _--_|\
;;;    Medical Computing, Faculty of Medicine       /      \
;;;    University of Adelaide, South Australia      \_.--._/
;;;    InterNet: mpradhan@f.adelaide.edu.au               v
;;;    Fax: + 618 223 2076

;;; Feel free to use this code in any way you see fit.  If you make any
;;; modifications to it, please send them to Malcolm Pradhan at the above
;;; address.

;;;
;;;   STRING TO PTR
;;;
;;;   creates and fills a mac pointer with the contents of a lisp string
;;; 

(defun string-to-ptr (str)
  (let* ((num (length str))
         (macp (#_NewPtr num)))
    (dotimes (count num macp)
      (%put-byte macp (char-int (elt str count)) count))))


;;;
;;;   PTR TO STRING
;;;
;;;   creates and fills a lisp string with the contents of a mac pointer
;;;

(defun ptr-to-string (mptr)
  (let* ((num (#_GetPtrSize mptr))
         (str (make-string num)))
    (dotimes (count num str)
      (setf (elt str count) (character (%get-byte mptr count))))))


;;; The following is the actual code to handle the communication with HyperCard.


;;;
;;;       MCL to HYPERCARD
;;;

;;;         CHECK ERR
;;;
;;;

(defun checkError (err)
  (when (numberp err)
    (unless (eql err #$noErr)
      (throw 'appleEventError err))))


;;;         DOHCEVAL
;;; 
;;;

(defun doHCEval (script &key (priority #$kAENormalPriority) (timeout #$kAEDefaultTimeout))
  "Sends an expression to be evaluated by HyperCard, a value is returned"
  (let ((scriptLen (length script))  ; length of the script to be sent
        (script-ptr (string-to-ptr script))
        (reply-ptr (%null-ptr))
        (result-string ""))
    (rlet ((ae :appleEvent)
           (ostype :osType)
           (aetarget :aeaddressdesc)
           (aereply :AppleEvent)
           (replyLen :unsigned-longint)
           (replyDesc :DescType))
      (catch 'appleEventError
        (unwind-protect
          (progn
            (%put-ostype ostype "WILD")   ; this will identify Hypercard on the local machine
            (checkError (#_AECreateDesc #$typeApplSignature ostype 4 aetarget))  ; destination description
            (checkError (#_AECreateAppleEvent "misc" "eval" aetarget #$kAutoGenerateReturnID
                         #$kAnyTransactionID ae))
            (checkError (#_AEPutParamPtr ae #$keyDirectObject #$typeChar script-ptr scriptLen))
            (checkError (#_AESend ae aereply (+ #$kAEWaitReply #$kAENeverInteract)
                         priority timeout (%null-ptr) (%null-ptr)))  ; send the event
            
            (checkError (#_AEGetParamPtr aereply #$keyDirectObject #$typeChar replyDesc
                         (%null-ptr) 0 replyLen))   ; find the length of the reply string
            (setq reply-ptr (#_NewPtr (%get-long replyLen)))
            (checkError (#_AEGetParamPtr aereply #$keyDirectObject #$typeChar replyDesc
                         reply-ptr (%get-long replyLen) replyLen))
            (setq result-string (ptr-to-string reply-ptr)) ; convert macptr to a lisp string
            )
          (#_DisposPtr script-ptr)    ; clean up
          (#_DisposPtr reply-ptr))
        result-string))))


;;;         DOHCSCRIPT
;;;
;;;

(defun doHCScript (script &key (priority #$kAENormalPriority) (timeout #$kAEDefaultTimeout))
  "Sends an expression to be evaluated by HyperCard, no value is returned"
  (let ((scriptLen (length script))
        (script-ptr (string-to-ptr script)))
    (rlet ((ae :appleEvent)
           (aetarget :aeaddressdesc)
           (aereply :AppleEvent)
           (osType :ostype))
      (catch 'appleEventError
        (unwind-protect
          (progn
            (%put-ostype ostype "WILD")
            (checkError (#_AECreateDesc #$typeApplSignature ostype 4 aetarget))
            (checkError (#_AECreateAppleEvent "misc" "dosc" aetarget #$kAutoGenerateReturnID
                         #$kAnyTransactionID ae))
            (checkError (#_AEPutParamPtr ae #$keyDirectObject #$typeChar script-ptr scriptLen))
            (checkError (#_AESend ae aereply (+ #$kAENoReply #$kAENeverInteract)
                         priority timeout (%null-ptr) (%null-ptr))))
          (#_DisposPtr script-ptr))
        t))))


;;;         DO SCRIPT
;;;
;;;

(defpascal doScript (:ptr theAppleEvent :ptr reply :long handlerRefCon :word)
  "AE handler for the 'dosc' id - does script, no result"
  (declare (ignore reply handlerRefcon)
           (inline ptr-to-string))
  (let ((script-ptr nil))
    (rlet ((scriptDesc :DescType)
           (scriptLen :unsigned-longint))
      (catch 'appleEventError
        (unwind-protect
          (progn
            (checkError (#_AEGetParamPtr theAppleEvent #$keyDirectObject #$typeChar scriptDesc
                         (%null-ptr) 0 scriptLen))      ; find the length of the script string
            (setq script-ptr (#_NewPtr (%get-long scriptLen)))
            (checkError (#_AEGetParamPtr theAppleEvent #$keyDirectObject #$typeChar scriptDesc
                         script-ptr (%get-long scriptLen) scriptLen))
            (eval (read-from-string (ptr-to-string script-ptr))))
          (#_DisposPtr script-ptr))
        #$noERR))))

;;;         DO EVAL
;;;
;;;


(defpascal doEval (:ptr theAppleEvent :ptr reply :long handlerRefCon :word)
  "Handler for the 'eval' AE of the 'misc' class - evaluates and returns the result"
  (declare (ignore handlerRefcon)
           (inline ptr-to-string))
  (let ((sexp nil)
        (result "")
        (result-ptr nil))
    (rlet ((sexpDesc :DescType)
           (sexpLen :unsigned-longint))
      (catch 'appleEventError
        (unwind-protect
          (progn
            (checkError (#_AEGetParamPtr theAppleEvent #$keyDirectObject #$typeChar sexpDesc
                         (%null-ptr) 0 sexpLen))      ; find the length of the sexp
            (setq sexp (#_NewPtr (%get-long sexpLen)))
            (checkError (#_AEGetParamPtr theAppleEvent #$keyDirectObject #$typeChar sexpDesc
                         sexp (%get-long sexpLen) sexpLen))
            (setq result (princ-to-string 
                          (eval (read-from-string (ptr-to-string sexp)))))
            (setq result-ptr (string-to-ptr result))
            (checkError (#_AEPutParamPtr reply #$keyDirectObject #$typeChar result-ptr 
                         (#_GetPtrSize result-ptr)))) 
          (#_DisposPtr result-ptr))
        #$noErr)
      )))

;;;         INSTALL AE HANDLERS
;;;
;;;     Install the handlers to the AEs
;;;

(defun AEInstallHandlers ()
  (#_AEInstallEventHandler "misc" "dosc" doscript 0 0)
  (#_AEInstallEventHandler "misc" "eval" doEval 0 0)
  )
------ code ends ------