diff options
Diffstat (limited to 'ext/tk/tcltklib.c')
-rw-r--r-- | ext/tk/tcltklib.c | 351 |
1 files changed, 313 insertions, 38 deletions
diff --git a/ext/tk/tcltklib.c b/ext/tk/tcltklib.c index d963f9231a..baa28c9640 100644 --- a/ext/tk/tcltklib.c +++ b/ext/tk/tcltklib.c @@ -4,7 +4,7 @@ * Oct. 24, 1997 Y. Matsumoto */ -#define TCLTKLIB_RELEASE_DATE "2006-12-01" +#define TCLTKLIB_RELEASE_DATE "2007-12-21" #include "ruby/ruby.h" #include "ruby/signal.h" @@ -312,6 +312,7 @@ call_queue_mark(struct call_queue *q) static VALUE eventloop_thread; static VALUE eventloop_stack; +static int window_event_mode = ~(TCL_WINDOW_EVENTS | TCL_IDLE_EVENTS); static VALUE watchdog_thread; @@ -565,6 +566,9 @@ struct tcltkip { #if TCL_NAMESPACE_DEBUG Tcl_Namespace *default_ns; /* default namespace */ #endif +#ifdef RUBY_VM + Tcl_ThreadId tk_thread_id; /* default namespace */ +#endif int has_orig_exit; /* has original 'exit' command ? */ Tcl_CmdInfo orig_exit_info; /* command info of original 'exit' command */ int ref_count; /* reference count of rbtk_preserve_ip call */ @@ -755,6 +759,10 @@ tcltkip_init_tk(interp) } #endif +#ifdef RUBY_VM + ptr->tk_thread_id = Tcl_GetCurrentThread(); +#endif + return Qnil; } @@ -862,7 +870,8 @@ call_original_exit(ptr, state) if (info->isNativeObjectProc) { Tcl_Obj **argv; - argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); + // argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); /* XXXXXXXXXX */ + argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3); argv[0] = Tcl_NewStringObj("exit", 4); argv[1] = state_obj; argv[2] = (Tcl_Obj *)NULL; @@ -875,7 +884,8 @@ call_original_exit(ptr, state) } else { /* string interface */ char **argv; - argv = (char **)ALLOC_N(char *, 3); + //argv = (char **)ALLOC_N(char *, 3); /* XXXXXXXXXX */ + argv = (char **)ckalloc(sizeof(char *) * 3); argv[0] = "exit"; /* argv[1] = Tcl_GetString(state_obj); */ argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL); @@ -944,6 +954,34 @@ _timer_for_tcl(clientData) /* tick_counter += event_loop_max; */ } + +static VALUE +set_eventloop_window_mode(self, mode) + VALUE self; + VALUE mode; +{ + rb_secure(4); + + if (RTEST(mode)) { + window_event_mode = ~0; + } else { + window_event_mode = ~(TCL_WINDOW_EVENTS | TCL_IDLE_EVENTS); + } + + return mode; +} + +static VALUE +get_eventloop_window_mode(self) + VALUE self; +{ + if ( ~window_event_mode ) { + return Qfalse; + } else { + return Qtrue; + } +} + static VALUE set_eventloop_tick(self, tick) VALUE self; @@ -1258,19 +1296,25 @@ eventloop_sleep(dummy) t.tv_sec = (time_t)0; t.tv_usec = (time_t)(no_event_wait*1000.0); +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on eventloop_sleep()"); } #endif +#endif + DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %lx", rb_thread_current()); rb_thread_wait_for(t); + DUMP2("eventloop_sleep: finish at thread : %lx", rb_thread_current()); +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on eventloop_sleep()"); } #endif +#endif return Qnil; } @@ -1310,14 +1354,19 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) } for(;;) { +#ifdef RUBY_VM + if (0) { +#else if (rb_thread_alone()) { +#endif DUMP1("no other thread"); event_loop_wait_event = 0; if (update_flag) { event_flag = update_flag | TCL_DONT_WAIT; /* for safety */ } else { - event_flag = TCL_ALL_EVENTS; + // event_flag = TCL_ALL_EVENTS; + event_flag = TCL_FILE_EVENTS | TCL_TIMER_EVENTS | TCL_DONT_WAIT; } if (timer_tick == 0 && update_flag == 0) { @@ -1457,10 +1506,20 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) if (NIL_P(eventloop_thread) || current == eventloop_thread) { int st; int status; - +#ifdef RUBY_VM + if (update_flag) { + st = RTEST(rb_protect(call_DoOneEvent, + INT2FIX(event_flag), &status)); + } else { + st = RTEST(rb_protect(call_DoOneEvent, + INT2FIX(event_flag & window_event_mode), + &status)); + } +#else /* st = Tcl_DoOneEvent(event_flag); */ st = RTEST(rb_protect(call_DoOneEvent, INT2FIX(event_flag), &status)); +#endif if (status) { switch (status) { case TAG_RAISE: @@ -1531,7 +1590,9 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) tick_counter += no_event_tick; /* rb_thread_wait_for(t); */ +#if 0 rb_protect(eventloop_sleep, Qnil, &status); +#endif if (status) { switch (status) { @@ -1614,6 +1675,9 @@ lib_eventloop_core(check_root, update_flag, check_var, interp) break; /* switch to other thread */ } } + + DUMP1("thread scheduling"); + rb_thread_schedule(); } DUMP1("trap check & thread scheduling"); @@ -2004,9 +2068,11 @@ lib_thread_callback(argc, argv, self) proc = rb_block_proc(); } - q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); + //q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); + q = (struct thread_call_proc_arg *)ckalloc(sizeof(struct thread_call_proc_arg)); q->proc = proc; - q->done = (int*)ALLOC(int); + //q->done = (int*)ALLOC(int); + q->done = (int*)ckalloc(sizeof(int)); *(q->done) = 0; /* create call-proc thread */ @@ -2025,8 +2091,10 @@ lib_thread_callback(argc, argv, self) ret = rb_protect(_thread_call_proc_value, th, &status); } - free(q->done); - free(q); + //free(q->done); + //free(q); + ckfree((char*)q->done); + ckfree((char*)q); if (NIL_P(rbtk_pending_exception)) { /* return rb_errinfo(); */ @@ -2157,7 +2225,8 @@ ip_set_exc_message(interp, exc) } /* to avoid a garbled error message dialog */ - buf = ALLOC_N(char, (RSTRING_LEN(msg))+1); + // buf = ALLOC_N(char, (RSTRING_LEN(msg))+1); + buf = ckalloc(sizeof(char)*((RSTRING_LEN(msg))+1)); memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg)); buf[RSTRING_LEN(msg)] = 0; @@ -2168,7 +2237,8 @@ ip_set_exc_message(interp, exc) Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL); DUMP2("error message:%s", Tcl_DStringValue(&dstr)); Tcl_DStringFree(&dstr); - free(buf); + //free(buf); + ckfree(buf); #else /* TCL_VERSION <= 8.0 */ Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL); @@ -2385,11 +2455,13 @@ tcl_protect(interp, proc, data) int old_trapflag = rb_trap_immediate; int code; +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on tcl_protect()"); } #endif +#endif rb_trap_immediate = 0; code = tcl_protect_core(interp, proc, data); @@ -2792,11 +2864,13 @@ ip_rbUpdateCommand(clientData, interp, objc, objv) "IP is deleted"); return TCL_ERROR; } +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on ip_ruby_eval()"); } #endif +#endif if (objc == 1) { flags = TCL_DONT_WAIT; @@ -2939,11 +3013,13 @@ ip_rb_threadUpdateCommand(clientData, interp, objc, objv) "IP is deleted"); return TCL_ERROR; } +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on ip_ruby_eval()"); } #endif +#endif if (rb_thread_alone() || NIL_P(eventloop_thread) || eventloop_thread == current_thread) { @@ -3116,11 +3192,13 @@ ip_rbVwaitCommand(clientData, interp, objc, objv) #endif Tcl_Preserve(interp); +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on ip_ruby_eval()"); } #endif +#endif if (objc != 2) { #ifdef Tcl_WrongNumArgs @@ -4754,6 +4832,9 @@ ip_init(argc, argv, self) Data_Get_Struct(self, struct tcltkip, ptr); ptr = ALLOC(struct tcltkip); DATA_PTR(self) = ptr; +#ifdef RUBY_VM + ptr->tk_thread_id = 0; +#endif ptr->ref_count = 0; ptr->allow_ruby_exit = 1; ptr->return_value = 0; @@ -4861,6 +4942,9 @@ ip_init(argc, argv, self) (Tcl_PackageInitProc *) NULL); #endif +#ifdef RUBY_VM + ptr->tk_thread_id = Tcl_GetCurrentThread(); +#endif /* get main window */ mainWin = Tk_MainWindow(ptr->ip); Tk_Preserve((ClientData)mainWin); @@ -4924,7 +5008,7 @@ ip_init(argc, argv, self) if (mainWin != (Tk_Window)NULL) { Tk_Release((ClientData)mainWin); } - + return self; } @@ -5388,7 +5472,9 @@ get_str_from_obj(obj) #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 s = Tcl_GetStringFromObj(obj, &len); -#else /* TCL_VERSION >= 8.1 */ +#else +#if 0 + /* TCL_VERSION >= 8.1 */ if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { /* possibly binary string */ s = Tcl_GetByteArrayFromObj(obj, &len); @@ -5397,6 +5483,26 @@ get_str_from_obj(obj) /* possibly text string */ s = Tcl_GetStringFromObj(obj, &len); } +#else +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 + if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { + /* possibly binary string */ + s = Tcl_GetByteArrayFromObj(obj, &len); + binary = 1; + } else { + /* possibly text string */ + s = Tcl_GetStringFromObj(obj, &len); + } +#else /* TCL_VERSION >= 8.5 */ + /* TODO: Known BUG: + Tcl_GetByteArrayFromObj() returns "alloc: invalid block" */ + if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { + /* possibly binary string */ + binary = 1; + } + s = Tcl_GetStringFromObj(obj, &len); +#endif +#endif #endif str = s ? rb_str_new(s, len) : rb_str_new2(""); if (binary) rb_ivar_set(str, ID_at_enc, rb_str_new2("binary")); @@ -5446,6 +5552,7 @@ ip_get_result_string_obj(interp) Tcl_IncrRefCount(retObj); strval = get_str_from_obj(retObj); OBJ_TAINT(strval); + Tcl_ResetResult(interp); Tcl_DecrRefCount(retObj); return strval; #else @@ -5479,7 +5586,7 @@ call_queue_handler(evPtr, flags) struct tcltkip *ptr; DUMP2("do_call_queue_handler : evPtr = %p", evPtr); - DUMP2("queue_handler thread : %lx", rb_thread_current()); + DUMP2("call_queue_handler thread : %lx", rb_thread_current()); DUMP2("added by thread : %lx", q->thread); if (*(q->done)) { @@ -5541,6 +5648,9 @@ tk_funcall(func, argc, argv, obj) VALUE obj; { struct call_queue *callq; +#ifdef RUBY_VM + struct tcltkip *ptr; +#endif int *alloc_done; int thr_crit_bup; volatile VALUE current = rb_thread_current(); @@ -5553,7 +5663,17 @@ tk_funcall(func, argc, argv, obj) return Qnil; } - if (NIL_P(eventloop_thread) || current == eventloop_thread) { +#ifdef RUBY_VM + ptr = get_ip(ip_obj); +#endif + + if ( +#ifdef RUBY_VM + (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) + && +#endif + (NIL_P(eventloop_thread) || current == eventloop_thread) + ) { if (NIL_P(eventloop_thread)) { DUMP2("tk_funcall from thread:%lx but no eventloop", current); } else { @@ -5602,14 +5722,25 @@ tk_funcall(func, argc, argv, obj) /* add the handler to Tcl event queue */ DUMP1("add handler"); +#ifdef RUBY_VM + if (ptr->tk_thread_id) { + Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(callq->ev), TCL_QUEUE_HEAD); + Tcl_ThreadAlert(ptr->tk_thread_id); + } else { + Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); + } +#else Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); +#endif rb_thread_critical = thr_crit_bup; /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { + DUMP2("*** wait for handler (current thread:%lx)", current); rb_thread_stop(); + DUMP2("*** wakeup (current thread:%lx)", current); } DUMP2("back from handler (current thread:%lx)", current); @@ -5806,6 +5937,11 @@ eval_queue_handler(evPtr, flags) struct eval_queue *q = (struct eval_queue *)evPtr; volatile VALUE ret; volatile VALUE q_dat; + struct tcltkip *ptr; + + DUMP2("do_eval_queue_handler : evPtr = %p", evPtr); + DUMP2("eval_queue_thread : %lx", rb_thread_current()); + DUMP2("added by thread : %lx", q->thread); if (*(q->done)) { DUMP1("processed by another event-loop"); @@ -5817,13 +5953,22 @@ eval_queue_handler(evPtr, flags) /* process it */ *(q->done) = 1; + /* deleted ipterp ? */ + ptr = get_ip(q->interp); + if (deleted_ip(ptr)) { + /* deleted IP --> ignore */ + return 1; + } + /* check safe-level */ if (rb_safe_level() != q->safe_level) { +#if 0 #ifdef HAVE_NATIVETHREAD if (!is_ruby_native_thread()) { rb_bug("cross-thread violation on eval_queue_handler()"); } #endif +#endif /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,0,q); ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), @@ -5860,6 +6005,9 @@ ip_eval(self, str) VALUE str; { struct eval_queue *evq; +#ifdef RUBY_VM + struct tcltkip *ptr; +#endif char *eval_str; int *alloc_done; int thr_crit_bup; @@ -5874,7 +6022,17 @@ ip_eval(self, str) StringValue(str); rb_thread_critical = thr_crit_bup; - if (NIL_P(eventloop_thread) || current == eventloop_thread) { +#ifdef RUBY_VM + ptr = get_ip(ip_obj); +#endif + + if ( +#ifdef RUBY_VM + (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) + && +#endif + (NIL_P(eventloop_thread) || current == eventloop_thread) + ) { if (NIL_P(eventloop_thread)) { DUMP2("eval from thread:%lx but no eventloop", current); } else { @@ -5921,14 +6079,25 @@ ip_eval(self, str) /* add the handler to Tcl event queue */ DUMP1("add handler"); +#ifdef RUBY_VM + if (ptr->tk_thread_id) { + Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); + Tcl_ThreadAlert(ptr->tk_thread_id); + } else { + Tcl_QueueEvent(&(evq->ev), position); + } +#else Tcl_QueueEvent(&(evq->ev), position); +#endif rb_thread_critical = thr_crit_bup; /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { + DUMP2("*** wait for handler (current thread:%lx)", current); rb_thread_stop(); + DUMP2("*** wakeup (current thread:%lx)", current); } DUMP2("back from handler (current thread:%lx)", current); @@ -6492,7 +6661,8 @@ invoke_tcl_proc(arg) #if TCL_MAJOR_VERSION >= 8 if (!inf->cmdinfo.isNativeObjectProc) { /* string interface */ - argv = (char **)ALLOC_N(char *, argc+1); + // argv = (char **)ALLOC_N(char *, argc+1); /* XXXXXXXXXX */ + argv = (char **)ckalloc(sizeof(char *)*(argc+1)); for (i = 0; i < argc; ++i) { argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len); } @@ -6505,6 +6675,7 @@ invoke_tcl_proc(arg) /* Invoke the C procedure */ #if TCL_MAJOR_VERSION >= 8 if (inf->cmdinfo.isNativeObjectProc) { + int ret_val; inf->ptr->return_value = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData, inf->ptr->ip, inf->objc, inf->objv); @@ -6517,7 +6688,8 @@ invoke_tcl_proc(arg) = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, argc, (CONST84 char **)argv); - free(argv); + //free(argv); + ckfree((char*)argv); #else /* TCL_MAJOR_VERSION < 8 */ inf->ptr->return_value @@ -6563,6 +6735,9 @@ ip_invoke_core(interp, argc, argv) #endif #endif + /* get the data struct */ + ptr = get_ip(interp); + /* get the command name string */ #if TCL_MAJOR_VERSION >= 8 cmd = Tcl_GetStringFromObj(objv[0], &len); @@ -6570,9 +6745,6 @@ ip_invoke_core(interp, argc, argv) cmd = argv[0]; #endif - /* get the data struct */ - ptr = get_ip(interp); - /* ip is deleted? */ if (deleted_ip(ptr)) { return rb_tainted_str_new2(""); @@ -6622,7 +6794,8 @@ ip_invoke_core(interp, argc, argv) unknown_flag = 1; #if TCL_MAJOR_VERSION >= 8 - unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); + //unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); + unknown_objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc+2)); unknown_objv[0] = Tcl_NewStringObj("::unknown", 9); Tcl_IncrRefCount(unknown_objv[0]); memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc); @@ -6642,7 +6815,6 @@ ip_invoke_core(interp, argc, argv) thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; - #if 1 /* wrap tcl-proc call */ /* setup params */ inf.ptr = ptr; @@ -6683,7 +6855,8 @@ ip_invoke_core(interp, argc, argv) int i; /* string interface */ - argv = (char **)ALLOC_N(char *, argc+1); + //argv = (char **)ALLOC_N(char *, argc+1); + argv = (char **)ckalloc(sizeof(char *) * (argc+1)); for (i = 0; i < argc; ++i) { argv[i] = Tcl_GetStringFromObj(objv[i], &len); } @@ -6712,7 +6885,8 @@ ip_invoke_core(interp, argc, argv) ptr->return_value = (*info.proc)(info.clientData, ptr->ip, argc, (CONST84 char **)argv); - free(argv); + //free(argv); + ckfree(argv); #else /* TCL_MAJOR_VERSION < 8 */ ptr->return_value = (*info.proc)(info.clientData, ptr->ip, @@ -6783,7 +6957,8 @@ alloc_invoke_arguments(argc, argv) /* memory allocation */ #if TCL_MAJOR_VERSION >= 8 - av = ALLOC_N(Tcl_Obj *, argc+1); + //av = ALLOC_N(Tcl_Obj *, argc+1); /* XXXXXXXXXX */ + av = (Tcl_Obj**)ckalloc(sizeof(Tcl_Obj *)*(argc+1)); for (i = 0; i < argc; ++i) { av[i] = get_obj_from_str(argv[i]); Tcl_IncrRefCount(av[i]); @@ -6822,7 +6997,11 @@ free_invoke_arguments(argc, av) free(av[i]); #endif } +#if TCL_MAJOR_VERSION >= 8 + ckfree((char*)av); +#else /* TCL_MAJOR_VERSION < 8 */ free(av); +#endif } static VALUE @@ -6942,6 +7121,9 @@ ip_invoke_with_position(argc, argv, obj, position) Tcl_QueuePosition position; { struct invoke_queue *ivq; +#ifdef RUBY_VM + struct tcltkip *ptr; +#endif int *alloc_done; int thr_crit_bup; volatile VALUE current = rb_thread_current(); @@ -6958,7 +7140,21 @@ ip_invoke_with_position(argc, argv, obj, position) if (argc < 1) { rb_raise(rb_eArgError, "command name missing"); } - if (NIL_P(eventloop_thread) || current == eventloop_thread) { + +#ifdef RUBY_VM + ptr = get_ip(ip_obj); +#endif + DUMP2("status: ptr->tk_thread_id %d", ptr->tk_thread_id); + DUMP2("status: Tcl_GetCurrentThread %d", Tcl_GetCurrentThread()); + DUMP2("status: eventloopt_thread %lx", eventloop_thread); + + if ( +#ifdef RUBY_VM + (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) + && +#endif + (NIL_P(eventloop_thread) || current == eventloop_thread) + ) { if (NIL_P(eventloop_thread)) { DUMP2("invoke from thread:%lx but no eventloop", current); } else { @@ -6971,8 +7167,6 @@ ip_invoke_with_position(argc, argv, obj, position) return result; } - DUMP2("invoke from thread %lx (NOT current eventloop)", current); - thr_crit_bup = rb_thread_critical; rb_thread_critical = Qtrue; @@ -6980,11 +7174,12 @@ ip_invoke_with_position(argc, argv, obj, position) av = alloc_invoke_arguments(argc, argv); /* allocate memory (keep result) */ - alloc_done = (int*)ALLOC(int); + //alloc_done = (int*)ALLOC(int); + alloc_done = (int*)ckalloc(sizeof(int)); *alloc_done = 0; /* allocate memory (freed by Tcl_ServiceEvent) */ - ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); + ivq = (struct invoke_queue *)ckalloc(sizeof(struct invoke_queue)); Tcl_Preserve(ivq); /* allocate result obj */ @@ -7002,20 +7197,30 @@ ip_invoke_with_position(argc, argv, obj, position) /* add the handler to Tcl event queue */ DUMP1("add handler"); +#ifdef RUBY_VM + if (ptr->tk_thread_id) { + Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); + Tcl_ThreadAlert(ptr->tk_thread_id); + } else { + Tcl_QueueEvent(&(ivq->ev), position); + } +#else Tcl_QueueEvent(&(ivq->ev), position); +#endif rb_thread_critical = thr_crit_bup; /* wait for the handler to be processed */ DUMP2("wait for handler (current thread:%lx)", current); while(*alloc_done >= 0) { - rb_thread_stop(); + rb_thread_stop(); } DUMP2("back from handler (current thread:%lx)", current); /* get result & free allocated memory */ ret = RARRAY_PTR(result)[0]; - free(alloc_done); + //free(alloc_done); + ckfree((char*)alloc_done); Tcl_Release(ivq); @@ -7028,7 +7233,6 @@ ip_invoke_with_position(argc, argv, obj, position) rb_exc_raise(ret); } - DUMP1("exit ip_invoke"); return ret; } @@ -7645,7 +7849,7 @@ lib_merge_tklist(argc, argv, obj) } /* pass 2 */ - result = (char *)Tcl_Alloc(len); + result = (char *)ckalloc(len); dst = result; for(num = 0; num < argc; num++) { #if TCL_MAJOR_VERSION >= 8 @@ -7670,7 +7874,7 @@ lib_merge_tklist(argc, argv, obj) /* create object */ str = rb_str_new(result, dst - result - 1); if (taint_flag) OBJ_TAINT(str); - Tcl_Free(result); + ckfree(result); if (old_gc == Qfalse) rb_gc_enable(); rb_thread_critical = thr_crit_bup; @@ -7717,6 +7921,35 @@ lib_conv_listelement(self, src) static VALUE +lib_getversion(self) + VALUE self; +{ + int major, minor, patchlevel, type; + volatile VALUE type_name; + + Tcl_GetVersion(&major, &minor, &patchlevel, &type); + + switch(type) { + case TCL_ALPHA_RELEASE: + type_name = rb_str_new2("alpha"); + break; + case TCL_BETA_RELEASE: + type_name = rb_str_new2("beta"); + break; + case TCL_FINAL_RELEASE: + type_name = rb_str_new2("final"); + break; + default: + type_name = rb_str_new2("unknown"); + } + + return rb_ary_new3(5, INT2NUM(major), INT2NUM(minor), + INT2NUM(type), type_name, + INT2NUM(patchlevel)); +} + + +static VALUE tcltklib_compile_info() { volatile VALUE ret; @@ -7780,7 +8013,7 @@ tcltklib_compile_info() /* * The following is based on tkMenu.[ch] - * of Tcl/Tk (>=8.0) source code. + * of Tcl/Tk (Tk8.0 -- Tk8.5b1) source code. */ #if TCL_MAJOR_VERSION >= 8 @@ -7814,7 +8047,11 @@ struct dummy_TkMenuRef { char *dummy3; }; +#if 0 EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*); +#else +#define MENU_HASH_KEY "tkMenus" /* based on Tk8.0 - Tk8.5b1 */ +#endif #endif @@ -7825,11 +8062,27 @@ ip_make_menu_embeddable(interp, menu_path) { #if TCL_MAJOR_VERSION >= 8 struct tcltkip *ptr = get_ip(interp); - struct dummy_TkMenuRef *menuRefPtr; + struct dummy_TkMenuRef *menuRefPtr = NULL; + XEvent event; + Tcl_HashTable *menuTablePtr; + Tcl_HashEntry *hashEntryPtr; StringValue(menu_path); +#if 0 /* was available on Tk8.0 -- Tk8.4 */ menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path)); +#else /* based on Tk8.0 -- Tk8.5b1 */ + if ((menuTablePtr + = (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL)) + != NULL) { + if ((hashEntryPtr + = Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path))) + != NULL) { + menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr); + } + } +#endif + if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) { rb_raise(rb_eArgError, "not a menu widget, or invalid widget path"); } @@ -7856,9 +8109,20 @@ ip_make_menu_embeddable(interp, menu_path) } #endif +#if 0 /* was available on Tk8.0 -- Tk8.4 */ TkEventuallyRecomputeMenu(menuRefPtr->menuPtr); TkEventuallyRedrawMenu(menuRefPtr->menuPtr, (struct dummy_TkMenuEntry *)NULL); +#else /* based on Tk8.0 -- Tk8.5b1 */ + memset((void *) &event, 0, sizeof(event)); + event.xany.type = ConfigureNotify; + event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin)); + event.xany.send_event = 0; /* FALSE */ + event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin); + event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin); + event.xconfigure.window = event.xany.window; + Tk_HandleEvent(&event); +#endif #else /* TCL_MAJOR_VERSION <= 7 */ rb_notimplement(); @@ -7880,6 +8144,7 @@ Init_tcltklib() VALUE ev_flag = rb_define_module_under(lib, "EventFlag"); VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag"); + VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE"); /* --------------------------------------------------------------- */ @@ -7937,6 +8202,14 @@ Init_tcltklib() /* --------------------------------------------------------------- */ + rb_define_module_function(lib, "get_version", lib_getversion, -1); + + rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE)); + rb_define_const(release_type, "BETA", INT2FIX(TCL_BETA_RELEASE)); + rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE)); + + /* --------------------------------------------------------------- */ + eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError); eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); eTkCallbackContinue = rb_define_class("TkCallbackContinue", @@ -7989,6 +8262,8 @@ Init_tcltklib() lib_evloop_abort_on_exc, 0); rb_define_module_function(lib, "mainloop_abort_on_exception=", lib_evloop_abort_on_exc_set, 1); + rb_define_module_function(lib, "set_eventloop_window_mode",set_eventloop_window_mode,1); + rb_define_module_function(lib, "get_eventloop_window_mode",get_eventloop_window_mode,0); rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1); rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0); rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1); |