;This module is the interface to DDEClient.dll a dll to setup dde clients.
;It defines all dde procedures to communicate between PLT Scheme and other
;applications via dde.
;Author and copyright: R. Matovinovic, 24.10.2006, v1.00
(module ddeclient mzscheme
  
  (require (lib "foreign.ss" "mzlib"))
  (require (only (lib "contract.ss") provide/contract natural-number/c or/c any))
  (require (rename (lib "contract.ss") --> ->))
  (unsafe!)
  
  (provide/contract
   ;procedures which are defined in this module
   (dde-connect (--> string? string? any))
   (dde-disconnect (--> natural-number/c any))
   (dde-cmd (--> natural-number/c 
                 (lambda (in)
                   (or (string=? in "execute")
                       (string=? in "poke")
                       (string=? in "request")
                       ))
                 (lambda (in) (and (string? in) (< (string-length in) 256)))
                 string? 
                 string? 
                 natural-number/c 
                 (lambda (in)
                   (or (string=? in "byte")
                       (string=? in "string")
                       (string=? in "")
                       ))
                 any))
   (dde-request (--> natural-number/c 
                     (lambda (in) (and (string? in) (< (string-length in) 256)))
                     string? natural-number/c any))
   (dde-request-string (--> natural-number/c 
                            (lambda (in) (and (string? in) 
                                              (< (string-length in) 256)))
                            natural-number/c any))
   (dde-execute (--> natural-number/c 
                     (lambda (in) (and (string? in) (< (string-length in) 256)))
                     natural-number/c any))
   (dde-poke (--> natural-number/c 
                  (lambda (in) (and (string? in) (< (string-length in) 256)))
                  string? natural-number/c any))
   
   (dde-data-pointer (--> natural-number/c))
   (dde-data-length (--> natural-number/c))
   (dde-data-string (--> natural-number/c))
   (dde-data-id-trans (--> natural-number/c))
   
   ;procedures which access directly the dll
   (dc-dde-disconnect (--> natural-number/c any))
   (dc-dde-cmd (--> natural-number/c 
                 (lambda (in)
                   (or (string=? in "execute")
                       (string=? in "poke")
                       (string=? in "request")
                       ))
                 string? 
                 string? 
                 string? 
                 natural-number/c 
                 (lambda (in)
                   (or (string=? in "byte")
                       (string=? in "string")
                       (string=? in "")
                       ))
                 any))
   (dc-dde-request (--> natural-number/c string? string? natural-number/c any))
   (dc-dde-request-string (--> natural-number/c string? natural-number/c any))
   (dc-dde-asynch-transaction-completed (--> natural-number/c natural-number/c boolean? any))
   (dc-dde-abandon-transaction (--> natural-number/c natural-number/c any))
   (dc-dde-free-mem (--> natural-number/c any))
   )

  (provide 
   ;procedures which are defined in this module
   dde-init 
   dde-uninit 
   dde-error-head
   
   ;procedures which access directly the dll
   dc-dde-init 
   dc-dde-uninit 
   dc-dde-connect
   dc-dde-finalize
   dc-dde-version
   dc-dde-last-error
   )
  
  ;ctype which converts false and true from Windows into #f and #t
  ;because the corresponding values are byte and not int which could
  ;be handled by the type _bool
  (define _bytebool
    (make-ctype _byte
                (lambda (bool) (if bool 1 0))
                (lambda (byte) (not (zero? byte)))))
  
  ;the following definition is taken from to Jon Rafkind's allegro package
  ;it resolves the directory of this module
  (define *dir*
    (let-syntax ((current-module-directory
                  (lambda (stx)
                    (datum->syntax-object
		     stx (current-load-relative-directory)))))
      (current-module-directory)))
  

  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;Import of dll procedures
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define dde-client-dll (ffi-lib (build-path *dir* "dll" "DDEClient")))

  (define dc-dde-init (get-ffi-obj "DCInit" dde-client-dll 
                                (_fun -> _bytebool)))
  (define dc-dde-uninit (get-ffi-obj "DCUninit" dde-client-dll 
                                  (_fun -> _bytebool)))
  (define dc-dde-connect (get-ffi-obj "DCConnect" dde-client-dll 
                                      (_fun _pointer _string _string -> _bytebool)))
  (define dc-dde-disconnect (get-ffi-obj "DCDisconnect" dde-client-dll 
                                      (_fun _word -> _bytebool)))
  (define dc-dde-cmd (get-ffi-obj "DCTransaction" dde-client-dll
                                  (_fun _word _string _string _string 
                                        _string _uint32 _string -> _bytebool)
                                  )
    )
  (define dc-dde-request (get-ffi-obj "DCRequest" dde-client-dll
                                      (_fun _word _string _string _int -> _bytebool)
                                      )
    )
  (define dc-dde-request-string (get-ffi-obj "DCRequestString" dde-client-dll
                                             (_fun _word _string _int -> _bytebool)
                                             )
    )
  (define dc-dde-asynch-transaction-completed 
    (get-ffi-obj "DCAsynchTransactionCompleted" dde-client-dll 
                 (_fun _word _uint32 _bool -> _bytebool)))
  (define dc-dde-free-mem (get-ffi-obj "DCFreeDdeMem" dde-client-dll 
                                    (_fun _word -> _bytebool)))
  (define dc-dde-finalize (get-ffi-obj "DCFinalize" dde-client-dll 
                                    (_fun -> _void)))
  (define dc-dde-abandon-transaction 
    (get-ffi-obj "DCAbandonTransaction" dde-client-dll 
                 (_fun _word _uint32 -> _bytebool)))
  (define dc-dde-version (get-ffi-obj "DCVersion" dde-client-dll 
                                   (_fun -> _string)))
  
  (define dc-dde-last-error (get-ffi-obj "DCLastError" dde-client-dll 
                                      (_fun -> _string)))
  (define dc-dde-import-errors? (get-ffi-obj "bDCErrorExport" dde-client-dll _bytebool))
  
  
  

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;definitions for access of returned dde data
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  
  ;c structure type for accessing dde data of one conversation as defined in dll
  (define-cstruct _dde-struct ((ptr _pointer)(len _uint32)(str _string)
                               (id-trans _uint32)(id-trans-cb _uint32)
                               (access _string)))
  ;import of pointer to array of conversation pointers
  (define dde-conv-pointer (get-ffi-obj "DCDA" dde-client-dll _pointer))
  
 
  ;accessor procedures for conversation specific dde data of _dde-struct format
  ;pointer to data structure of a specific conversation indexed by conv
  (define (dde-struct-pointer conv)
    (ptr-ref (ptr-ref dde-conv-pointer _pointer conv) _dde-struct))
  ;data of conversation conv
  ;pointer to byte string data
  (define (dde-data-pointer conv)
    (dde-struct-ptr (dde-struct-pointer conv)))
  ;length of byte string data
  (define (dde-data-length conv)
    (dde-struct-len (dde-struct-pointer conv)))
  ;string of data, if data is accessed as string
  (define (dde-data-string conv)
    (dde-struct-str (dde-struct-pointer conv)))
  ;transaction id of current dde transaction
  ;for use with asynchronous transactions
  (define (dde-data-id-trans conv)
    (dde-struct-id-trans (dde-struct-pointer conv)))
  

 
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;error related procedures and settings
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  
  ;head of error message
  (define dde-error-head "DDE Client DLL Error:")
  
  ;dde error message procedure
  ;(dde-last-error) retrieves the last error from the dll
  (define (dde-error)
    (raise-user-error dde-error-head (dc-dde-last-error))
    )
  
  ;error procedure for dde commands to make sure
  ;proper disconnection and memory freeing
  (define (dde-error-in-cmd conv)
    (let((error-message (dc-dde-last-error)))
      (dc-dde-disconnect conv)
      (dc-dde-uninit)
      (raise-user-error dde-error-head error-message)
      )
    )
  
  ;Errors shall be returned to this program and not displayed in
  ;system message boxes
  (set-ffi-obj! "bDCErrorExport" dde-client-dll _bytebool #t)

  
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;procedures with data and error handling for more convenient use
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  
  ;initialization procedure with error handling
  ;void -> void
  (define (dde-init)
    (if(not(dc-dde-init))
       (dde-error)
       )
    )

  ;uninitialization procedure with error handling
  ;void -> void
  (define (dde-uninit)
    (if(not(dc-dde-uninit))
       (dde-error)
       )
    )
  
  ;procedure to connect to dde service with error handling
  ;string, string -> number
  (define (dde-connect service topic)
    (let((conversation-ptr (malloc _word))
         (conversation-no 0)
         )
      (if (dc-dde-connect conversation-ptr service topic)
          (begin
            (set! conversation-no (ptr-ref conversation-ptr _word))
            (free conversation-ptr)
            conversation-no
            )
          (raise-user-error dde-error-head (dc-dde-last-error));(dde-error)
          )
      )
    )
  
  ;procedure to disconnect dde service with error handling
  ;number -> void
  (define (dde-disconnect conv)
     (if(not(dc-dde-disconnect conv))
       (dde-error)
       )
    )
 
  ;procedure to access dde data as byte string
  ;number -> byte-string
  (define (access-dde-data-bytes conv)
    ;make a copy of the byte string of dde data with dde-data-struct data
    (let ((dde-data (bytes-copy (make-sized-byte-string 
                                 (dde-data-pointer conv)
                                 (- (dde-data-length conv) 1))))
          )
      ;free memory of dde data in library
      (dc-dde-free-mem conv)
      ;return DDE data as byte string
      dde-data
      )
    )
  
  ;procedure to access dde data as string
  ;number -> string
  (define (access-dde-data-string conv)
    ;make a copy of dde data string
    (let ((dde-data (string-copy (dde-data-string conv))))
      ;free memory of dde data in library
      (dc-dde-free-mem conv)
      ;return dde data string
      dde-data
      )
    )
  
  ;procedure to access dde data in given format
  ;number, string -> formatted string
  (define (access-dde-data conv format)
    (if (string=? format "string")
        (access-dde-data-string conv)
        (access-dde-data-bytes conv)
        )
    )
  
  ;procedure to send a dde command to a service with error handling
  ;number, string, string, string, string, number, string -> string/byte-string
  (define (dde-cmd conv type item data format timeout access)
    (if (dc-dde-cmd conv type item data format timeout access)
        (cond ((string=? type "request")
               (cond ((> timeout 0)
                      (access-dde-data conv access)
                      )
                     ((= timeout 0)
                      (if (dc-dde-asynch-transaction-completed 
                           conv (dde-data-id-trans conv) #t)
                          (access-dde-data conv access)
                          (dde-error-in-cmd conv)
                          )
                      )
                     )
               )
              ((or (string=? type "execute")
                   (string=? type "poke"))
               (if (= timeout 0)
                     (if (dc-dde-asynch-transaction-completed conv (dde-data-id-trans conv) #t)
                         #t
                         (dde-error-in-cmd conv)
                         )
                   )             
               )
              )
        (dde-error-in-cmd conv)
        )
    )

  ;procedure abbreviates dde-cmd for a request in byte format
  ;number, string, string, number -> byte-string
  (define (dde-request conv item format timeout)
    (if (dc-dde-request conv item format timeout)
        (cond ((> timeout 0)
               (access-dde-data-bytes conv)
               )
              ((= timeout 0)
               (if (dc-dde-asynch-transaction-completed 
                    conv (dde-data-id-trans conv) #t)
                   (access-dde-data-bytes conv)
                   (dde-error-in-cmd conv)
                   )
               )
              )
        (dde-error-in-cmd conv)
        )
    )

  ;procedure abbreviates dde-cmd for a request in string format
  ;number, string, number -> string
  (define (dde-request-string conv item timeout)
    (if (dc-dde-request-string conv item timeout)
        (cond ((> timeout 0)
               (access-dde-data-string conv)
               )
              ((= timeout 0)
               (if (dc-dde-asynch-transaction-completed 
                    conv (dde-data-id-trans conv) #t)
                   (access-dde-data-string conv)
                   (dde-error-in-cmd conv)
                   )
               )
              )
        (dde-error-in-cmd conv)
        )
    )

  ;procedure abbreviates dde-cmd for a execute
  ;number, string, number -> void
  (define (dde-execute conv item timeout)
    (if (dc-dde-cmd conv "execute" item "" "CF_TEXT" timeout "")
        (if (= timeout 0)
            (if (not(dc-dde-asynch-transaction-completed conv (dde-data-id-trans conv) #t))
                (dde-error-in-cmd conv)
                )
            )             
        (dde-error-in-cmd conv)
        )
    )

  ;procedure abbreviates dde-cmd for a poke
  ;number, string, string, number -> void
  (define (dde-poke conv item data timeout)
    (if (dc-dde-cmd conv "poke" item data "CF_TEXT" timeout "")
        (if (= timeout 0)
            (if (not (dc-dde-asynch-transaction-completed conv (dde-data-id-trans conv) #t))
                (dde-error-in-cmd conv)
                )
            )             
        (dde-error-in-cmd conv)
        )
    )
   
)