summaryrefslogtreecommitdiff
path: root/ext/tcltklib/tcltklib.c
diff options
context:
space:
mode:
Diffstat (limited to 'ext/tcltklib/tcltklib.c')
-rw-r--r--ext/tcltklib/tcltklib.c362
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-27 13:34:04 +0000