[ruby-dev:25663] Re: some problems on ext/tk/sample/**/*.rb
From:
Hidetoshi NAGAI <nagai@...>
Date:
2005-02-09 09:06:42 UTC
List:
ruby-dev #25663
永井@知能．九工大です．
From: H.Yamamoto <ocean@m2.ccsnet.ne.jp>
Subject: [ruby-dev:25656] Re: some problems on ext/tk/sample/**/*.rb
Date: Tue, 8 Feb 2005 15:37:00 +0900
Message-ID: <20050208153646.6DDB8540.ocean@m2.ccsnet.ne.jp>
> 試した限りでは落ちなくなったようです。ただ、multi-ip の
> サンプルがうまく動いていないようでした。
これについてはオオボケをかましてました．
その修正 + α を行いましたのでお試し頂ければ幸いです．
CVS HEAD からの差分になってます．
> menu_spec = [
> [['File', 0],
> ['exit(Crash)', proc{exit}, 0]]
> ]
>
> TkMenubar.new(nil, menu_spec).pack
> Tk.mainloop
>
> でメニューから終了すると、画面中央に一瞬何かのウィンドウが表示される
> ことがあります。すぐ閉じるので、なんて書いてあるのかは読めません。
こちらについても少しは対策してみたつもりですが，
問題の現象を手元で再現できないため，確信が持てません．
結果を報告頂けますと助かります．
Index: tcltklib.c
===================================================================
RCS file: /var/cvs/src/ruby/ext/tk/tcltklib.c,v
retrieving revision 1.2
diff -u -r1.2 tcltklib.c
--- tcltklib.c 31 Jan 2005 04:14:50 -0000 1.2
+++ tcltklib.c 9 Feb 2005 08:53:11 -0000
@@ -4,7 +4,7 @@
* Oct. 24, 1997 Y. Matsumoto
*/
-#define TCLTKLIB_RELEASE_DATE "2005-01-28"
+#define TCLTKLIB_RELEASE_DATE "2005-02-09"
#include "ruby.h"
#include "rubysig.h"
@@ -73,10 +73,6 @@
/* finalize_proc_name */
static char *finalize_hook_name = "INTERP_FINALIZE_HOOK";
-/* to cancel remained after-scripts when deleting IP */
-#define CANCEL_AFTER_SCRIPTS "__ruby_tcltklib_cancel_after_scripts__"
-#define DEF_CANCEL_AFTER_SCRIPTS_PROC "proc __ruby_tcltklib_cancel_after_scripts__ {} {foreach id [after info] {after cancel $id}}"
-
/* for callback break & continue */
static VALUE eTkCallbackReturn;
static VALUE eTkCallbackBreak;
@@ -106,6 +102,9 @@
static VALUE ip_invoke_real _((int, VALUE*, VALUE));
static VALUE ip_invoke _((int, VALUE*, VALUE));
+static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE));
+
+
/* from tkAppInit.c */
#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4)
@@ -148,6 +147,18 @@
VALUE thread;
};
+struct call_queue {
+ Tcl_Event ev;
+ VALUE (*func)();
+ int argc;
+ VALUE *argv;
+ VALUE interp;
+ int *done;
+ int safe_level;
+ VALUE result;
+ VALUE thread;
+};
+
void
invoke_queue_mark(struct invoke_queue *q)
{
@@ -164,9 +175,26 @@
rb_gc_mark(q->thread);
}
+void
+call_queue_mark(struct call_queue *q)
+{
+ int i;
+
+ for(i = 0; i < q->argc; i++) {
+ rb_gc_mark(q->argv[i]);
+ }
+
+ rb_gc_mark(q->interp);
+ rb_gc_mark(q->result);
+ rb_gc_mark(q->thread);
+}
+
static VALUE eventloop_thread;
static VALUE watchdog_thread;
+
+static VALUE rbtk_pending_exception;
+
Tcl_Interp *current_interp;
/*
@@ -204,6 +232,20 @@
static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **));
#endif
+/*----------------------------*/
+/* use Tcl internal functions */
+/*----------------------------*/
+#ifndef TCL_NAMESPACE_DEBUG
+#define TCL_NAMESPACE_DEBUG 0
+#endif
+
+#if TCL_NAMESPACE_DEBUG
+
+#if TCL_MAJOR_VERSION >= 8
+EXTERN struct TclIntStubs *tclIntStubsPtr;
+#endif
+
+/*-- Tcl_GetCurrentNamespace --*/
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5
/* Tcl7.x doesn't have namespace support. */
/* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */
@@ -213,26 +255,186 @@
# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# ifndef Tcl_GetCurrentNamespace
# ifndef FunctionNum_of_GetCurrentNamespace
-# define FunctionNum_of_GetCurrentNamespace 124
+#define FunctionNum_of_GetCurrentNamespace 124
# endif
-struct DummyTclIntStubs {
- int magic;
- struct TclIntStubHooks *hooks;
- void (*func[FunctionNum_of_GetCurrentNamespace])();
- Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *));
+struct DummyTclIntStubs_for_GetCurrentNamespace {
+ int magic;
+ struct TclIntStubHooks *hooks;
+ void (*func[FunctionNum_of_GetCurrentNamespace])();
+ Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *));
};
-EXTERN struct TclIntStubs *tclIntStubsPtr;
+
#define Tcl_GetCurrentNamespace \
- (((struct DummyTclIntStubs *)tclIntStubsPtr)->tcl_GetCurrentNamespace)
+ (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace)
+# endif
+# endif
+#endif
+
+/* namespace check */
+/* ip_null_namespace(Tcl_Interp *interp) */
+#if TCL_MAJOR_VERSION < 8
+#define ip_null_namespace(interp) (0)
+#else /* support namespace */
+#define ip_null_namespace(interp) \
+ (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL)
+#endif
+
+/* rbtk_invalid_namespace(tcltkip *ptr) */
+#if TCL_MAJOR_VERSION < 8
+#define rbtk_invalid_namespace(ptr) (0)
+#else /* support namespace */
+#define rbtk_invalid_namespace(ptr) \
+ ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns)
+#endif
+
+/*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/
+#if TCL_MAJOR_VERSION >= 8
+# ifndef CallFrame
+typedef struct CallFrame {
+ Tcl_Namespace *nsPtr;
+ int dummy1;
+ int dummy2;
+ char *dummy3;
+ struct CallFrame *callerPtr;
+ struct CallFrame *callerVarPtr;
+ int level;
+ char *dummy7;
+ char *dummy8;
+ int dummy9;
+ char* dummy10;
+} CallFrame;
+# endif
+
+# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
+EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
+# endif
+# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+# ifndef TclGetFrame
+# ifndef FunctionNum_of_GetFrame
+#define FunctionNum_of_GetFrame 32
+# endif
+struct DummyTclIntStubs_for_GetFrame {
+ int magic;
+ struct TclIntStubHooks *hooks;
+ void (*func[FunctionNum_of_GetFrame])();
+ int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **));
+};
+#define TclGetFrame \
+ (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame)
+# endif
+# endif
+
+# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
+EXTERN void Tcl_PopCallFrame _((Tcl_Interp *));
+EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
+# endif
+# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+# ifndef Tcl_PopCallFrame
+# ifndef FunctionNum_of_PopCallFrame
+#define FunctionNum_of_PopCallFrame 128
+# endif
+struct DummyTclIntStubs_for_PopCallFrame {
+ int magic;
+ struct TclIntStubHooks *hooks;
+ void (*func[FunctionNum_of_PopCallFrame])();
+ void (*tcl_PopCallFrame) _((Tcl_Interp *));
+ int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
+};
+
+#define Tcl_PopCallFrame \
+ (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame)
+#define Tcl_PushCallFrame \
+ (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame)
# endif
# endif
+
+#else /* Tcl7.x */
+# ifndef CallFrame
+typedef struct CallFrame {
+ Tcl_HashTable varTable;
+ int level;
+ int argc;
+ char **argv;
+ struct CallFrame *callerPtr;
+ struct CallFrame *callerVarPtr;
+} CallFrame;
+# endif
+# ifndef Tcl_CallFrame
+#define Tcl_CallFrame CallFrame
+# endif
+
+# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
+EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
+# endif
+
+# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
+typedef struct DummyInterp {
+ char *dummy1;
+ char *dummy2;
+ int dummy3;
+ Tcl_HashTable dummy4;
+ Tcl_HashTable dummy5;
+ Tcl_HashTable dummy6;
+ int numLevels;
+ int maxNestingDepth;
+ CallFrame *framePtr;
+ CallFrame *varFramePtr;
+} DummyInterp;
+
+static void
+Tcl_PopCallFrame(interp)
+ Tcl_Interp *interp;
+{
+ DummyInterp *iPtr = (DummyInterp*)interp;
+ CallFrame *frame = iPtr->varFramePtr;
+
+ /* **** DUMMY **** */
+ iPtr->framePtr = frame.callerPtr;
+ iPtr->varFramePtr = frame.callerVarPtr;
+
+ return TCL_OK;
+}
+
+/* dummy */
+#define Tcl_Namespace char
+
+static int
+Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame)
+ Tcl_Interp *interp;
+ Tcl_CallFrame *framePtr;
+ Tcl_Namespace *nsPtr;
+ int isProcCallFrame;
+{
+ DummyInterp *iPtr = (DummyInterp*)interp;
+ CallFrame *frame = (CallFrame *)framePtr;
+
+ /* **** DUMMY **** */
+ Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
+ if (iPtr->varFramePtr != NULL) {
+ frame.level = iPtr->varFramePtr->level + 1;
+ } else {
+ frame.level = 1;
+ }
+ frame.callerPtr = iPtr->framePtr;
+ frame.callerVarPtr = iPtr->varFramePtr;
+ iPtr->framePtr = &frame;
+ iPtr->varFramePtr = &frame;
+
+ return TCL_OK;
+}
+# endif
+
#endif
+#endif /* TCL_NAMESPACE_DEBUG */
+
/*---- class TclTkIp ----*/
struct tcltkip {
Tcl_Interp *ip; /* the interpreter */
+#if TCL_NAMESPACE_DEBUG
Tcl_Namespace *default_ns; /* 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 */
@@ -248,37 +450,28 @@
Data_Get_Struct(self, struct tcltkip, ptr);
if (ptr == 0) {
- rb_raise(rb_eTypeError, "uninitialized TclTkIp");
+ /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */
+ return((struct tcltkip *)NULL);
+ }
+ if (ptr->ip == (Tcl_Interp*)NULL) {
+ /* rb_raise(rb_eRuntimeError, "deleted IP"); */
}
return ptr;
}
-/* namespace check */
-/* ip_null_namespace(Tcl_Interp *interp) */
-#if TCL_MAJOR_VERSION < 8
-#define ip_null_namespace(interp) (0)
-#else /* support namespace */
-#define ip_null_namespace(interp) \
- (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL)
-#endif
-
-/* rbtk_invalid_namespace(tcltkip *ptr) */
-#if TCL_MAJOR_VERSION < 8
-#define rbtk_invalid_namespace(ptr) (0)
-#else /* support namespace */
-#define rbtk_invalid_namespace(ptr) \
- ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns)
-#endif
-
-
/* increment/decrement reference count of tcltkip */
static int
rbtk_preserve_ip(ptr)
struct tcltkip *ptr;
{
ptr->ref_count++;
- Tcl_Preserve((ClientData)ptr->ip);
+ if (ptr->ip == (Tcl_Interp*)NULL) {
+ /* deleted IP */
+ ptr->ref_count = 0;
+ } else {
+ Tcl_Preserve((ClientData)ptr->ip);
+ }
return(ptr->ref_count);
}
@@ -289,6 +482,9 @@
ptr->ref_count--;
if (ptr->ref_count < 0) {
ptr->ref_count = 0;
+ } else if (ptr->ip == (Tcl_Interp*)NULL) {
+ /* deleted IP */
+ ptr->ref_count = 0;
} else {
Tcl_Release((ClientData)ptr->ip);
}
@@ -454,7 +650,7 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return get_eventloop_tick(self);
}
@@ -507,7 +703,7 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return get_no_event_wait(self);
}
@@ -563,7 +759,7 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return get_eventloop_weight(self);
}
@@ -659,7 +855,7 @@
rb_secure(4);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return lib_evloop_abort_on_exc(self);
}
@@ -734,6 +930,15 @@
found_event = Tcl_DoOneEvent(event_flag);
+ if (rbtk_pending_exception != 0) {
+ volatile VALUE exc = rbtk_pending_exception;
+ DUMP1("find a pending exception");
+ rbtk_pending_exception = 0;
+ if (rb_obj_is_kind_of(exc, rb_eException)) {
+ rb_exc_raise(exc);
+ }
+ }
+
if (update_flag != 0) {
if (found_event) {
DUMP1("next update loop");
@@ -759,7 +964,7 @@
}
} else {
- int tick_counter;
+ int st, tick_counter;
DUMP1("there are other threads");
event_loop_wait_event = 1;
@@ -781,15 +986,31 @@
}
}
- if (Tcl_DoOneEvent(event_flag)) {
- tick_counter++;
- } else {
- if (update_flag != 0) {
- DUMP1("update complete");
- return 0;
+ if (eventloop_thread == 0 || current == eventloop_thread) {
+ st = Tcl_DoOneEvent(event_flag);
+
+ if (rbtk_pending_exception != 0) {
+ volatile VALUE exc = rbtk_pending_exception;
+ DUMP1("find a pending exception");
+ rbtk_pending_exception = 0;
+ if (rb_obj_is_kind_of(exc, rb_eException)) {
+ rb_exc_raise(exc);
+ }
+ }
+
+ if (st) {
+ tick_counter++;
+ } else {
+ if (update_flag != 0) {
+ DUMP1("update complete");
+ return 0;
+ }
+ tick_counter += no_event_tick;
+ rb_thread_wait_for(t);
}
- tick_counter += no_event_tick;
- rb_thread_wait_for(t);
+ } else {
+ DUMP2("sleep eventloop %lx", current);
+ rb_thread_stop();
}
if (watchdog_thread != 0 && eventloop_thread != current) {
@@ -851,12 +1072,22 @@
{
Tk_DeleteTimerHandler(timer_token);
timer_token = (Tcl_TimerToken)NULL;
- DUMP2("eventloop-ensure: current-thread : %lx\n", rb_thread_current());
- DUMP2("eventloop-ensure: eventloop-thread : %lx\n", eventloop_thread);
- if (eventloop_thread == rb_thread_current()) {
- DUMP2("eventloop-thread -> %lx\n", parent_evloop);
- eventloop_thread = parent_evloop;
+
+ DUMP2("eventloop-ensure: current-thread : %lx", rb_thread_current());
+ DUMP2("eventloop-ensure: eventloop-thread : %lx", eventloop_thread);
+ while (eventloop_thread != rb_thread_current()) {
+ DUMP2("current-eventloop %lx waits for child", rb_thread_current());
+ rb_thread_stop();
}
+
+ DUMP2("eventloop-enshure: eventloop-thread -> %lx", parent_evloop);
+ eventloop_thread = parent_evloop;
+ if (eventloop_thread != 0) {
+ DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread);
+ rb_thread_wakeup(eventloop_thread);
+ }
+ DUMP2("FINISH eventloop %lx", rb_thread_current());
+
return Qnil;
}
@@ -864,10 +1095,19 @@
lib_eventloop_launcher(check_rootwidget)
VALUE check_rootwidget;
{
- VALUE parent_evloop = eventloop_thread;
+ volatile VALUE parent_evloop = eventloop_thread;
eventloop_thread = rb_thread_current();
+ if (parent_evloop != 0) {
+ DUMP2("wait for stop of parent_evloop %lx", parent_evloop);
+ while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) {
+ DUMP2("parent_evloop %lx doesn't stop", parent_evloop);
+ rb_thread_run(parent_evloop);
+ }
+ DUMP1("succeed to stop parent");
+ }
+
if (ruby_debug) {
fprintf(stderr, "tcltklib: eventloop-thread : %lx -> %lx\n",
parent_evloop, eventloop_thread);
@@ -906,7 +1146,8 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return Qnil;
}
@@ -1011,7 +1252,7 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return Qnil;
}
@@ -1034,6 +1275,10 @@
int flags;
int found_event;
+ if (eventloop_thread) {
+ rb_raise(rb_eRuntimeError, "eventloop is already running");
+ }
+
if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
flags = TCL_ALL_EVENTS | TCL_DONT_WAIT;
} else {
@@ -1050,7 +1295,8 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return Qfalse;
}
@@ -1064,6 +1310,15 @@
/* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */
found_event = Tcl_DoOneEvent(flags);
+ if (rbtk_pending_exception != 0) {
+ volatile VALUE exc = rbtk_pending_exception;
+ DUMP1("find a pending exception");
+ rbtk_pending_exception = 0;
+ if (rb_obj_is_kind_of(exc, rb_eException)) {
+ rb_exc_raise(exc);
+ }
+ }
+
if (found_event) {
return Qtrue;
} else {
@@ -1347,8 +1602,23 @@
/* ruby command has 1 arg. */
if (argc != 2) {
- rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)",
- argc - 1);
+#if 0
+ rb_raise(rb_eArgError,
+ "wrong number of arguments (%d for 1)", argc - 1);
+#else
+ char buf[sizeof(int)*8 + 1];
+ Tcl_ResetResult(interp);
+ sprintf(buf, "%d", argc-1);
+ Tcl_AppendResult(interp, "wrong number of arguments (",
+ buf, " for 1)", (char *)NULL);
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eArgError,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eArgError, interp->result);
+#endif
+ return TCL_ERROR;
+#endif
}
/* allocate */
@@ -1435,9 +1705,15 @@
return TCL_CONTINUE;
} else if (eclass == rb_eSystemExit) {
+ ip_set_exc_message(interp, res);
+ rbtk_pending_exception = res;
+ return TCL_ERROR;
+
+#if 0
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
+#if 0 /* REMOVE : fail to rescue SystemExit */
/* Tcl_Eval(interp, "destroy ."); */
if (Tk_GetNumMainWindows() > 0) {
Tk_Window main_win = Tk_MainWindow(interp);
@@ -1445,6 +1721,7 @@
Tk_DestroyWindow(main_win);
}
}
+#endif
/* StringValue(res); */
res = rb_funcall(res, ID_message, 0, 0);
@@ -1454,6 +1731,7 @@
rb_thread_critical = thr_crit_bup;
rb_raise(rb_eSystemExit, RSTRING(res)->ptr);
+#endif
} else if (rb_obj_is_kind_of(res, eLocalJumpError)) {
VALUE reason = rb_ivar_get(res, ID_at_reason);
@@ -1707,7 +1985,19 @@
VALUE old_gc;
if (argc < 3) {
+#if 0
rb_raise(rb_eArgError, "too few arguments");
+#else
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "too few arguments", (char *)NULL);
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eArgError,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eArgError, interp->result);
+#endif
+ return TCL_ERROR;
+#endif
}
/* allocate */
@@ -1744,8 +2034,21 @@
free(buf);
}
if (NIL_P(receiver)) {
- rb_raise(rb_eArgError, "unknown class/module/global-variable '%s'",
- str);
+#if 0
+ rb_raise(rb_eArgError,
+ "unknown class/module/global-variable '%s'", str);
+#else
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "unknown class/module/global-variable '",
+ str, "'", (char *)NULL);
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eArgError,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eArgError, interp->result);
+#endif
+ return TCL_ERROR;
+#endif
}
/* get metrhod */
@@ -1835,6 +2138,7 @@
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
+#if 0 /* REMOVE : fail to rescue SystemExit */
/* Tcl_Eval(interp, "destroy ."); */
if (Tk_GetNumMainWindows() > 0) {
Tk_Window main_win = Tk_MainWindow(interp);
@@ -1842,6 +2146,7 @@
Tk_DestroyWindow(main_win);
}
}
+#endif
/* StringValue(res); */
res = rb_funcall(res, ID_message, 0, 0);
@@ -1850,8 +2155,21 @@
rb_thread_critical = thr_crit_bup;
+#if 0
rb_raise(rb_eSystemExit, RSTRING(res)->ptr);
-
+#else
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "raise SystemExit on `ruby_cmd'",
+ (char *)NULL);
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
+ interp->result);
+#endif
+ return TCL_ERROR;
+#endif
} else if (rb_obj_is_kind_of(res, eLocalJumpError)) {
VALUE reason = rb_ivar_get(res, ID_at_reason);
@@ -1926,7 +2244,11 @@
char *argv[];
#endif
{
- if (!Tcl_InterpDeleted(interp) && !ip_null_namespace(interp)) {
+ if (!Tcl_InterpDeleted(interp)
+#if TCL_NAMESPACE_DEBUG
+ && !ip_null_namespace(interp)
+#endif
+ ) {
Tcl_Preserve(interp);
Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}");
Tcl_Release(interp);
@@ -1961,12 +2283,42 @@
#endif
if (rb_safe_level() >= 4) {
+#if 0
rb_raise(rb_eSecurityError,
"Insecure operation `exit' at level %d",
rb_safe_level());
+#else
+ char buf[sizeof(int)*8 + 1];
+ Tcl_ResetResult(interp);
+ sprintf(buf, "%d", rb_safe_level());
+ Tcl_AppendResult(interp, "Insecure operation `exit' at level ",
+ buf, (char *)NULL);
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eSecurityError,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eSecurityError,
+ interp->result);
+#endif
+ return TCL_ERROR;
+#endif
} else if (Tcl_IsSafe(interp)) {
+#if 0
rb_raise(rb_eSecurityError,
"Insecure operation `exit' on a safe interpreter");
+#else
+ Tcl_AppendResult(interp,
+ "Insecure operation `exit' on a safe interpreter",
+ (char *)NULL);
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eSecurityError,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eSecurityError,
+ interp->result);
+#endif
+ return TCL_ERROR;
+#endif
#if 0
} else if (Tcl_GetMaster(interp) != (Tcl_Interp *)NULL) {
Tcl_Preserve(interp);
@@ -1981,10 +2333,18 @@
switch(argc) {
case 1:
- rb_exit(0); /* not return if succeed */
-
+ /* rb_exit(0); */ /* not return if succeed */
Tcl_AppendResult(interp,
"fail to call \"", cmd, "\"", (char *)NULL);
+
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, interp->result);
+#endif
+ rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0));
+
return TCL_ERROR;
case 2:
@@ -2002,11 +2362,21 @@
}
param = argv[1];
#endif
- rb_exit(state); /* not return if succeed */
+ /* rb_exit(state); */ /* not return if succeed */
Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
param, "\"", (char *)NULL);
+
+#if TCL_MAJOR_VERSION >= 8
+ rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
+ Tcl_GetStringResult(interp));
+#else
+ rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, interp->result);
+#endif
+ rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state));
+
return TCL_ERROR;
+
default:
/* arguemnt error */
Tcl_AppendResult(interp,
@@ -3275,12 +3645,19 @@
VALUE self;
VALUE var;
{
- VALUE argv[2];
+ VALUE *argv;
+ VALUE retval;
volatile VALUE cmd_str = rb_str_new2("thread_vwait");
+ argv = ALLOC_N(VALUE, 2);
argv[0] = cmd_str;
argv[1] = var;
- return ip_invoke_real(2, argv, self);
+
+ retval = ip_invoke_real(2, argv, self);
+
+ free(argv);
+
+ return retval;
}
static VALUE
@@ -3289,13 +3666,20 @@
VALUE mode;
VALUE target;
{
- VALUE argv[3];
+ VALUE *argv;
+ VALUE retval;
volatile VALUE cmd_str = rb_str_new2("thread_tkwait");
+ argv = ALLOC_N(VALUE, 3);
argv[0] = cmd_str;
argv[1] = mode;
argv[2] = target;
- return ip_invoke_real(3, argv, self);
+
+ retval = ip_invoke_real(3, argv, self);
+
+ free(argv);
+
+ return retval;
}
/* destroy interpreter */
@@ -3329,7 +3713,11 @@
char *slave_name;
int i, len;
- if (Tcl_InterpDeleted(ip) || ip_null_namespace(ip)) {
+ if (Tcl_InterpDeleted(ip)
+#if TCL_NAMESPACE_DEBUG
+ || ip_null_namespace(ip)
+#endif
+ ) {
DUMP2("call delete_slaves() for deleted ip(%lx)", ip);
return;
}
@@ -3370,20 +3758,22 @@
Tcl_Preserve(slave);
- if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave) &&
- Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) {
+ if (!Tcl_InterpDeleted(slave)
+#if TCL_NAMESPACE_DEBUG
+ && !ip_null_namespace(slave)
+#endif
+ && Tcl_GetCommandInfo(slave, finalize_hook_name, &info)) {
DUMP2("call finalize hook proc '%s'", finalize_hook_name);
Tcl_Eval(slave, finalize_hook_name);
}
- if (!Tcl_InterpDeleted(slave) &&
- Tcl_Eval(slave, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) {
- if (!Tcl_InterpDeleted(slave) && !ip_null_namespace(slave) &&
- Tcl_GetCommandInfo(slave, CANCEL_AFTER_SCRIPTS, &info)) {
- DUMP2("call cancel after scripts proc '%s'",
- CANCEL_AFTER_SCRIPTS);
- Tcl_Eval(slave, CANCEL_AFTER_SCRIPTS);
- }
+ if (!Tcl_InterpDeleted(slave)
+#if TCL_NAMESPACE_DEBUG
+ && !ip_null_namespace(slave)
+#endif
+ ) {
+ DUMP1("call cancel after scripts");
+ Tcl_Eval(slave, "foreach id [after info] {after cancel $id}");
}
/* delete slaves of slave */
@@ -3408,69 +3798,124 @@
Tcl_Release(ip);
}
-static void
-ip_free(ptr)
- struct tcltkip *ptr;
+
+static int
+ip_free_core(ip)
+ Tcl_Interp *ip;
{
Tcl_CmdInfo info;
int thr_crit_bup;
- char* argv[2];
- DUMP2("free Tcl Interp %lx", ptr->ip);
- if (ptr) {
- thr_crit_bup = rb_thread_critical;
- rb_thread_critical = Qtrue;
+ /* deleted ipterp ? */
+ if (ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ip)) {
+ /* deleted IP --> ignore */
+ return 1;
+ }
- DUMP2("IP ref_count = %d", ptr->ref_count);
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)) {
- DUMP2("IP(%lx) is not deleted", ptr->ip);
- /* Tcl_Preserve(ptr->ip); */
- rbtk_preserve_ip(ptr);
+ Tcl_Preserve(ip);
- delete_slaves(ptr->ip);
+ delete_slaves(ip);
- Tcl_ResetResult(ptr->ip);
+ Tcl_ResetResult(ip);
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)
- && Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) {
- DUMP2("call finalize hook proc '%s'", finalize_hook_name);
- Tcl_Eval(ptr->ip, finalize_hook_name);
- }
+ if (!Tcl_InterpDeleted(ip)
+#if TCL_NAMESPACE_DEBUG
+ && !ip_null_namespace(ip)
+#endif
+ && Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) {
+ DUMP2("call finalize hook proc '%s'", finalize_hook_name);
+ Tcl_Eval(ip, finalize_hook_name);
+ }
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)
- && Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) {
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)
- && Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) {
- DUMP2("call cancel after scripts proc '%s'",
- CANCEL_AFTER_SCRIPTS);
- Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS);
- }
- }
+ if (!Tcl_InterpDeleted(ip)
+#if TCL_NAMESPACE_DEBUG
+ && !ip_null_namespace(ip)
+#endif
+ ) {
+ DUMP1("call cancel aftern scripts");
+ Tcl_Eval(ip, "foreach id [after info] {after cancel $id}");
+ }
- /* del_root(ptr->ip); */
+ /* del_root(ip); */
- DUMP1("delete interp");
- /* while(!rbtk_InterpDeleted(ptr->ip)) { */
- if (!Tcl_InterpDeleted(ptr->ip)) {
- DUMP2("delete ip(%lx)", ptr->ip);
- Tcl_DeleteInterp(ptr->ip);
- }
+ /* while(!rbtk_InterpDeleted(ip)) { */
+ if (!Tcl_InterpDeleted(ip)) {
+ DUMP2("delete ip(%lx)", ip);
+ Tcl_DeleteInterp(ip);
+ }
- /* Tcl_Release(ptr->ip); */
- rbtk_release_ip(ptr);
- }
+ Tcl_Release(ip);
- rbtk_release_ip(ptr);
- DUMP2("IP ref_count = %d", ptr->ref_count);
+ rb_thread_critical = thr_crit_bup;
- free(ptr);
+ return 1;
+}
- rb_thread_critical = thr_crit_bup;
+struct ip_free_queue {
+ Tcl_Event ev;
+ Tcl_Interp *ip;
+};
+
+static int
+ip_free_queue_handler(evPtr, flags)
+ Tcl_Event *evPtr;
+ int flags;
+{
+ struct ip_free_queue *ptr = (struct ip_free_queue *)evPtr;
+ int st;
+
+ st = ip_free_core(ptr->ip);
+
+ Tcl_Release(evPtr);
+
+ return st;
+}
+
+static void
+ip_free(ptr)
+ struct tcltkip *ptr;
+{
+ struct ip_free_queue *q;
+
+ DUMP2("free Tcl Interp %lx", ptr->ip);
+ if (ptr) {
+ if ( ptr->ip != (Tcl_Interp*)NULL
+ && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL
+ && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) {
+ DUMP2("parent IP(%lx) is not deleted", Tcl_GetMaster(ptr->ip));
+ DUMP2("slave IP(%lx) should not be deleted", ptr->ip);
+ free(ptr);
+ return;
+ }
+
+ if (ptr->ip == (Tcl_Interp*)NULL) {
+ DUMP1("ip_free is called for deleted IP");
+ free(ptr);
+ return;
+ }
+
+ if (eventloop_thread != 0 && rb_thread_current() != eventloop_thread) {
+ /* queueing */
+ q = (struct ip_free_queue*)Tcl_Alloc(sizeof(struct ip_free_queue));
+ Tcl_Preserve(q);
+ q->ip = ptr->ip;
+ q->ev.proc = ip_free_queue_handler;
+ Tcl_QueueEvent(&(q->ev), TCL_QUEUE_HEAD);
+ } else {
+ /* direct call */
+ ip_free_core(ptr->ip);
+ }
+
+ free(ptr);
}
+
DUMP1("complete freeing Tcl Interp");
}
+
/* create and initialize interpreter */
static VALUE ip_alloc _((VALUE));
static VALUE
@@ -3494,7 +3939,9 @@
/* security check */
if (ruby_safe_level >= 4) {
- rb_raise(rb_eSecurityError, "Cannot create a TclTkIp object at level %d", ruby_safe_level);
+ rb_raise(rb_eSecurityError,
+ "Cannot create a TclTkIp object at level %d",
+ ruby_safe_level);
}
/* create object */
@@ -3513,12 +3960,14 @@
}
#if TCL_MAJOR_VERSION >= 8
+#if TCL_NAMESPACE_DEBUG
DUMP1("get current namespace");
if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip))
== (Tcl_Namespace*)NULL) {
rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace");
}
#endif
+#endif
rbtk_preserve_ip(ptr);
DUMP2("IP ref_count = %d", ptr->ref_count);
@@ -3715,12 +4164,12 @@
}
static VALUE
-ip_create_slave(argc, argv, self)
+ip_create_slave_core(interp, argc, argv)
+ VALUE interp;
int argc;
VALUE *argv;
- VALUE self;
{
- struct tcltkip *master = get_ip(self);
+ struct tcltkip *master = get_ip(interp);
struct tcltkip *slave = ALLOC(struct tcltkip);
VALUE safemode;
VALUE name;
@@ -3728,15 +4177,22 @@
int thr_crit_bup;
Tk_Window mainWin;
- /* safe-mode check */
- if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
- safemode = Qfalse;
+ /* ip is deleted? */
+ if (master == (struct tcltkip *)NULL || master->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(master->ip)) {
+ DUMP1("master-ip is deleted");
+ return rb_exc_new2(rb_eRuntimeError,
+ "deleted master cannot create a new slave");
}
+
+ name = argv[0];
+ safemode = argv[1];
+
if (Tcl_IsSafe(master->ip) == 1) {
safe = 1;
} else if (safemode == Qfalse || NIL_P(safemode)) {
safe = 0;
- rb_secure(4);
+ /* rb_secure(4); */ /* already checked */
} else {
safe = 1;
}
@@ -3744,26 +4200,22 @@
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
- /* ip is deleted? */
- if (Tcl_InterpDeleted(master->ip)) {
- DUMP1("master-ip is deleted");
- rb_thread_critical = thr_crit_bup;
- rb_raise(rb_eRuntimeError, "deleted master cannot create a new slave interpreter");
- }
-
/* create slave-ip */
slave->ref_count = 0;
slave->allow_ruby_exit = 0;
slave->return_value = 0;
- slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
+ slave->ip = Tcl_CreateSlave(master->ip, RSTRING(name)->ptr, safe);
if (slave->ip == NULL) {
rb_thread_critical = thr_crit_bup;
- rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter");
+ return rb_exc_new2(rb_eRuntimeError,
+ "fail to create the new slave interpreter");
}
#if TCL_MAJOR_VERSION >= 8
+#if TCL_NAMESPACE_DEBUG
slave->default_ns = Tcl_GetCurrentNamespace(slave->ip);
#endif
+#endif
rbtk_preserve_ip(slave);
slave->has_orig_exit
@@ -3783,28 +4235,72 @@
rb_thread_critical = thr_crit_bup;
- return Data_Wrap_Struct(CLASS_OF(self), 0, ip_free, slave);
+ return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave);
}
-/* make ip "safe" */
static VALUE
-ip_make_safe(self)
+ip_create_slave(argc, argv, self)
+ int argc;
+ VALUE *argv;
VALUE self;
{
- struct tcltkip *ptr = get_ip(self);
+ struct tcltkip *master = get_ip(self);
+ VALUE safemode;
+ VALUE name;
+ VALUE *callargv;
+ VALUE retval;
+
+ /* ip is deleted? */
+ if (master == (struct tcltkip *)NULL || master->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(master->ip)) {
+ DUMP1("master-ip is deleted");
+ rb_raise(rb_eRuntimeError,
+ "deleted master cannot create a new slave interpreter");
+ }
+
+ /* safe-mode check */
+ if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
+ safemode = Qfalse;
+ }
+ if (Tcl_IsSafe(master->ip) != 1
+ && (safemode == Qfalse || NIL_P(safemode))) {
+ rb_secure(4);
+ }
+
+ callargv = ALLOC_N(VALUE, 2);
+ StringValue(name);
+ callargv[0] = name;
+ callargv[1] = safemode;
+
+ retval = tk_funcall(ip_create_slave_core, 2, callargv, self);
+
+ free(callargv);
+
+ return retval;
+}
+
+/* make ip "safe" */
+static VALUE
+ip_make_safe_core(interp, argc, argv)
+ VALUE interp;
+ int argc; /* dummy */
+ VALUE *argv; /* dummy */
+{
+ struct tcltkip *ptr = get_ip(interp);
Tk_Window mainWin;
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
- rb_raise(rb_eRuntimeError, "interpreter is deleted");
+ return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
}
if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
#if TCL_MAJOR_VERSION >= 8
- rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+ return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
#else /* TCL_MAJOR_VERSION < 8 */
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
#endif
}
@@ -3822,7 +4318,23 @@
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
- return self;
+ return interp;
+}
+
+static VALUE
+ip_make_safe(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ /* ip is deleted? */
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ rb_raise(rb_eRuntimeError, "interpreter is deleted");
+ }
+
+ return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self);
}
/* is safe? */
@@ -3833,7 +4345,8 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
@@ -3853,7 +4366,8 @@
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
@@ -3876,7 +4390,8 @@
rb_secure(4);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
@@ -3918,11 +4433,19 @@
/* delete interpreter */
static VALUE
-ip_delete(self)
- VALUE self;
+ip_delete_core(interp, argc, argv)
+ VALUE interp;
+ int argc; /* dummy */
+ VALUE *argv; /* dummy */
{
Tcl_CmdInfo info;
- struct tcltkip *ptr = get_ip(self);
+ struct tcltkip *ptr = get_ip(interp);
+
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("delete deleted IP");
+ return Qnil;
+ }
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
@@ -3931,20 +4454,22 @@
delete_slaves(ptr->ip);
DUMP1("finalize operation");
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)
+ if (!Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ && !rbtk_invalid_namespace(ptr)
+#endif
&& Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) {
DUMP2("call finalize hook proc '%s'", finalize_hook_name);
Tcl_Eval(ptr->ip, finalize_hook_name);
}
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)
- && Tcl_Eval(ptr->ip, DEF_CANCEL_AFTER_SCRIPTS_PROC) == TCL_OK) {
- if (!Tcl_InterpDeleted(ptr->ip) && !rbtk_invalid_namespace(ptr)
- && Tcl_GetCommandInfo(ptr->ip, CANCEL_AFTER_SCRIPTS, &info)) {
- DUMP2("call cancel after scripts proc '%s'",
- CANCEL_AFTER_SCRIPTS);
- Tcl_Eval(ptr->ip, CANCEL_AFTER_SCRIPTS);
- }
+ if (!Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ && !ip_null_namespace(ptr->ip)
+#endif
+ ) {
+ DUMP1("call cancel after scripts");
+ Tcl_Eval(ptr->ip, "foreach id [after info] {after cancel $id}");
}
del_root(ptr->ip);
@@ -3955,6 +4480,7 @@
DUMP2("delete ip(%lx)", ptr->ip);
Tcl_DeleteInterp(ptr->ip);
}
+ ptr->ip = (Tcl_Interp*)NULL;
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
@@ -3962,6 +4488,21 @@
return Qnil;
}
+static VALUE
+ip_delete(self)
+ VALUE self;
+{
+ struct tcltkip *ptr = get_ip(self);
+
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
+ return Qnil;
+ } else {
+ return tk_funcall(ip_delete_core, 0, (VALUE*)NULL, self);
+ }
+}
+
+
/* is deleted? */
static VALUE
ip_has_invalid_namespace_p(self)
@@ -3969,11 +4510,20 @@
{
struct tcltkip *ptr = get_ip(self);
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) {
+ /* deleted IP */
+ return Qtrue;
+ }
+
+#if TCL_NAMESPACE_DEBUG
if (rbtk_invalid_namespace(ptr)) {
return Qtrue;
} else {
return Qfalse;
}
+#else
+ return Qfalse;
+#endif
}
static VALUE
@@ -3982,7 +4532,8 @@
{
struct tcltkip *ptr = get_ip(self);
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
return Qtrue;
} else {
return Qfalse;
@@ -4004,6 +4555,7 @@
va_list args;
char buf[BUFSIZ];
VALUE einfo;
+ struct tcltkip *ptr = get_ip(interp);
va_init_list(args,fmt);
vsnprintf(buf, BUFSIZ, fmt, args);
@@ -4011,7 +4563,9 @@
va_end(args);
einfo = rb_exc_new2(exc, buf);
rb_ivar_set(einfo, ID_at_interp, interp);
- Tcl_ResetResult(get_ip(interp)->ip);
+ if (ptr) {
+ Tcl_ResetResult(ptr->ip);
+ }
return einfo;
}
@@ -4073,6 +4627,175 @@
#endif
}
+
+/* call Tcl/Tk functions on the eventloop thread */
+static VALUE
+callq_safelevel_handler(arg, callq)
+ VALUE arg;
+ VALUE callq;
+{
+ struct call_queue *q;
+
+ Data_Get_Struct(callq, struct call_queue, q);
+ DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
+ rb_set_safe_level(q->safe_level);
+ return((q->func)(q->interp, q->argc, q->argv));
+}
+
+static int call_queue_handler _((Tcl_Event *, int));
+static int
+call_queue_handler(evPtr, flags)
+ Tcl_Event *evPtr;
+ int flags;
+{
+ struct call_queue *q = (struct call_queue *)evPtr;
+ volatile VALUE ret;
+ volatile VALUE q_dat;
+ struct tcltkip *ptr;
+
+ DUMP2("do_call_queue_handler : evPtr = %p", evPtr);
+ DUMP2("queue_handler thread : %lx", rb_thread_current());
+ DUMP2("added by thread : %lx", q->thread);
+
+ if (*(q->done)) {
+ DUMP1("processed by another event-loop");
+ return 0;
+ } else {
+ DUMP1("process it on current event-loop");
+ }
+
+ /* process it */
+ *(q->done) = 1;
+
+ /* deleted ipterp ? */
+ ptr = get_ip(q->interp);
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
+ /* deleted IP --> ignore */
+ return 1;
+ }
+
+ /* check safe-level */
+ if (rb_safe_level() != q->safe_level) {
+ /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
+ q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,0,q);
+ ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat),
+ ID_call, 0);
+ rb_gc_force_recycle(q_dat);
+ } else {
+ DUMP2("call function (for caller thread:%lx)", q->thread);
+ DUMP2("call function (current thread:%lx)", rb_thread_current());
+ ret = (q->func)(q->interp, q->argc, q->argv);
+ }
+
+ /* set result */
+ RARRAY(q->result)->ptr[0] = ret;
+
+ /* complete */
+ *(q->done) = -1;
+
+ /* back to caller */
+ DUMP2("back to caller (caller thread:%lx)", q->thread);
+ DUMP2(" (current thread:%lx)", rb_thread_current());
+ rb_thread_run(q->thread);
+ DUMP1("finish back to caller");
+
+ /* end of handler : remove it */
+ return 1;
+}
+
+static VALUE
+tk_funcall(func, argc, argv, obj)
+ VALUE (*func)();
+ int argc;
+ VALUE *argv;
+ VALUE obj;
+{
+ struct call_queue *callq;
+ int *alloc_done;
+ int thr_crit_bup;
+ volatile VALUE current = rb_thread_current();
+ volatile VALUE ip_obj = obj;
+ volatile VALUE result;
+ volatile VALUE ret;
+
+
+ if (!NIL_P(ip_obj) && Tcl_InterpDeleted(get_ip(ip_obj)->ip)) {
+ return Qnil;
+ }
+
+ if (eventloop_thread == 0 || current == eventloop_thread) {
+ if (eventloop_thread) {
+ DUMP2("tk_funcall from current eventloop %lx", current);
+ } else {
+ DUMP2("tk_funcall from thread:%lx but no eventloop", current);
+ }
+ result = (func)(ip_obj, argc, argv);
+ if (rb_obj_is_kind_of(result, rb_eException)) {
+ rb_exc_raise(result);
+ }
+ return result;
+ }
+
+ DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* allocate memory (keep result) */
+ alloc_done = (int*)ALLOC(int);
+ *alloc_done = 0;
+
+ /* allocate memory (freed by Tcl_ServiceEvent) */
+ callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue));
+ Tcl_Preserve(callq);
+
+ /* allocate result obj */
+ result = rb_ary_new2(1);
+ RARRAY(result)->ptr[0] = Qnil;
+ RARRAY(result)->len = 1;
+
+ /* construct event data */
+ callq->done = alloc_done;
+ callq->func = func;
+ callq->argc = argc;
+ callq->argv = argv;
+ callq->interp = ip_obj;
+ callq->result = result;
+ callq->thread = current;
+ callq->safe_level = rb_safe_level();
+ callq->ev.proc = call_queue_handler;
+
+ /* add the handler to Tcl event queue */
+ DUMP1("add handler");
+ Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD);
+
+ 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();
+ }
+ DUMP2("back from handler (current thread:%lx)", current);
+
+ /* get result & free allocated memory */
+ ret = RARRAY(result)->ptr[0];
+ free(alloc_done);
+
+ Tcl_Release(callq);
+
+ /* exception? */
+ if (rb_obj_is_kind_of(ret, rb_eException)) {
+ DUMP1("raise exception");
+ rb_exc_raise(ret);
+ }
+
+ DUMP1("exit tk_funcall");
+ return ret;
+}
+
+
/* eval string in tcl by Tcl_Eval() */
static VALUE
ip_eval_real(self, cmd_str, cmd_len)
@@ -4098,7 +4821,12 @@
Tcl_IncrRefCount(cmd);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
Tcl_DecrRefCount(cmd);
rb_thread_critical = thr_crit_bup;
@@ -4118,8 +4846,15 @@
if (ptr->return_value == TCL_ERROR) {
volatile VALUE exc;
- exc = create_ip_exc(self, rb_eRuntimeError,
- "%s", Tcl_GetStringResult(ptr->ip));
+
+ if (rbtk_pending_exception != 0) {
+ exc = rbtk_pending_exception;
+ rbtk_pending_exception = 0;
+ } else {
+ exc = create_ip_exc(self, rb_eRuntimeError,
+ "%s", Tcl_GetStringResult(ptr->ip));
+ }
+
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
@@ -4139,7 +4874,12 @@
DUMP2("Tcl_Eval(%s)", cmd_str);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
ptr->return_value = TCL_OK;
return rb_tainted_str_new2("");
@@ -4152,7 +4892,14 @@
if (ptr->return_value == TCL_ERROR) {
volatile VALUE exc;
- exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
+
+ if (rbtk_pending_exception != 0) {
+ exc = rbtk_pending_exception;
+ rbtk_pending_exception = 0;
+ } else {
+ exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_exc_raise(exc);
@@ -4334,19 +5081,26 @@
/* restart Tk */
static VALUE
-lib_restart(self)
- VALUE self;
+lib_restart_core(interp, argc, argv)
+ VALUE interp;
+ int argc; /* dummy */
+ VALUE *argv; /* dummy */
{
volatile VALUE exc;
- struct tcltkip *ptr = get_ip(self);
+ struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
- rb_secure(4);
+ /* rb_secure(4); */ /* already checked */
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
- rb_raise(rb_eRuntimeError, "interpreter is deleted");
+ return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
}
thr_crit_bup = rb_thread_critical;
@@ -4361,11 +5115,13 @@
DUMP2("(TCL_Eval result) %d", ptr->return_value);
Tcl_ResetResult(ptr->ip);
+#if TCL_MAJOR_VERSION >= 8
/* delete namespace ( tested on tk8.4.5 ) */
ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
/* ignore ERROR */
DUMP2("(TCL_Eval result) %d", ptr->return_value);
Tcl_ResetResult(ptr->ip);
+#endif
/* delete trace proc ( tested on tk8.4.5 ) */
ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
@@ -4382,7 +5138,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
} else {
DUMP1("Tk_Init");
@@ -4391,7 +5147,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
}
#else /* TCL_MAJOR_VERSION < 8 */
@@ -4400,7 +5156,7 @@
exc = rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
- rb_exc_raise(exc);
+ return exc;
}
#endif
@@ -4412,6 +5168,30 @@
return Qnil;
}
+static VALUE
+lib_restart(self)
+ VALUE self;
+{
+ volatile VALUE exc;
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+
+ rb_secure(4);
+
+ /* ip is deleted? */
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
+ DUMP1("ip is deleted");
+ rb_raise(rb_eRuntimeError, "interpreter is deleted");
+ }
+
+ return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self);
+}
+
static VALUE
ip_restart(self)
@@ -4422,7 +5202,8 @@
rb_secure(4);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
@@ -4454,12 +5235,15 @@
if (NIL_P(ip_obj)) {
interp = (Tcl_Interp *)NULL;
} else {
- interp = get_ip(ip_obj)->ip;
+ ptr = get_ip(ip_obj);
/* ip is deleted? */
- if (Tcl_InterpDeleted(interp)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = ptr->ip;
}
}
@@ -4597,6 +5381,8 @@
if (NIL_P(ip_obj)) {
interp = (Tcl_Interp *)NULL;
+ } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
+ interp = (Tcl_Interp *)NULL;
} else {
interp = get_ip(ip_obj)->ip;
}
@@ -4833,7 +5619,12 @@
ptr = get_ip(interp);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
}
@@ -4908,6 +5699,15 @@
/* exception on mainloop */
if (ptr->return_value == TCL_ERROR) {
if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
+
+ if (rbtk_pending_exception != 0) {
+ volatile VALUE exc;
+ DUMP1("find a pending exception");
+ exc = rbtk_pending_exception;
+ rbtk_pending_exception = 0;
+ return exc;
+ }
+
#if TCL_MAJOR_VERSION >= 8
return create_ip_exc(interp, rb_eRuntimeError,
"%s", Tcl_GetStringResult(ptr->ip));
@@ -5062,7 +5862,7 @@
ptr = get_ip(interp);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
}
@@ -5258,7 +6058,8 @@
ptr = get_ip(self);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
}
@@ -5284,21 +6085,22 @@
return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD);
}
+
/* access Tcl variables */
static VALUE
-ip_get_variable(self, varname_arg, flag_arg)
- VALUE self;
- VALUE varname_arg;
- VALUE flag_arg;
+ip_get_variable_core(interp, argc, argv)
+ VALUE interp;
+ int argc;
+ VALUE *argv;
{
- struct tcltkip *ptr = get_ip(self);
+ struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
volatile VALUE varname, flag;
- varname = varname_arg;
- flag = flag_arg;
+ varname = argv[0];
+ flag = argv[1];
- StringValue(varname);
+ /* StringValue(varname); */
#if TCL_MAJOR_VERSION >= 8
{
@@ -5315,7 +6117,12 @@
Tcl_IncrRefCount(nameobj);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
Tcl_DecrRefCount(nameobj);
rb_thread_critical = thr_crit_bup;
@@ -5339,7 +6146,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
Tcl_IncrRefCount(ret);
@@ -5379,7 +6186,12 @@
char *ret;
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
} else {
@@ -5399,7 +6211,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
strval = rb_tainted_str_new2(ret);
@@ -5413,26 +6225,44 @@
}
static VALUE
-ip_get_variable2(self, varname_arg, index_arg, flag_arg)
+ip_get_variable(self, varname, flag)
VALUE self;
- VALUE varname_arg;
- VALUE index_arg;
- VALUE flag_arg;
+ VALUE varname;
+ VALUE flag;
{
- struct tcltkip *ptr = get_ip(self);
+ VALUE *argv;
+ VALUE retval;
+
+ argv = ALLOC_N(VALUE, 2);
+ StringValue(varname);
+ argv[0] = varname;
+ argv[1] = flag;
+
+ retval = tk_funcall(ip_get_variable_core, 2, argv, self);
+
+ free(argv);
+
+ return retval;
+}
+
+static VALUE
+ip_get_variable2_core(interp, argc, argv)
+ VALUE interp;
+ int argc;
+ VALUE *argv;
+{
+ struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
volatile VALUE varname, index, flag;
- if (NIL_P(index_arg)) {
- return ip_get_variable(self, varname_arg, flag_arg);
- }
-
- varname = varname_arg;
- index = index_arg;
- flag = flag_arg;
+ varname = argv[0];
+ index = argv[1];
+ flag = argv[2];
+ /*
StringValue(varname);
StringValue(index);
+ */
#if TCL_MAJOR_VERSION >= 8
{
@@ -5451,7 +6281,12 @@
Tcl_IncrRefCount(idxobj);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
Tcl_DecrRefCount(nameobj);
Tcl_DecrRefCount(idxobj);
@@ -5476,7 +6311,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
Tcl_IncrRefCount(ret);
@@ -5516,7 +6351,12 @@
char *ret;
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
} else {
@@ -5536,7 +6376,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
strval = rb_tainted_str_new2(ret);
@@ -5550,22 +6390,52 @@
}
static VALUE
-ip_set_variable(self, varname_arg, value_arg, flag_arg)
+ip_get_variable2(self, varname, index, flag)
VALUE self;
- VALUE varname_arg;
- VALUE value_arg;
- VALUE flag_arg;
+ VALUE varname;
+ VALUE index;
+ VALUE flag;
{
- struct tcltkip *ptr = get_ip(self);
+ VALUE *argv;
+ VALUE retval;
+
+ argv = ALLOC_N(VALUE, 3);
+ StringValue(varname);
+ argv[0] = varname;
+
+ if (NIL_P(index)) {
+ argv[1] = flag;
+ retval = tk_funcall(ip_get_variable_core, 2, argv, self);
+ } else {
+ StringValue(index);
+ argv[1] = index;
+ argv[2] = flag;
+ retval = tk_funcall(ip_get_variable2_core, 3, argv, self);
+ }
+
+ free(argv);
+
+ return retval;
+}
+
+static VALUE
+ip_set_variable_core(interp, argc, argv)
+ VALUE interp;
+ int argc;
+ VALUE *argv;
+{
+ struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
volatile VALUE varname, value, flag;
- varname = varname_arg;
- value = value_arg;
- flag = flag_arg;
+ varname = argv[0];
+ value = argv[1];
+ flag = argv[2];
+ /*
StringValue(varname);
StringValue(value);
+ */
#if TCL_MAJOR_VERSION >= 8
{
@@ -5613,7 +6483,12 @@
# endif
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
Tcl_DecrRefCount(nameobj);
Tcl_DecrRefCount(valobj);
@@ -5639,7 +6514,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
Tcl_IncrRefCount(ret);
@@ -5680,7 +6555,12 @@
CONST char *ret;
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
} else {
@@ -5691,7 +6571,7 @@
}
if (ret == NULL) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
}
strval = rb_tainted_str_new2(ret);
@@ -5705,29 +6585,50 @@
}
static VALUE
-ip_set_variable2(self, varname_arg, index_arg, value_arg, flag_arg)
+ip_set_variable(self, varname, value, flag)
VALUE self;
- VALUE varname_arg;
- VALUE index_arg;
- VALUE value_arg;
- VALUE flag_arg;
+ VALUE varname;
+ VALUE value;
+ VALUE flag;
{
- struct tcltkip *ptr = get_ip(self);
+ VALUE *argv;
+ VALUE retval;
+
+ StringValue(varname);
+ StringValue(value);
+
+ argv = ALLOC_N(VALUE, 3);
+ argv[0] = varname;
+ argv[1] = value;
+ argv[2] = flag;
+
+ retval = tk_funcall(ip_set_variable_core, 3, argv, self);
+
+ free(argv);
+
+ return retval;
+}
+
+static VALUE
+ip_set_variable2_core(interp, argc, argv)
+ VALUE interp;
+ int argc;
+ VALUE *argv;
+{
+ struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
volatile VALUE varname, index, value, flag;
- if (NIL_P(index_arg)) {
- return ip_set_variable(self, varname_arg, value_arg, flag_arg);
- }
-
- varname = varname_arg;
- index = index_arg;
- value = value_arg;
- flag = flag_arg;
+ varname = argv[0];
+ index = argv[1];
+ value = argv[2];
+ flag = argv[3];
+ /*
StringValue(varname);
StringValue(index);
StringValue(value);
+ */
#if TCL_MAJOR_VERSION >= 8
{
@@ -5777,7 +6678,12 @@
Tcl_IncrRefCount(valobj);
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
Tcl_DecrRefCount(nameobj);
Tcl_DecrRefCount(idxobj);
@@ -5805,7 +6711,7 @@
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
- rb_exc_raise(exc);
+ return exc;
}
Tcl_IncrRefCount(ret);
@@ -5838,7 +6744,12 @@
CONST char *ret;
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return rb_tainted_str_new2("");
} else {
@@ -5850,7 +6761,7 @@
}
if (ret == (char*)NULL) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
}
Tcl_IncrRefCount(ret);
@@ -5868,21 +6779,62 @@
}
static VALUE
-ip_unset_variable(self, varname_arg, flag_arg)
+ip_set_variable2(self, varname, index, value, flag)
VALUE self;
- VALUE varname_arg;
- VALUE flag_arg;
+ VALUE varname;
+ VALUE index;
+ VALUE value;
+ VALUE flag;
{
- struct tcltkip *ptr = get_ip(self);
- volatile VALUE varname, value, flag;
+ VALUE *argv;
+ VALUE retval;
- varname = varname_arg;
- flag = flag_arg;
+ argv = ALLOC_N(VALUE, 4);
+ StringValue(varname);
+ argv[0] = varname;
+ if (NIL_P(index)) {
+ StringValue(value);
+ argv[1] = value;
+ argv[2] = flag;
+ retval = tk_funcall(ip_set_variable_core, 3, argv, self);
+ } else {
+ StringValue(index);
+ StringValue(value);
+ argv[1] = index;
+ argv[2] = value;
+ argv[3] = flag;
+ retval = tk_funcall(ip_set_variable2_core, 4, argv, self);
+ }
+
+ free(argv);
+
+ return retval;
+}
+
+static VALUE
+ip_unset_variable_core(interp, argc, argv)
+ VALUE interp;
+ int argc;
+ VALUE *argv;
+{
+ struct tcltkip *ptr = get_ip(interp);
+ volatile VALUE varname, flag;
+
+ varname = argv[0];
+ flag = argv[1];
+
+ /*
StringValue(varname);
+ */
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return Qtrue;
}
@@ -5892,9 +6844,9 @@
if (ptr->return_value == TCL_ERROR) {
if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
#if TCL_MAJOR_VERSION >= 8
- rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+ return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
#else /* TCL_MAJOR_VERSION < 8 */
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
#endif
}
return Qfalse;
@@ -5903,28 +6855,51 @@
}
static VALUE
-ip_unset_variable2(self, varname_arg, index_arg, flag_arg)
+ip_unset_variable(self, varname, flag)
VALUE self;
- VALUE varname_arg;
- VALUE index_arg;
- VALUE flag_arg;
+ VALUE varname;
+ VALUE flag;
{
- struct tcltkip *ptr = get_ip(self);
- volatile VALUE varname, index, value, flag;
+ VALUE *argv;
+ VALUE retval;
- if (NIL_P(index_arg)) {
- return ip_unset_variable(self, varname_arg, flag_arg);
- }
+ argv = ALLOC_N(VALUE, 2);
+ StringValue(varname);
+ argv[0] = varname;
+ argv[1] = flag;
+
+ retval = tk_funcall(ip_unset_variable_core, 2, argv, self);
- varname = varname_arg;
- index = index_arg;
- flag = flag_arg;
+ free(argv);
+
+ return retval;
+}
+static VALUE
+ip_unset_variable2_core(interp, argc, argv)
+ VALUE interp;
+ int argc;
+ VALUE *argv;
+{
+ struct tcltkip *ptr = get_ip(interp);
+ volatile VALUE varname, index, flag;
+
+ varname = argv[0];
+ index = argv[1];
+ flag = argv[2];
+
+ /*
StringValue(varname);
StringValue(index);
+ */
/* ip is deleted? */
- if (Tcl_InterpDeleted(ptr->ip) || rbtk_invalid_namespace(ptr)) {
+ if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL
+ || Tcl_InterpDeleted(ptr->ip)
+#if TCL_NAMESPACE_DEBUG
+ || rbtk_invalid_namespace(ptr)
+#endif
+ ) {
DUMP1("ip is deleted");
return Qtrue;
}
@@ -5934,9 +6909,9 @@
if (ptr->return_value == TCL_ERROR) {
if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
#if TCL_MAJOR_VERSION >= 8
- rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+ return rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
#else /* TCL_MAJOR_VERSION < 8 */
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
#endif
}
return Qfalse;
@@ -5945,6 +6920,35 @@
}
static VALUE
+ip_unset_variable2(self, varname, index, flag)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+ VALUE flag;
+{
+ VALUE *argv;
+ VALUE retval;
+
+ argv = ALLOC_N(VALUE, 3);
+ StringValue(varname);
+ argv[0] = varname;
+
+ if (NIL_P(index)) {
+ argv[1] = flag;
+ retval = tk_funcall(ip_unset_variable_core, 2, argv, self);
+ } else {
+ StringValue(index);
+ argv[1] = index;
+ argv[2] = flag;
+ retval = tk_funcall(ip_unset_variable2_core, 3, argv, self);
+ }
+
+ free(argv);
+
+ return retval;
+}
+
+static VALUE
ip_get_global_var(self, varname)
VALUE self;
VALUE varname;
@@ -6019,6 +7023,8 @@
if (NIL_P(ip_obj)) {
interp = (Tcl_Interp *)NULL;
+ } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
+ interp = (Tcl_Interp *)NULL;
} else {
interp = get_ip(ip_obj)->ip;
}
@@ -6403,6 +7409,8 @@
rb_global_variable(&eventloop_thread);
rb_global_variable(&watchdog_thread);
+ rb_global_variable(&rbtk_pending_exception);
+
/* --------------------------------------------------------------- */
rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info());
@@ -6569,6 +7577,8 @@
eventloop_thread = 0;
watchdog_thread = 0;
+
+ rbtk_pending_exception = 0;
/* --------------------------------------------------------------- */
Index: lib/multi-tk.rb
===================================================================
RCS file: /var/cvs/src/ruby/ext/tk/lib/multi-tk.rb,v
retrieving revision 1.38
diff -u -r1.38 multi-tk.rb
--- lib/multi-tk.rb 31 Jan 2005 04:14:50 -0000 1.38
+++ lib/multi-tk.rb 9 Feb 2005 08:53:11 -0000
@@ -411,7 +411,8 @@
def _receiver_mainloop(check_root)
Thread.new{
while !@interp.deleted?
- break if @interp._invoke_without_enc('info', 'command', '.').size == 0
+ inf = @interp._invoke_without_enc('info', 'command', '.')
+ break if !inf.kind_of?(String) || inf != '.'
sleep 0.5
end
}
@@ -970,9 +971,11 @@
######################################
def _default_delete_hook(slave)
- if @slave_ip_top[slave].kind_of?(String)
+ @slave_ip_tbl.delete(slave)
+ top = @slave_ip_top.delete(slave)
+ if top.kind_of?(String)
# call default hook of safetk.tcl (ignore exceptions)
- if @slave_ip_top[slave] == ''
+ if top == ''
begin
@interp._eval("::safe::disallowTk #{slave}")
rescue
@@ -980,20 +983,19 @@
end
else # toplevel path
begin
- @interp._eval("::safe::tkDelete {} #{@slave_ip_top[slave]} #{slave}")
+ @interp._eval("::safe::tkDelete {} #{top} #{slave}")
rescue
warn("Waring: fail to call '::safe::tkDelete'") if $DEBUG
begin
- @interp._eval("destroy #{@slave_ip_top[slave]}")
+ @interp._eval("destroy #{top}")
rescue
warn("Waring: fail to destroy toplevel") if $DEBUG
end
end
end
end
- @slave_ip_tbl.delete(slave)
- @slave_ip_top.delete(slave)
end
+
end
@@ -1739,7 +1741,7 @@
# depend on TclTkIp
class MultiTkIp
- def mainloop(check_root = true, restart_on_dead = false)
+ def mainloop(check_root = true, restart_on_dead = true)
#return self if self.slave?
#return self if self != @@DEFAULT_MASTER
if self != @@DEFAULT_MASTER
@@ -1752,7 +1754,11 @@
rescue MultiTkIp_OK => ret
# return value
@wait_on_mainloop[1] = false
- return ret.value.value
+ if ret.value.kind_of?(Thread)
+ return ret.value.value
+ else
+ return ret.value
+ end
rescue SystemExit
# exit IP
warn("Warning: " + $! + " on " + self.inspect) if $DEBUG
@@ -1762,7 +1768,7 @@
rescue Exception
end
self.delete
- rescue Exception => e
+ rescue StandardError => e
if $DEBUG
warn("Warning: " + e.class.inspect +
((e.message.length > 0)? ' "' + e.message + '"': '') +
@@ -1779,31 +1785,47 @@
unless restart_on_dead
@wait_on_mainloop[1] = true
+=begin
+ begin
+ @interp.mainloop(check_root)
+ rescue StandardError => e
+ if $DEBUG
+ warn("Warning: " + e.class.inspect +
+ ((e.message.length > 0)? ' "' + e.message + '"': '') +
+ " on " + self.inspect)
+ end
+ end
+=end
@interp.mainloop(check_root)
@wait_on_mainloop[1] = false
else
- begin
+ loop do
@wait_on_mainloop[1] = true
- loop do
- break unless self.alive?
- if check_root
- begin
- break if TclTkLib.num_of_mainwindows == 0
- rescue Exception
- break
- end
+ break unless self.alive?
+ if check_root
+ begin
+ break if TclTkLib.num_of_mainwindows == 0
+ rescue StandardError
+ break
end
- @interp.mainloop(check_root)
end
- #rescue StandardError
- rescue Exception
- if TclTkLib.mainloop_abort_on_exception != nil
- STDERR.print("Warning: Tk mainloop receives ", $!.class.inspect,
- " exception (ignore) : ", $!.message, "\n");
+ break if @interp.deleted?
+ begin
+ @interp.mainloop(check_root)
+ rescue StandardError
+ if TclTkLib.mainloop_abort_on_exception != nil
+ #STDERR.print("Warning: Tk mainloop receives ", $!.class.inspect,
+ # " exception (ignore) : ", $!.message, "\n");
+ if $DEBUG
+ warn("Warning: Tk mainloop receives ", $!.class.inspect,
+ " exception (ignore) : ", $!.message, "\n");
+ end
+ end
+ rescue Exception=>e
+ ensure
+ @wait_on_mainloop[1] = false
+ Thread.pass
end
- retry
- ensure
- @wait_on_mainloop[1] = false
end
end
self
@@ -1875,18 +1897,17 @@
@interp._eval_without_enc("foreach i {#{after_ids}} {after cancel $i}")
rescue Exception
end
-=begin
+
begin
@interp._invoke('destroy', '.') unless @interp.deleted?
rescue Exception
end
-=end
+
if @safe_base && !@interp.deleted?
# do 'exit' to call the delete_hook procedure
@interp._eval_without_enc('exit')
- else
- @interp.delete unless @interp.deleted?
end
+ @interp.delete
self
end
Index: lib/tk.rb
===================================================================
RCS file: /var/cvs/src/ruby/ext/tk/lib/tk.rb,v
retrieving revision 1.141
diff -u -r1.141 tk.rb
--- lib/tk.rb 31 Jan 2005 04:14:50 -0000 1.141
+++ lib/tk.rb 9 Feb 2005 08:53:13 -0000
@@ -3940,7 +3940,7 @@
#Tk.freeze
module Tk
- RELEASE_DATE = '2005-01-28'.freeze
+ RELEASE_DATE = '2005-02-09'.freeze
autoload :AUTO_PATH, 'tk/variable'
autoload :TCL_PACKAGE_PATH, 'tk/variable'
Index: lib/tk/clock.rb
===================================================================
RCS file: /var/cvs/src/ruby/ext/tk/lib/tk/clock.rb,v
retrieving revision 1.3
diff -u -r1.3 clock.rb
--- lib/tk/clock.rb 20 Dec 2004 05:10:59 -0000 1.3
+++ lib/tk/clock.rb 9 Feb 2005 08:53:13 -0000
@@ -10,8 +10,9 @@
end
def self.clicks(ms=nil)
+ ms = ms.to_s if ms.kind_of?(Symbol)
case ms
- when nil
+ when nil, ''
tk_call_without_enc('clock','clicks').to_i
when /^mic/
tk_call_without_enc('clock','clicks','-microseconds').to_i
Index: lib/tk/timer.rb
===================================================================
RCS file: /var/cvs/src/ruby/ext/tk/lib/tk/timer.rb,v
retrieving revision 1.10
diff -u -r1.10 timer.rb
--- lib/tk/timer.rb 16 Dec 2004 07:13:12 -0000 1.10
+++ lib/tk/timer.rb 9 Feb 2005 08:53:13 -0000
@@ -420,6 +420,7 @@
@wait_var.value = 0
tk_call 'after', 'cancel', @after_id if @after_id
@after_id = nil
+
Tk_CBTBL.delete(@id) ;# for GC
self
end
Index: lib/tk/variable.rb
===================================================================
RCS file: /var/cvs/src/ruby/ext/tk/lib/tk/variable.rb,v
retrieving revision 1.10
diff -u -r1.10 variable.rb
--- lib/tk/variable.rb 4 Nov 2004 06:03:53 -0000 1.10
+++ lib/tk/variable.rb 9 Feb 2005 08:53:13 -0000
@@ -306,6 +306,7 @@
}
self.value
elsif val.kind_of?(Array)
+=begin
INTERP._set_global_var(@id, '')
val.each{|v|
#INTERP._set_variable(@id, _toUTF8(_get_eval_string(v)),
@@ -316,6 +317,8 @@
TclTkLib::VarAccessFlag::LIST_ELEMENT)
}
self.value
+=end
+ _fromUTF8(INTERP._set_global_var(@id, array2tk_list(val)))
else
#_fromUTF8(INTERP._set_global_var(@id, _toUTF8(_get_eval_string(val))))
_fromUTF8(INTERP._set_global_var(@id, _get_eval_string(val, true)))
@@ -554,6 +557,29 @@
raise ArgumentError, "Array is expected"
end
val
+ end
+
+ def lappend(*elems)
+ tk_call('lappend', @id, *elems)
+ self
+ end
+
+ def lindex(idx)
+ tk_call('lindex', self.value, idx)
+ end
+ alias lget lindex
+
+ def lget_i(idx)
+ number(lget(idx)).to_i
+ end
+
+ def lget_f(idx)
+ number(lget(idx)).to_f
+ end
+
+ def lset(idx, val)
+ tk_call('lset', @id, idx, val)
+ self
end
def inspect
--
永井 秀利 （九工大 知能情報）
nagai@ai.kyutech.ac.jp