;; Notice: NT only, as written

(require-dll "w32.dll")

; NT definitions
(define *userdll* "user32.dll")
(define *kerneldll* "kernel32.dll")

(define GetDesktopWindow 
  (w32:foreign-procedure *userdll* "GetDesktopWindow" '(w32api handle)))

(define w32:*host-hwnd* (getdesktopwindow)) ; NT patch

(define LMEM_FIXED 0)
(define GMEM_MOVEABLE #x2)
(define GMEM_DDESHARE #x2000)
(define CF_UNICODETEXT 13)

(define LocalAlloc
  (w32:foreign-procedure *kerneldll* "LocalAlloc" '(w32api handle dword dword)))
(define LocalFree
  (w32:foreign-procedure *kerneldll* "LocalFree" '(w32api void handle)))
(define GlobalAlloc
  (w32:foreign-procedure *kerneldll* "GlobalAlloc" '(w32api handle dword dword)))
(define GlobalFree
  (w32:foreign-procedure *kerneldll* "GlobalFree" '(w32api void handle)))
(define GlobalLock
  (w32:foreign-procedure *kerneldll* "GlobalLock" '(w32api lpvoid handle)))
(define GlobalUnlock
  (w32:foreign-procedure *kerneldll* "GlobalUnlock" '(w32api bool handle)))
(define OpenClipboard 
  (w32:foreign-procedure *userdll* "OpenClipboard" '(w32api bool handle)))
(define EmptyClipboard 
  (w32:foreign-procedure *userdll* "EmptyClipboard" '(w32api bool)))
(define SetClipboardData 
  (w32:foreign-procedure *userdll* "SetClipboardData" '(w32api bool dword handle)))
(define IsClipboardFormatAvailable
  (w32:foreign-procedure *userdll* "IsClipboardFormatAvailable" '(w32api bool dword)))
(define GetClipboardData 
  (w32:foreign-procedure *userdll* "GetClipboardData" '(w32api handle dword)))
(define CloseClipboard
  (w32:foreign-procedure *userdll* "CloseClipboard" '(w32api bool)))


;; What goes up, must come down
;;
(define-macro (unwind-protect form . unwind-forms)
  `(dynamic-wind (lambda () #t) (lambda () ,form) (lambda () ,@unwind-forms)))

;; A very simpleminded way of checking an apicall.
;; Would be interesting to merge 'msg' with the results of calls to GetLastError and FormatMessage.
;;
(define (api-check res msg)
  (if (or (not res) (and (foreign? res) (zero? res)))
    (if (procedure? msg) (msg) (error msg))
    res))

;; Compare against w32:string->clipboard
;$ REVIEW -
; a FFI thunk for CRT DLLs (on NT, anyway) would let this use the CRTDLL memcpy
; instead of the very awkward loop below
;;
(define (test:string->clipboard str)
  (if (not (string? str)) (error "Not a string:" str))
  (let* ((cch (string-length str))
         (cw (+ 1 cch)))
    (api-check (openclipboard w32:*host-hwnd*) "Couldn't open clipboard")
    (unwind-protect
      ; on CE, should call LocalAlloc/LocalFree with LMEM_FIXED
      (let ((buf (api-check (globalalloc (bit-or GMEM_MOVEABLE GMEM_DDESHARE) (* 2 cw)) "allocating memory")))
        (unwind-protect
          (begin 
            (let ((vdst (foreign->raw-vector (api-check (globallock buf) "allocating memory") cw 'word))
                  (vsrc (foreign->raw-vector (string->foreign str) cch 'word)))
              (do ((i 0 (+ i 1))) 
                ((= i cch) (raw-vector-set! vdst i 0) (globalunlock buf)) 
                (raw-vector-set! vdst i (raw-vector-ref vsrc i))))
            (api-check (emptyclipboard) "Couldn't clear clipboard")
            (api-check (setclipboarddata CF_UNICODETEXT buf) "Couldn't set clipboard")
            (set! buf #f))
          (if buf (globalfree buf))))
      (closeclipboard))))

;; Compare against w32:clipboard->string
;;
(define (test:clipboard->string)
  (if (not (isclipboardformatavailable CF_UNICODETEXT))
    #f
    (begin
      (api-check (openclipboard w32:*host-hwnd*) "Couldn't open clipboard")
      (unwind-protect
        (string-copy (foreign->string (api-check (getclipboarddata CF_UNICODETEXT) "Couldn't get data")))
        (closeclipboard)))))