diff options
Diffstat (limited to 'ext/tcltklib/tcltklib.c')
-rw-r--r-- | ext/tcltklib/tcltklib.c | 362 |
1 files changed, 221 insertions, 141 deletions
diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c index 625fe61ccc..314246869e 100644 --- a/ext/tcltklib/tcltklib.c +++ b/ext/tcltklib/tcltklib.c @@ -4,22 +4,22 @@ * Oct. 24, 1997 Y. Matsumoto */ -#include "ruby.h" -#include "rubysig.h" #include <stdio.h> #include <string.h> #include <tcl.h> #include <tk.h> +#include "ruby.h" +#include "rubysig.h" #ifdef __MACOS__ # include <tkMac.h> # include <Quickdraw.h> #endif -/* for rb_debug */ +/* for ruby_debug */ -#define DUMP1(ARG1) if (rb_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);} -#define DUMP2(ARG1, ARG2) if (rb_debug) { fprintf(stderr, "tcltklib: ");\ +#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);} +#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); } /* #define DUMP1(ARG1) @@ -27,8 +27,10 @@ fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); } */ /* for callback break & continue */ -VALUE eTkCallbackBreak; -VALUE eTkCallbackContinue; +static VALUE eTkCallbackBreak; +static VALUE eTkCallbackContinue; + +static VALUE ip_invoke_real _((int, VALUE*, VALUE)); /* from tkAppInit.c */ @@ -42,51 +44,61 @@ int *tclDummyMathPtr = (int *) matherr; /*---- module TclTkLib ----*/ +struct invoke_queue { + int argc; + VALUE *argv; + VALUE obj; + int done; + VALUE result; + VALUE thread; + struct invoke_queue *next; +}; + +static struct invoke_queue *iqueue; +static VALUE main_thread; + /* Tk_ThreadTimer */ -typedef struct { - Tcl_TimerToken token; - int flag; -} Tk_TimerData; +static Tcl_TimerToken timer_token; /* timer callback */ -void _timer_for_tcl (ClientData clientData) +static void +_timer_for_tcl(clientData) + ClientData clientData; { - Tk_TimerData *timer = (Tk_TimerData*)clientData; + struct invoke_queue *q, *tmp; + VALUE thread; - timer->flag = 0; - CHECK_INTS; -#ifdef USE_THREAD - if (!rb_thread_critical) rb_thread_schedule(); -#endif + Tk_DeleteTimerHandler(timer_token); + timer_token = Tk_CreateTimerHandler(100, _timer_for_tcl, + (ClientData)0); - timer->token = Tk_CreateTimerHandler(200, _timer_for_tcl, - (ClientData)timer); - timer->flag = 1; + CHECK_INTS; + q = iqueue; + while (q) { + tmp = q; + q = q->next; + if (!tmp->done) { + tmp->done = 1; + tmp->result = ip_invoke_real(tmp->argc, tmp->argv, tmp->obj); + thread = tmp->thread; + tmp = tmp->next; + rb_thread_run(thread); + } + } + rb_thread_schedule(); } /* execute Tk_MainLoop */ static VALUE -lib_mainloop(VALUE self) +lib_mainloop(self) + VALUE self; { - Tk_TimerData *timer; - - timer = (Tk_TimerData *) ckalloc(sizeof(Tk_TimerData)); - timer->flag = 0; - timer->token = Tk_CreateTimerHandler(200, _timer_for_tcl, - (ClientData)timer); - timer->flag = 1; - + timer_token = Tk_CreateTimerHandler(100, _timer_for_tcl, + (ClientData)0); DUMP1("start Tk_Mainloop"); - while (Tk_GetNumMainWindows() > 0) { - Tcl_DoOneEvent(0); - } + Tk_MainLoop(); DUMP1("stop Tk_Mainloop"); - -#ifdef USE_THREAD - if (timer->flag) { - Tk_DeleteTimerHandler(timer->token); - } -#endif + Tk_DeleteTimerHandler(timer_token); return Qnil; } @@ -99,7 +111,9 @@ struct tcltkip { /* Tcl command `ruby' */ static VALUE -ip_eval_rescue(VALUE *failed, VALUE einfo) +ip_eval_rescue(failed, einfo) + VALUE *failed; + VALUE einfo; { *failed = einfo; return Qnil; @@ -107,10 +121,17 @@ ip_eval_rescue(VALUE *failed, VALUE einfo) static int #if TCL_MAJOR_VERSION >= 8 -ip_ruby(ClientData clientData, Tcl_Interp *interp, - int argc, Tcl_Obj *CONST argv[]) +ip_ruby(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + Tcl_Obj *CONST argv[]; #else -ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) +ip_ruby(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char *argv[]; #endif { VALUE res; @@ -143,11 +164,11 @@ ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) VALUE eclass = CLASS_OF(failed); Tcl_AppendResult(interp, STR2CSTR(failed), (char*)NULL); if (eclass == eTkCallbackBreak) { - return TCL_BREAK; + return TCL_BREAK; } else if (eclass == eTkCallbackContinue) { - return TCL_CONTINUE; + return TCL_CONTINUE; } else { - return TCL_ERROR; + return TCL_ERROR; } } @@ -167,7 +188,8 @@ ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) /* destroy interpreter */ static void -ip_free(struct tcltkip *ptr) +ip_free(ptr) + struct tcltkip *ptr; { DUMP1("Tcl_DeleteInterp"); Tcl_DeleteInterp(ptr->ip); @@ -176,7 +198,8 @@ ip_free(struct tcltkip *ptr) /* create and initialize interpreter */ static VALUE -ip_new(VALUE self) +ip_new(self) + VALUE self; { struct tcltkip *ptr; /* tcltkip data struct */ VALUE obj; /* newly created object */ @@ -192,11 +215,11 @@ ip_new(VALUE self) /* from Tcl_AppInit() */ DUMP1("Tcl_Init"); if (Tcl_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "Tcl_Init"); + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); } DUMP1("Tk_Init"); if (Tk_Init(ptr->ip) == TCL_ERROR) { - rb_raise(rb_eRuntimeError, "Tk_Init"); + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); } DUMP1("Tcl_StaticPackage(\"Tk\")"); Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, @@ -218,7 +241,9 @@ ip_new(VALUE self) /* eval string in tcl by Tcl_Eval() */ static VALUE -ip_eval(VALUE self, VALUE str) +ip_eval(self, str) + VALUE self; + VALUE str; { char *s; char *buf; /* Tcl_Eval requires re-writable string region */ @@ -234,7 +259,7 @@ ip_eval(VALUE self, VALUE str) DUMP2("Tcl_Eval(%s)", buf); ptr->return_value = Tcl_Eval(ptr->ip, buf); if (ptr->return_value == TCL_ERROR) { - rb_raise(rb_eRuntimeError, ptr->ip->result); + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); } DUMP2("(TCL_Eval result) %d", ptr->return_value); @@ -244,76 +269,77 @@ ip_eval(VALUE self, VALUE str) static VALUE -ip_toUTF8(VALUE self, VALUE str, VALUE encodename) +ip_toUTF8(self, str, encodename) + VALUE self; + VALUE str; + VALUE encodename; { -#ifndef TCL_UTF_MAX - return str; -#else - Tcl_Interp *interp; - Tcl_Encoding encoding; - Tcl_DString dstr; - struct tcltkip *ptr; - char *buff1,*buff2; - - Data_Get_Struct(self,struct tcltkip, ptr); - interp = ptr->ip; - - encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename)); - buff1 = ALLOCA_N(char,strlen(STR2CSTR(str))+1); - strcpy(buff1,STR2CSTR(str)); - - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - Tcl_ExternalToUtfDString(encoding,buff1,strlen(buff1),&dstr); - buff2 = ALLOCA_N(char,Tcl_DStringLength(&dstr)+1); - strcpy(buff2,Tcl_DStringValue(&dstr)); - - Tcl_FreeEncoding(encoding); - Tcl_DStringFree(&dstr); - - return rb_str_new2(buff2); +#ifdef TCL_UTF_MAX + Tcl_Interp *interp; + Tcl_Encoding encoding; + Tcl_DString dstr; + struct tcltkip *ptr; + char *buf; + + Data_Get_Struct(self,struct tcltkip, ptr); + interp = ptr->ip; + + encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename)); + buf = ALLOCA_N(char,strlen(STR2CSTR(str))+1); + strcpy(buf,STR2CSTR(str)); + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); + str = rb_str_new2(Tcl_DStringValue(&dstr)); + + Tcl_FreeEncoding(encoding); + Tcl_DStringFree(&dstr); #endif + return str; } static VALUE -ip_fromUTF8(VALUE self, VALUE str, VALUE encodename) +ip_fromUTF8(self, str, encodename) + VALUE self; + VALUE str; + VALUE encodename; { -#ifndef TCL_UTF_MAX - return str; -#else - Tcl_Interp *interp; - Tcl_Encoding encoding; - Tcl_DString dstr; - struct tcltkip *ptr; - char *buff1,*buff2; +#ifdef TCL_UTF_MAX + Tcl_Interp *interp; + Tcl_Encoding encoding; + Tcl_DString dstr; + struct tcltkip *ptr; + char *buf; - Data_Get_Struct(self,struct tcltkip, ptr); - interp = ptr->ip; + Data_Get_Struct(self,struct tcltkip, ptr); + interp = ptr->ip; - encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename)); - buff1 = ALLOCA_N(char,strlen(STR2CSTR(str))+1); - strcpy(buff1,STR2CSTR(str)); + encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename)); + buf = ALLOCA_N(char,strlen(STR2CSTR(str))+1); + strcpy(buf,STR2CSTR(str)); - Tcl_DStringInit(&dstr); - Tcl_DStringFree(&dstr); - Tcl_UtfToExternalDString(encoding,buff1,strlen(buff1),&dstr); - buff2 = ALLOCA_N(char,Tcl_DStringLength(&dstr)+1); - strcpy(buff2,Tcl_DStringValue(&dstr)); + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); + str = rb_str_new2(Tcl_DStringValue(&dstr)); - Tcl_FreeEncoding(encoding); - Tcl_DStringFree(&dstr); + Tcl_FreeEncoding(encoding); + Tcl_DStringFree(&dstr); - return rb_str_new2(buff2); #endif + return str; } static VALUE -ip_invoke(int argc, VALUE *argv, VALUE obj) +ip_invoke_real(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; { struct tcltkip *ptr; /* tcltkip data struct */ int i; - int object = 0; Tcl_CmdInfo info; char *cmd; char **av = (char **)NULL; @@ -332,63 +358,115 @@ ip_invoke(int argc, VALUE *argv, VALUE obj) if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { rb_raise(rb_eNameError, "invalid command name `%s'", cmd); } -#if TCL_MAJOR_VERSION >= 8 - object = info.isNativeObjectProc; -#endif /* memory allocation for arguments of this command */ - if (object) { #if TCL_MAJOR_VERSION >= 8 - /* object interface */ - ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1); - for (i = 0; i < argc; ++i) { - char *s = STR2CSTR(argv[i]); - ov[i] = Tcl_NewStringObj(s, strlen(s)); - } - ov[argc] = (Tcl_Obj *)NULL; + if (info.isNativeObjectProc) { + /* object interface */ + ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1); + for (i = 0; i < argc; ++i) { + char *s = STR2CSTR(argv[i]); + ov[i] = Tcl_NewStringObj(s, strlen(s)); + Tcl_IncrRefCount(ov[i]); + } + ov[argc] = (Tcl_Obj *)NULL; + } + else #endif - } else { + { /* string interface */ - av = (char **)ALLOCA_N(char *, argc+1); - for (i = 0; i < argc; ++i) { - char *s = STR2CSTR(argv[i]); - - av[i] = ALLOCA_N(char, strlen(s)+1); - strcpy(av[i], s); - } - av[argc] = (char *)NULL; + av = (char **)ALLOCA_N(char *, argc+1); + for (i = 0; i < argc; ++i) { + char *s = STR2CSTR(argv[i]); + + av[i] = ALLOCA_N(char, strlen(s)+1); + strcpy(av[i], s); + } + av[argc] = (char *)NULL; } Tcl_ResetResult(ptr->ip); /* Invoke the C procedure */ - if (object) { #if TCL_MAJOR_VERSION >= 8 - int dummy; - ptr->return_value = (*info.objProc)(info.objClientData, - ptr->ip, argc, ov); - - /* get the string value from the result object */ - resultPtr = Tcl_GetObjResult(ptr->ip); - Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy), - TCL_VOLATILE); + if (info.isNativeObjectProc) { + int dummy; + ptr->return_value = (*info.objProc)(info.objClientData, + ptr->ip, argc, ov); + + /* get the string value from the result object */ + resultPtr = Tcl_GetObjResult(ptr->ip); + Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy), + TCL_VOLATILE); + + for (i=0; i<argc; i++) { + Tcl_DecrRefCount(ov[i]); + } + } + else #endif - } else { - ptr->return_value = (*info.proc)(info.clientData, - ptr->ip, argc, av); + { + ptr->return_value = (*info.proc)(info.clientData, + ptr->ip, argc, av); } if (ptr->return_value == TCL_ERROR) { - rb_raise(rb_eRuntimeError, ptr->ip->result); + rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); } /* pass back the result (as string) */ - return(rb_str_new2(ptr->ip->result)); + return rb_str_new2(ptr->ip->result); +} + +static VALUE +ip_invoke(argc, argv, obj) + int argc; + VALUE *argv; + VALUE obj; +{ + struct invoke_queue *tmp, *p; + VALUE result = rb_thread_current(); + + if (result == main_thread) { + return ip_invoke_real(argc, argv, obj); + } + tmp = ALLOC(struct invoke_queue); + tmp->obj = obj; + tmp->argc = argc; + tmp->argv = ALLOC_N(VALUE, argc); + MEMCPY(tmp->argv, argv, VALUE, argc); + tmp->thread = result; + tmp->done = 0; + + tmp->next = iqueue; + iqueue = tmp; + + rb_thread_stop(); + result = tmp->result; + if (iqueue == tmp) { + iqueue = tmp->next; + free(tmp->argv); + free(tmp); + return result; + } + + p = iqueue; + while (p->next) { + if (p->next == tmp) { + p->next = tmp->next; + free(tmp->argv); + free(tmp); + break; + } + p = p->next; + } + return result; } /* get return code from Tcl_Eval() */ static VALUE -ip_retval(VALUE self) +ip_retval(self) + VALUE self; { struct tcltkip *ptr; /* tcltkip data struct */ @@ -402,13 +480,14 @@ ip_retval(VALUE self) static void _macinit() { - tcl_macQdPtr = &qd; /* setup QuickDraw globals */ - Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */ + tcl_macQdPtr = &qd; /* setup QuickDraw globals */ + Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */ } #endif /*---- initialization ----*/ -void Init_tcltklib() +void +Init_tcltklib() { extern VALUE rb_argv0; /* the argv[0] */ @@ -428,6 +507,7 @@ void Init_tcltklib() rb_define_method(ip, "_return_value", ip_retval, 0); rb_define_method(ip, "mainloop", lib_mainloop, 0); + main_thread = rb_thread_current(); #ifdef __MACOS__ _macinit(); #endif |