From ef52659ef2de48cedaf518a77fb73ca4a0bf279d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 17 Oct 2010 15:19:00 -0600
Subject: [PATCH] win32: single-instance support

original commit: 4360a45fa6ee0a42656c61fd294be9b878fbc002
---
 collects/mred/private/wx/win32/window.rkt | 64 +++++++++++++++++++++++
 1 file changed, 64 insertions(+)

diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt
index eea9ba42..ab0a7428 100644
--- a/collects/mred/private/wx/win32/window.rkt
+++ b/collects/mred/private/wx/win32/window.rkt
@@ -2,6 +2,7 @@
 (require ffi/unsafe
 	 racket/class
 	 racket/draw
+	 racket/draw/bstr
          "../../syntax.rkt"
          "../common/freeze.rkt"
          "../common/queue.rkt"
@@ -102,6 +103,17 @@
 (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
 (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
 
+(define WM_IS_GRACKET (cast (scheme_register_process_global "PLT_WM_IS_GRACKET" #f)
+                            _pointer
+                            _UINT_PTR))
+(define GRACKET_GUID (cast (scheme_register_process_global "PLT_GRACKET_GUID" #f)
+                           _pointer
+                           _bytes))
+(define-cstruct _COPYDATASTRUCT
+  ([dwData _pointer]
+   [cbData _DWORD]
+   [lpData _pointer]))
+
 (defclass window% object%
   (init-field parent hwnd)
   (init style
@@ -189,6 +201,15 @@
          [(= msg WM_DROPFILES)
           (handle-drop-files wParam)
           0]
+         ;; for single-instance applications:
+         [(and (= msg WM_IS_GRACKET)
+               (positive? WM_IS_GRACKET))
+          ;; return 79 to indicate that this is a GRacket window
+          79]
+         ;; also for single-instance:
+         [(= msg WM_COPYDATA)
+          (handle-copydata lParam)
+          0]
          [else
           (default w msg wParam lParam)])))
 
@@ -621,6 +642,49 @@
 
 ;; ----------------------------------------
 
+(define (handle-copydata lParam)
+  (let* ([cd (cast lParam _LPARAM _COPYDATASTRUCT-pointer)]
+         [data (COPYDATASTRUCT-lpData cd)]
+         [guid-len (bytes-length GRACKET_GUID)]
+         [data-len (COPYDATASTRUCT-cbData cd)])
+    (when (and (data-len
+                . > . 
+                (+ guid-len (ctype-sizeof _DWORD)))
+               (bytes=? GRACKET_GUID
+                        (scheme_make_sized_byte_string data
+                                                       guid-len
+                                                       0))
+               (bytes=? #"OPEN"
+                        (scheme_make_sized_byte_string (ptr-add data guid-len)
+                                                       4
+                                                       0)))
+      ;; The command line's argv (sans argv[0]) is
+      ;; expressed as a DWORD for the number of args,
+      ;; followed by each arg. Each arg is a DWORD
+      ;; for the number of chars and then the chars
+      (let ([args
+             (let ([count (ptr-ref data _DWORD 'abs (+ guid-len 4))])
+               (let loop ([i 0] [delta (+ guid-len 4 (ctype-sizeof _DWORD))])
+                 (if (or (= i count)
+                         ((+ delta (ctype-sizeof _DWORD)) . > . data-len))
+                     null
+                     (let ([len (ptr-ref (ptr-add data delta) _DWORD)]
+                           [delta (+ delta (ctype-sizeof _DWORD))])
+                       (if ((+ delta len) . > . data-len)
+                           null
+                           (let ([s (scheme_make_sized_byte_string 
+                                     (ptr-add data delta)
+                                     len
+                                     1)])
+                             (if (or (bytes=? s #"")
+                                     (regexp-match? #rx"\0" s))
+                                 null
+                                 (cons (bytes->path s)
+                                       (loop (add1 i) (+ delta len))))))))))])
+        (map queue-file-event args)))))
+
+;; ----------------------------------------
+
 (define (queue-window-event win thunk)
   (queue-event (send win get-eventspace) thunk))