gtk: command line and single-instance support

collects/mred/private/wx/common/queue.rkt

@@ -50,7 +50,9 @@
 
          begin-busy-cursor
          end-busy-cursor
-         is-busy?)
+         is-busy?
+
+         scheme_register_process_global)
 
 ;; ------------------------------------------------------------
 ;; This module must be instantiated only once:

collects/mred/private/wx/gtk/init.rkt

@@ -5,8 +5,6 @@
          "queue.rkt")
 (unsafe!)
 
-(define-gtk gtk_init (_fun (_ptr io _int) (_ptr io _pointer) -> _void))
-
 (define-gtk gtk_rc_parse_string (_fun _string -> _void))
 (define-gtk gtk_rc_add_default_file (_fun _path -> _void))
 (define-gtk gtk_rc_find_module_in_path (_fun _path -> _path))
@@ -17,6 +15,5 @@
     (gtk_rc_parse_string (format "module_path \"~a\"\n" dir))
     (gtk_rc_add_default_file (build-path dir "gtkrc"))))
 
-(gtk_init 0 #f)
 (define pump-thread (gtk-start-event-pump))
 

collects/mred/private/wx/gtk/queue.rkt

@@ -7,7 +7,8 @@
          "../common/queue.rkt"
          "../common/freeze.rkt"
          "const.rkt"
-	 "w32.rkt")
+	 "w32.rkt"
+         "unique.rkt")
 
 (provide gtk-start-event-pump
 
@@ -20,12 +21,65 @@
          queue-event
          yield)
 
+
+;; ------------------------------------------------------------
+;; Gtk initialization
+
+(define-gtk gtk_init_check (_fun (_ptr io _int) (_ptr io _gcpointer) -> _gboolean))
+
+(let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)]
+       [argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)]
+       [argv (and (positive? argc)
+                  (scheme_register_process_global "PLT_X11_ARGUMENTS" #f))]
+       [display (getenv "DISPLAY")])
+  ;; Convert X11 arguments, if any, to Gtk form:
+  (let-values ([(args single-instance?)
+                (if (zero? argc)
+                    (values null #f)
+                    (let loop ([i 1][si? #f])
+                      (if (= i argc) 
+                          (values null si?)
+                          (let ([s (ptr-ref argv _bytes i)])
+                            (cond
+                             [(bytes=? s #"-display")
+                              (let-values ([(args si?) (loop (+ i 2) si?)]
+                                           [(d) (ptr-ref argv _bytes (add1 i))])
+                                (set! display (bytes->string/utf-8 d #\?))
+                                (values (list* #"--display" d args)
+                                        si?))]
+                             [(bytes=? s #"-synchronous")
+                              (let-values ([(args si?) (loop (+ i 1) si?)])
+                                (values (cons #"--sync" args)
+                                        si?))]
+                             [(bytes=? s #"-singleInstance")
+                              (loop (add1 i) #t)]
+                             [(or (bytes=? s #"-iconic")
+                                  (bytes=? s #"-rv")
+                                  (bytes=? s #"+rv")
+                                  (bytes=? s #"-reverse"))
+                              ;; ignored with 0 arguments
+                              (loop (add1 i) #t)]
+                             [else
+                              ;; all other ignored flags have a single argument
+                              (loop (+ i 2) #t)])))))])
+    (let-values ([(new-argc new-argv)
+                  (if (null? args)
+                      (values 0 #f)
+                      (values (add1 (length args))
+                              (cast (cons (ptr-ref argv _bytes 0)
+                                          args)
+                                    (_list i _bytes)
+                                    _pointer)))])
+      (unless (gtk_init_check new-argc new-argv)
+        (error (format
+                "Gtk initialization failed for display ~s"
+                (or display ":0"))))
+      (when single-instance?
+        (do-single-instance)))))
+
 ;; ------------------------------------------------------------
 ;; Gtk event pump
 
-(define-gtk gtk_init (_fun _int _pointer -> _void))
-(gtk_init 0 #f)
-
 (define-gtk gtk_events_pending (_fun -> _gboolean))
 (define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean))
 

collects/mred/private/wx/gtk/unique.rkt

@@ -0,0 +1,86 @@
+#lang racket/base
+(require ffi/unsafe
+         ffi/unsafe/define
+         racket/draw/bstr
+         net/base64
+         "types.rkt"
+         "utils.rkt")
+
+(provide do-single-instance)
+
+(define unique-lib
+  (with-handlers ([exn:fail? (lambda (exn) #f)])
+    (ffi-lib "libunique-1.0" '("0"))))
+
+(define-ffi-definer define-unique unique-lib
+  #:default-make-fail make-not-available)
+
+(define _gsize _ulong)
+
+(define UNIQUE_RESPONSE_OK 1)
+
+(define _UniqueApp _GtkWidget) ; not a widget, but we want to connect a signal
+(define _UniqueMessageData (_cpointer 'UniqueMessageData))
+
+(define-unique unique_app_new (_fun _string _string -> _UniqueApp)
+  #:fail (lambda () (lambda args #f)))
+(define-unique unique_app_add_command (_fun _UniqueApp _string _int -> _void))
+(define-unique unique_app_is_running (_fun _UniqueApp -> _gboolean))
+(define-unique unique_app_send_message (_fun _UniqueApp _int _UniqueMessageData -> _int))
+
+(define-unique unique_message_data_new (_fun -> _UniqueMessageData))
+(define-unique unique_message_data_free (_fun _UniqueMessageData -> _void))
+(define-unique unique_message_data_set (_fun _UniqueMessageData _pointer _gsize -> _void))
+(define-unique unique_message_data_get (_fun _UniqueMessageData (len : (_ptr o _gsize))
+                                             -> (data : _bytes)
+                                             -> (scheme_make_sized_byte_string
+                                                 data
+                                                 len
+                                                 0)))
+
+(define-signal-handler connect-message-received "message-received"
+  (_fun _UniqueApp _int _UniqueMessageData _uint -> _int)
+  (lambda (app cmd data time)
+    UNIQUE_RESPONSE_OK))
+
+(define-mz gethostname (_fun _pointer _long -> _int)
+  #:fail (lambda () #f))
+
+(define HOSTLEN 256)
+
+(define (build-app-name)
+  (let-values ([(path) (simplify-path
+                        (path->complete-path
+                         (or (find-executable-path (find-system-path 'run-file) #f)
+                             (find-system-path 'run-file))
+                         (current-directory)))]
+               [(host) (or (and gethostname
+                                (let ([b (make-bytes HOSTLEN)])
+                                  (and (zero? (gethostname b HOSTLEN))
+                                       (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" b)) #\?))))
+                           "")])
+    (string->bytes/utf-8
+     (format "org.racket-lang.~a"
+             (encode
+              (format "~a~a~a" host path (version)))))))
+
+(define (encode s)
+  (regexp-replace* #rx"\r\n" (base64-encode (string->bytes/utf-8 s)) ""))
+
+(define (send-command-line app)
+  (let ([msg (unique_message_data_new)]
+        [b (let ([o (open-output-bytes)])
+             (write (current-command-line-arguments) o)
+             (get-output-bytes o))])
+    (unique_message_data_set msg b (bytes-length b))
+    (unique_app_send_message app 42 msg)))
+
+(define (do-single-instance)
+  (let ([app (unique_app_new (build-app-name) #f)])
+    (when app
+      (unique_app_add_command app "startup" 42)
+      (when (unique_app_is_running app)
+        (when (= (send-command-line app)
+                 UNIQUE_RESPONSE_OK)
+          (exit 0)))
+      (connect-message-received app))))

src/gracket/grmain.c

@@ -18,6 +18,11 @@ static int wx_in_terminal = 0;
 struct Scheme_Env;
 static char *get_gr_init_filename(struct Scheme_Env *env);
 
+#ifdef wx_xt
+# define PRE_FILTER_CMDLINE_ARGUMENTS
+static void pre_filter_cmdline_arguments(int *argc, char ***argv);
+#endif
+
 #define UNIX_INIT_FILENAME "~/.gracketrc"
 #define WINDOWS_INIT_FILENAME "%%HOMEDIRVE%%\\%%HOMEPATH%%\\gracketrc.rktd"
 #define MACOS9_INIT_FILENAME "PREFERENCES:gracketrc.rktd"
@@ -93,8 +98,16 @@ static void yield_indefinitely()
 #endif
 }
 
+/***********************************************************************/
+/*                        Win32 handling                               */
+/***********************************************************************/
+
 #ifdef WIN32
 
+/* ---------------------------------------- */
+/*             stdio to console             */
+/* ---------------------------------------- */
+
 static void MrEdSchemeMessages(char *, ...);
 static Scheme_Object *stdin_pipe;
 
@@ -495,6 +508,10 @@ static int parse_command_line(char ***_command, char *buf)
   return count;
 }
 
+/* ---------------------------------------- */
+/*           command-line parsing           */
+/* ---------------------------------------- */
+
 int APIENTRY WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR ignored, int nCmdShow)
 {
   LPWSTR m_lpCmdLine;
@@ -582,3 +599,86 @@ END_XFORM_SKIP;
 # endif
 
 #endif
+
+/***********************************************************************/
+/*                      X11 flag handling                              */
+/***********************************************************************/
+
+#ifdef wx_xt
+
+typedef struct {
+  char *flag;
+  int arg_count;
+} X_flag_entry;
+
+#define SINGLE_INSTANCE "-singleInstance"
+
+X_flag_entry X_flags[] = {
+  { "-display", 1 },
+  { "-geometry", 1 },
+  { "-bg", 1 },
+  { "-background", 1 },
+  { "-fg", 1 },
+  { "-foreground", 1 },
+  { "-fn", 1 },
+  { "-font", 1 },
+  { "-iconic", 0 },
+  { "-name", 1 },
+  { "-rv", 0 },
+  { "-reverse", 0 },
+  { "+rv", 0 },
+  { "-selectionTimeout", 1 },
+  { "-synchronous", 0 },
+  { "-title", 1 },
+  { "-xnllanguage", 1 },
+  { "-xrm", 1 },
+  { SINGLE_INSTANCE, 0},
+  { NULL, 0 }
+};
+
+static int filter_x_readable(char **argv, int argc)
+  XFORM_SKIP_PROC
+{
+  int pos = 1, i;
+
+  while (pos < argc) {
+    for (i = 0; X_flags[i].flag; i++) {
+      if (!strcmp(X_flags[i].flag, argv[pos]))
+	break;
+    }
+
+    if (!X_flags[i].flag)
+      return pos;
+    else {
+      int newpos = pos + X_flags[i].arg_count + 1;
+      if (newpos > argc) {
+	printf("%s: X Window System flag \"%s\" expects %d arguments, %d provided\n",
+	       argv[0], argv[pos], X_flags[i].arg_count, argc - pos - 1);
+	exit(-1);
+      }
+      pos = newpos;
+    }
+  }
+
+  return pos;
+}
+
+static void pre_filter_cmdline_arguments(int *argc, char ***argv)
+  XFORM_SKIP_PROC
+{
+  int pos;
+  char **naya;
+
+  pos = filter_x_readable(*argv, *argc);
+  if (pos > 1) {
+    scheme_register_process_global("PLT_X11_ARGUMENT_COUNT", (void *)(long)pos);
+    scheme_register_process_global("PLT_X11_ARGUMENTS", *argv);
+    naya = malloc((*argc - (pos - 1)) * sizeof(char *));
+    memcpy(naya, *argv + (pos - 1), (*argc - (pos - 1)) * sizeof(char *));
+    naya[0] = (*argv)[0];
+    *argv = naya;
+    *argc -= (pos - 1);
+  }
+}
+
+#endif

src/racket/main.c

@@ -307,37 +307,42 @@ static int main_after_stack(void *data)
 #endif
 
 #ifdef WINDOWS_UNICODE_MAIN
- {
+  {
-   char *a;
+    char *a;
-   int i, j, l;
+    int i, j, l;
-   argv = (char **)malloc(sizeof(char*)*argc);
+    argv = (char **)malloc(sizeof(char*)*argc);
-   for (i = 0; i < argc; i++) {
+    for (i = 0; i < argc; i++) {
-     for (j = 0; wargv[i][j]; j++) {
+      for (j = 0; wargv[i][j]; j++) {
-     }
+      }
-     l = scheme_utf8_encode((unsigned int*)wargv[i], 0, j, 
+      l = scheme_utf8_encode((unsigned int*)wargv[i], 0, j, 
-			    NULL, 0,
+                             NULL, 0,
-			    1 /* UTF-16 */);
+                             1 /* UTF-16 */);
-     a = malloc(l + 1);
+      a = malloc(l + 1);
-     scheme_utf8_encode((unsigned int *)wargv[i], 0, j, 
+      scheme_utf8_encode((unsigned int *)wargv[i], 0, j, 
-			(unsigned char *)a, 0,
+                         (unsigned char *)a, 0,
-			1 /* UTF-16 */);
+                         1 /* UTF-16 */);
-	 a[l] = 0;
+      a[l] = 0;
-     argv[i] = a;
+      argv[i] = a;
-   }
+    }
- }
+  }
 #endif
 
+
 #if !defined(NO_USER_BREAK_HANDLER) || defined(DOS_FILE_SYSTEM)
- break_handle = scheme_get_main_thread_break_handle();
+  break_handle = scheme_get_main_thread_break_handle();
- signal_handle = scheme_get_signal_handle();
+  signal_handle = scheme_get_signal_handle();
 # ifndef NO_USER_BREAK_HANDLER
- MZ_SIGSET(SIGINT, user_break_hit);
+  MZ_SIGSET(SIGINT, user_break_hit);
 # endif
 # ifdef DOS_FILE_SYSTEM
- SetConsoleCtrlHandler(ConsoleBreakHandler, TRUE);      
+  SetConsoleCtrlHandler(ConsoleBreakHandler, TRUE);      
 # endif
 #endif
 
+#ifdef PRE_FILTER_CMDLINE_ARGUMENTS
+  pre_filter_cmdline_arguments(&argc, &MAIN_argv);
+#endif
+
   rval = run_from_cmd_line(argc, argv, scheme_basic_env, cont_run);
 
 #ifndef DEFER_EXPLICIT_EXIT

src/racket/src/thread.c

@@ -2553,7 +2553,8 @@ void *scheme_register_process_global(const char *key, void *val)
   long len;
 
 #if defined(MZ_USE_MZRT)
-  mzrt_mutex_lock(process_global_lock);
+  if (process_global_lock)
+    mzrt_mutex_lock(process_global_lock);
 #endif
 
   for (pg = process_globals; pg; pg = pg->next) {
@@ -2575,7 +2576,8 @@ void *scheme_register_process_global(const char *key, void *val)
   }
 
 #if defined(MZ_USE_MZRT)
-  mzrt_mutex_unlock(process_global_lock);
+  if (process_global_lock)
+    mzrt_mutex_unlock(process_global_lock);
 #endif
 
   return old_val;