suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gtk: command line and single-instance support

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-17 12:01:53 -06:00
parent cd1fb5bea9
commit 045da06ace
7 changed files with 278 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/wx/common/queue.rkt
View File

@ -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:

3
collects/mred/private/wx/gtk/init.rkt
View File

@ -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))

62
collects/mred/private/wx/gtk/queue.rkt
View File

@ -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))

86
collects/mred/private/wx/gtk/unique.rkt Normal file
View File

@ -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))))

100
src/gracket/grmain.c
View File

@ -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

5
src/racket/main.c
View File

@ -327,6 +327,7 @@ static int main_after_stack(void *data)
}
#endif
#if !defined(NO_USER_BREAK_HANDLER) || defined(DOS_FILE_SYSTEM)
break_handle = scheme_get_main_thread_break_handle();
signal_handle = scheme_get_signal_handle();
@ -338,6 +339,10 @@ static int main_after_stack(void *data)
# 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

2
src/racket/src/thread.c
View File

@ -2553,6 +2553,7 @@ void *scheme_register_process_global(const char *key, void *val)
long len;
#if defined(MZ_USE_MZRT)
if (process_global_lock)
mzrt_mutex_lock(process_global_lock);
#endif
@ -2575,6 +2576,7 @@ void *scheme_register_process_global(const char *key, void *val)
}
#if defined(MZ_USE_MZRT)
if (process_global_lock)
mzrt_mutex_unlock(process_global_lock);
#endif