From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 6 Oct 1994 03:08:42 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~7088
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2a58aa74daad1492134adb1d28cf4cae8539204a;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/win32/tests/CLIPBRD.SCM b/v7/src/win32/tests/CLIPBRD.SCM
new file mode 100644
index 000000000..7a3944b47
--- /dev/null
+++ b/v7/src/win32/tests/CLIPBRD.SCM
@@ -0,0 +1,69 @@
+
+(define open-clipboard
+  (windows-procedure (open-clipboard (hwnd hwnd))
+    bool user32.dll "OpenClipboard"))
+
+(define close-clipboard
+  (windows-procedure (close-clipboard) bool user32.dll "CloseClipboard"))
+
+(define set-clipboard-data
+  (windows-procedure (set-clipboard-data (format uint) (hdata handle))
+    handle user32.dll "SetClipboardData"))
+
+(define get-clipboard-data
+  (windows-procedure (get-clipboard-data (format uint))
+    handle user32.dll "GetClipboardData"))
+
+(define global-alloc
+  (windows-procedure (global-alloc (fuFlags uint) (cbBytes dword))
+    handle kernel32.dll "GlobalAlloc"))
+
+(define global-lock
+  (windows-procedure (global-lock (hglbMem handle))
+    uint kernel32.dll "GlobalLock"))
+
+(define global-unlock
+  (windows-procedure (global-unlock (hglbMem handle))
+    bool kernel32.dll "GlobalUnlock"))
+
+(define global-size
+  (windows-procedure (global-size (hglbMem handle))
+    dword kernel32.dll "GlobalSize"))
+
+(define copy-memory
+  (windows-procedure (copy-memory (destination unchecked) (source unchecked)
+				  (length dword))
+    bool kernel32.dll "RtlMoveMemory"))
+
+(define (clipboard-set! s)
+  (let ((clip? (open-clipboard 0)))
+    (and clip?
+	 (let* ((len  (+ (string-length s) 1))
+		(mem  (global-alloc #x2002 #|= GMEM_MOVEABLE + GMEM_DDESHARE|#
+				    len)))
+	   (if (= mem 0)
+	       #F
+	       (let ((ptr  (global-lock mem)))
+		 (if (= ptr 0)
+		     #F
+		     (begin
+		       (copy-memory ptr s len)
+		       (global-unlock mem)
+		       (set-clipboard-data CF_TEXT mem)
+		       (close-clipboard)))))))))
+
+(define (clipboard-ref)
+  (let ((clip? (open-clipboard 0)))
+    (and clip?
+	 (let* ((mem  (get-clipboard-data CF_TEXT)))
+	   (if (= mem 0)
+	       'empty
+	       (let* ((maxlen (global-size mem))
+		      (s      (string-allocate maxlen))
+		      (ptr    (global-lock mem)))
+		 (copy-memory s ptr maxlen)
+		 (global-unlock mem)
+		 (close-clipboard)
+		 (let ((end (vector-8b-find-next-char s 0 maxlen 0)))
+		   (set-string-length! s end))
+		 s))))))
\ No newline at end of file