Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

10259 lines (8771 sloc) 281.622 kB
/*
* tcltklib.c
* Aug. 27, 1997 Y. Shigehiro
* Oct. 24, 1997 Y. Matsumoto
*/
#define TCLTKLIB_RELEASE_DATE "2008-05-23"
#include "ruby.h"
#ifdef RUBY_VM
/* #include "ruby/ruby.h" */
#include "ruby/signal.h"
#include "ruby/encoding.h"
#else
/* #include "ruby.h" */
#include "rubysig.h"
#include "version.h"
#endif
#undef EXTERN /* avoid conflict with tcl.h of tcl8.2 or before */
#include <stdio.h>
#ifdef HAVE_STDARG_PROTOTYPES
#include <stdarg.h>
#define va_init_list(a,b) va_start(a,b)
#else
#include <varargs.h>
#define va_init_list(a,b) va_start(a)
#endif
#include <string.h>
#include <tcl.h>
#include <tk.h>
#include "stubs.h"
#ifndef TCL_ALPHA_RELEASE
#define TCL_ALPHA_RELEASE 0
#define TCL_BETA_RELEASE 1
#define TCL_FINAL_RELEASE 2
#endif
static struct {
int major;
int minor;
int patchlevel;
int type;
} tcltk_version = {0, 0, 0, 0};
static void
set_tcltk_version()
{
if (tcltk_version.major) return;
Tcl_GetVersion(&(tcltk_version.major),
&(tcltk_version.minor),
&(tcltk_version.patchlevel),
&(tcltk_version.type));
}
#if TCL_MAJOR_VERSION >= 8
# ifndef CONST84
# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */
# define CONST84
# else /* unknown (maybe TCL_VERSION >= 8.5) */
# ifdef CONST
# define CONST84 CONST
# else
# define CONST84
# endif
# endif
# endif
#else /* TCL_MAJOR_VERSION < 8 */
# ifdef CONST
# define CONST84 CONST
# else
# define CONST
# define CONST84
# endif
#endif
/* copied from eval.c */
#define TAG_RETURN 0x1
#define TAG_BREAK 0x2
#define TAG_NEXT 0x3
#define TAG_RETRY 0x4
#define TAG_REDO 0x5
#define TAG_RAISE 0x6
#define TAG_THROW 0x7
#define TAG_FATAL 0x8
/* for ruby_debug */
#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); }
#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); }
#define DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); }
/*
#define DUMP1(ARG1)
#define DUMP2(ARG1, ARG2)
#define DUMP3(ARG1, ARG2, ARG3)
*/
/* release date */
const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE;
/* finalize_proc_name */
static char *finalize_hook_name = "INTERP_FINALIZE_HOOK";
static void ip_finalize _((Tcl_Interp*));
static int at_exit = 0;
#ifdef RUBY_VM
static VALUE cRubyEncoding;
/* encoding */
static int ENCODING_INDEX_UTF8;
static int ENCODING_INDEX_BINARY;
#endif
static VALUE ENCODING_NAME_UTF8;
static VALUE ENCODING_NAME_BINARY;
static VALUE create_dummy_encoding_for_tk_core _((VALUE, VALUE, VALUE));
static VALUE create_dummy_encoding_for_tk _((VALUE, VALUE));
static int update_encoding_table _((VALUE, VALUE, VALUE));
static VALUE encoding_table_get_name_core _((VALUE, VALUE, VALUE));
static VALUE encoding_table_get_obj_core _((VALUE, VALUE, VALUE));
static VALUE encoding_table_get_name _((VALUE, VALUE));
static VALUE encoding_table_get_obj _((VALUE, VALUE));
static VALUE create_encoding_table _((VALUE));
static VALUE ip_get_encoding_table _((VALUE));
/* for callback break & continue */
static VALUE eTkCallbackReturn;
static VALUE eTkCallbackBreak;
static VALUE eTkCallbackContinue;
static VALUE eLocalJumpError;
static VALUE eTkLocalJumpError;
static VALUE eTkCallbackRetry;
static VALUE eTkCallbackRedo;
static VALUE eTkCallbackThrow;
static VALUE tcltkip_class;
static ID ID_at_enc;
static ID ID_at_interp;
static ID ID_encoding_name;
static ID ID_encoding_table;
static ID ID_stop_p;
static ID ID_alive_p;
static ID ID_kill;
static ID ID_join;
static ID ID_value;
static ID ID_call;
static ID ID_backtrace;
static ID ID_message;
static ID ID_at_reason;
static ID ID_return;
static ID ID_break;
static ID ID_next;
static ID ID_to_s;
static ID ID_inspect;
static VALUE ip_invoke_real _((int, VALUE*, VALUE));
static VALUE ip_invoke _((int, VALUE*, VALUE));
static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition));
static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE));
/* Tcl's object type */
#if TCL_MAJOR_VERSION >= 8
static char *Tcl_ObjTypeName_ByteArray = "bytearray";
static Tcl_ObjType *Tcl_ObjType_ByteArray;
static char *Tcl_ObjTypeName_String = "string";
static Tcl_ObjType *Tcl_ObjType_String;
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
#define IS_TCL_BYTEARRAY(obj) ((obj)->typePtr == Tcl_ObjType_ByteArray)
#define IS_TCL_STRING(obj) ((obj)->typePtr == Tcl_ObjType_String)
#define IS_TCL_VALID_STRING(obj) ((obj)->bytes != (char*)NULL)
#endif
#endif
#ifndef HAVE_RB_HASH_LOOKUP
#define rb_hash_lookup rb_hash_aref
#endif
/* safe Tcl_Eval and Tcl_GlobalEval */
static int
#ifdef RUBY_VM
tcl_eval(Tcl_Interp *interp, const char *cmd)
#else
tcl_eval(interp, cmd)
Tcl_Interp *interp;
const char *cmd; /* don't have to be writable */
#endif
{
char *buf = strdup(cmd);
int ret;
Tcl_AllowExceptions(interp);
ret = Tcl_Eval(interp, buf);
free(buf);
return ret;
}
#undef Tcl_Eval
#define Tcl_Eval tcl_eval
static int
#ifdef RUBY_VM
tcl_global_eval(Tcl_Interp *interp, const char *cmd)
#else
tcl_global_eval(interp, cmd)
Tcl_Interp *interp;
const char *cmd; /* don't have to be writable */
#endif
{
char *buf = strdup(cmd);
int ret;
Tcl_AllowExceptions(interp);
ret = Tcl_GlobalEval(interp, buf);
free(buf);
return ret;
}
#undef Tcl_GlobalEval
#define Tcl_GlobalEval tcl_global_eval
/* Tcl_{Incr|Decr}RefCount for tcl7.x or earlier */
#if TCL_MAJOR_VERSION < 8
#define Tcl_IncrRefCount(obj) (1)
#define Tcl_DecrRefCount(obj) (1)
#endif
/* Tcl_GetStringResult for tcl7.x or earlier */
#if TCL_MAJOR_VERSION < 8
#define Tcl_GetStringResult(interp) ((interp)->result)
#endif
/* Tcl_[GS]etVar2Ex for tcl8.0 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
static Tcl_Obj *
Tcl_GetVar2Ex(interp, name1, name2, flags)
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
nameObj1 = Tcl_NewStringObj((char*)name1, -1);
Tcl_IncrRefCount(nameObj1);
if (name2) {
nameObj2 = Tcl_NewStringObj((char*)name2, -1);
Tcl_IncrRefCount(nameObj2);
}
retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags);
if (name2) {
Tcl_DecrRefCount(nameObj2);
}
Tcl_DecrRefCount(nameObj1);
return retObj;
}
static Tcl_Obj *
Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags)
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
Tcl_Obj *newValObj;
int flags;
{
Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
nameObj1 = Tcl_NewStringObj((char*)name1, -1);
Tcl_IncrRefCount(nameObj1);
if (name2) {
nameObj2 = Tcl_NewStringObj((char*)name2, -1);
Tcl_IncrRefCount(nameObj2);
}
retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags);
if (name2) {
Tcl_DecrRefCount(nameObj2);
}
Tcl_DecrRefCount(nameObj1);
return retObj;
}
#endif
/* from tkAppInit.c */
#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4)
# if !defined __MINGW32__ && !defined __BORLANDC__
/*
* The following variable is a special hack that is needed in order for
* Sun shared libraries to be used for Tcl.
*/
extern int matherr();
int *tclDummyMathPtr = (int *) matherr;
# endif
#endif
/*---- module TclTkLib ----*/
struct invoke_queue {
Tcl_Event ev;
int argc;
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **argv;
#else /* TCL_MAJOR_VERSION < 8 */
char **argv;
#endif
VALUE interp;
int *done;
int safe_level;
VALUE result;
VALUE thread;
};
struct eval_queue {
Tcl_Event ev;
char *str;
int len;
VALUE interp;
int *done;
int safe_level;
VALUE result;
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)
{
rb_gc_mark(q->interp);
rb_gc_mark(q->result);
rb_gc_mark(q->thread);
}
void
eval_queue_mark(struct eval_queue *q)
{
rb_gc_mark(q->interp);
rb_gc_mark(q->result);
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;
#ifdef RUBY_VM
Tcl_ThreadId tk_eventloop_thread_id; /* native thread ID of Tcl interpreter */
#endif
static VALUE eventloop_stack;
static int window_event_mode = ( ~ TCL_IDLE_EVENTS | TCL_WINDOW_EVENTS );
static VALUE watchdog_thread;
Tcl_Interp *current_interp;
/* thread control strategy */
/* multi-tk works with the following settings only ???
: CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
: USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
: DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
*/
#define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
#define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
static int have_rb_thread_waiting_for_value = 0;
#endif
/*
* 'event_loop_max' is a maximum events which the eventloop processes in one
* term of thread scheduling. 'no_event_tick' is the count-up value when
* there are no event for processing.
* 'timer_tick' is a limit of one term of thread scheduling.
* If 'timer_tick' == 0, then not use the timer for thread scheduling.
*/
#ifdef RUBY_VM
#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/
#define DEFAULT_NO_EVENT_TICK 10/*counts*/
#define DEFAULT_NO_EVENT_WAIT 10/*milliseconds ( 1 -- 999 ) */
#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */
#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */
#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */
#else /* ! RUBY_VM */
#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/
#define DEFAULT_NO_EVENT_TICK 10/*counts*/
#define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */
#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */
#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */
#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */
#endif
static int event_loop_max = DEFAULT_EVENT_LOOP_MAX;
static int no_event_tick = DEFAULT_NO_EVENT_TICK;
static int no_event_wait = DEFAULT_NO_EVENT_WAIT;
static int timer_tick = DEFAULT_TIMER_TICK;
static int req_timer_tick = DEFAULT_TIMER_TICK;
static int run_timer_flag = 0;
static int event_loop_wait_event = 0;
static int event_loop_abort_on_exc = 1;
static int loop_counter = 0;
static int check_rootwidget_flag = 0;
/* call ruby interpreter */
#if TCL_MAJOR_VERSION >= 8
static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
#else /* TCL_MAJOR_VERSION < 8 */
static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **));
static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **));
#endif
struct cmd_body_arg {
VALUE receiver;
ID method;
VALUE args;
};
/*----------------------------*/
/* 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 */
# ifndef Tcl_GetCurrentNamespace
EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *));
# endif
# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# ifndef Tcl_GetCurrentNamespace
# ifndef FunctionNum_of_GetCurrentNamespace
#define FunctionNum_of_GetCurrentNamespace 124
# endif
struct DummyTclIntStubs_for_GetCurrentNamespace {
int magic;
struct TclIntStubHooks *hooks;
void (*func[FunctionNum_of_GetCurrentNamespace])();
Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *));
};
#define 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
#ifdef RUBY_VM
Tcl_ThreadId tk_thread_id; /* native thread ID of Tcl interpreter */
#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 */
int allow_ruby_exit; /* allow exiting ruby by 'exit' function */
int return_value; /* return value */
};
static struct tcltkip *
get_ip(self)
VALUE self;
{
struct tcltkip *ptr;
Data_Get_Struct(self, struct tcltkip, ptr);
if (ptr == 0) {
/* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */
return((struct tcltkip *)NULL);
}
if (ptr->ip == (Tcl_Interp*)NULL) {
/* rb_raise(rb_eRuntimeError, "deleted IP"); */
return((struct tcltkip *)NULL);
}
return ptr;
}
static int
deleted_ip(ptr)
struct tcltkip *ptr;
{
if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip)
#if TCL_NAMESPACE_DEBUG
|| rbtk_invalid_namespace(ptr)
#endif
) {
DUMP1("ip is deleted");
return 1;
}
return 0;
}
/* increment/decrement reference count of tcltkip */
static int
rbtk_preserve_ip(ptr)
struct tcltkip *ptr;
{
ptr->ref_count++;
if (ptr->ip == (Tcl_Interp*)NULL) {
/* deleted IP */
ptr->ref_count = 0;
} else {
Tcl_Preserve((ClientData)ptr->ip);
}
return(ptr->ref_count);
}
static int
rbtk_release_ip(ptr)
struct tcltkip *ptr;
{
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);
}
return(ptr->ref_count);
}
static VALUE
#ifdef HAVE_STDARG_PROTOTYPES
create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
#else
create_ip_exc(interp, exc, fmt, va_alist)
VALUE interp:
VALUE exc;
const char *fmt;
va_dcl
#endif
{
va_list args;
char buf[BUFSIZ];
VALUE einfo;
struct tcltkip *ptr = get_ip(interp);
va_init_list(args,fmt);
vsnprintf(buf, BUFSIZ, fmt, args);
buf[BUFSIZ - 1] = '\0';
va_end(args);
einfo = rb_exc_new2(exc, buf);
rb_ivar_set(einfo, ID_at_interp, interp);
if (ptr) {
Tcl_ResetResult(ptr->ip);
}
return einfo;
}
/* stub status */
static void
tcl_stubs_check()
{
if (!tcl_stubs_init_p()) {
int st = ruby_tcl_stubs_init();
switch(st) {
case TCLTK_STUBS_OK:
break;
case NO_TCL_DLL:
rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
case NO_FindExecutable:
rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
case NO_CreateInterp:
rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
case NO_DeleteInterp:
rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
case FAIL_CreateInterp:
rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()");
case FAIL_Tcl_InitStubs:
rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
default:
rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st);
}
}
}
static VALUE
tcltkip_init_tk(interp)
VALUE interp;
{
struct tcltkip *ptr = get_ip(interp);
#if TCL_MAJOR_VERSION >= 8
int st;
if (Tcl_IsSafe(ptr->ip)) {
DUMP1("Tk_SafeInit");
st = ruby_tk_stubs_safeinit(ptr->ip);
switch(st) {
case TCLTK_STUBS_OK:
break;
case NO_Tk_Init:
return rb_exc_new2(rb_eLoadError,
"tcltklib: can't find Tk_SafeInit()");
case FAIL_Tk_Init:
return create_ip_exc(interp, rb_eRuntimeError,
"tcltklib: fail to Tk_SafeInit(). %s",
Tcl_GetStringResult(ptr->ip));
case FAIL_Tk_InitStubs:
return create_ip_exc(interp, rb_eRuntimeError,
"tcltklib: fail to Tk_InitStubs(). %s",
Tcl_GetStringResult(ptr->ip));
default:
return create_ip_exc(interp, rb_eRuntimeError,
"tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st);
}
} else {
DUMP1("Tk_Init");
st = ruby_tk_stubs_init(ptr->ip);
switch(st) {
case TCLTK_STUBS_OK:
break;
case NO_Tk_Init:
return rb_exc_new2(rb_eLoadError,
"tcltklib: can't find Tk_Init()");
case FAIL_Tk_Init:
return create_ip_exc(interp, rb_eRuntimeError,
"tcltklib: fail to Tk_Init(). %s",
Tcl_GetStringResult(ptr->ip));
case FAIL_Tk_InitStubs:
return create_ip_exc(interp, rb_eRuntimeError,
"tcltklib: fail to Tk_InitStubs(). %s",
Tcl_GetStringResult(ptr->ip));
default:
return create_ip_exc(interp, rb_eRuntimeError,
"tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
}
}
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tk_Init");
if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) {
return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
}
#endif
#ifdef RUBY_VM
ptr->tk_thread_id = Tcl_GetCurrentThread();
#endif
return Qnil;
}
/* treat excetiopn on Tcl side */
static VALUE rbtk_pending_exception;
static int rbtk_eventloop_depth = 0;
static int rbtk_internal_eventloop_handler = 0;
static int
pending_exception_check0()
{
volatile VALUE exc = rbtk_pending_exception;
if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
DUMP1("find a pending exception");
if (rbtk_eventloop_depth > 0
|| rbtk_internal_eventloop_handler > 0
) {
return 1; /* pending */
} else {
rbtk_pending_exception = Qnil;
if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
DUMP1("pending_exception_check0: call rb_jump_tag(retry)");
rb_jump_tag(TAG_RETRY);
} else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
DUMP1("pending_exception_check0: call rb_jump_tag(redo)");
rb_jump_tag(TAG_REDO);
} else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
DUMP1("pending_exception_check0: call rb_jump_tag(throw)");
rb_jump_tag(TAG_THROW);
}
rb_exc_raise(exc);
}
} else {
return 0;
}
}
static int
pending_exception_check1(thr_crit_bup, ptr)
int thr_crit_bup;
struct tcltkip *ptr;
{
volatile VALUE exc = rbtk_pending_exception;
if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
DUMP1("find a pending exception");
if (rbtk_eventloop_depth > 0
|| rbtk_internal_eventloop_handler > 0
) {
return 1; /* pending */
} else {
rbtk_pending_exception = Qnil;
if (ptr != (struct tcltkip *)NULL) {
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
}
rb_thread_critical = thr_crit_bup;
if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
DUMP1("pending_exception_check1: call rb_jump_tag(retry)");
rb_jump_tag(TAG_RETRY);
} else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
DUMP1("pending_exception_check1: call rb_jump_tag(redo)");
rb_jump_tag(TAG_REDO);
} else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
DUMP1("pending_exception_check1: call rb_jump_tag(throw)");
rb_jump_tag(TAG_THROW);
}
rb_exc_raise(exc);
}
} else {
return 0;
}
}
/* call original 'exit' command */
static void
call_original_exit(ptr, state)
struct tcltkip *ptr;
int state;
{
int thr_crit_bup;
Tcl_CmdInfo *info;
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj *cmd_obj;
Tcl_Obj *state_obj;
#endif
DUMP1("original_exit is called");
if (!(ptr->has_orig_exit)) return;
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tcl_ResetResult(ptr->ip);
info = &(ptr->orig_exit_info);
/* memory allocation for arguments of this command */
#if TCL_MAJOR_VERSION >= 8
state_obj = Tcl_NewIntObj(state);
Tcl_IncrRefCount(state_obj);
if (info->isNativeObjectProc) {
Tcl_Obj **argv;
#define USE_RUBY_ALLOC 0
#if USE_RUBY_ALLOC
argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3);
#else /* not USE_RUBY_ALLOC */
argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
#endif
cmd_obj = Tcl_NewStringObj("exit", 4);
Tcl_IncrRefCount(cmd_obj);
argv[0] = cmd_obj;
argv[1] = state_obj;
argv[2] = (Tcl_Obj *)NULL;
ptr->return_value
= (*(info->objProc))(info->objClientData, ptr->ip, 2, argv);
Tcl_DecrRefCount(cmd_obj);
#if USE_RUBY_ALLOC
free(argv);
#else /* not USE_RUBY_ALLOC */
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)argv); /* XXXXXXXX */
#else
/* free(argv); */
ckfree((char*)argv);
#endif
#endif
#endif
#undef USE_RUBY_ALLOC
} else {
/* string interface */
char **argv;
#define USE_RUBY_ALLOC 0
#if USE_RUBY_ALLOC
argv = (char **)ALLOC_N(char *, 3); /* XXXXXXXXXX */
#else /* not USE_RUBY_ALLOC */
argv = (char **)ckalloc(sizeof(char *) * 3);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
#endif
argv[0] = "exit";
/* argv[1] = Tcl_GetString(state_obj); */
argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL);
argv[2] = (char *)NULL;
ptr->return_value = (*(info->proc))(info->clientData, ptr->ip,
2, (CONST84 char **)argv);
#if USE_RUBY_ALLOC
free(argv);
#else /* not USE_RUBY_ALLOC */
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)argv); /* XXXXXXXX */
#else
/* free(argv); */
ckfree((char*)argv);
#endif
#endif
#endif
#undef USE_RUBY_ALLOC
}
Tcl_DecrRefCount(state_obj);
#else /* TCL_MAJOR_VERSION < 8 */
{
/* string interface */
char **argv;
#define USE_RUBY_ALLOC 0
#if USE_RUBY_ALLOC
argv = (char **)ALLOC_N(char *, 3);
#else /* not USE_RUBY_ALLOC */
argv = (char **)ckalloc(sizeof(char *) * 3);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
#endif
argv[0] = "exit";
argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10));
argv[2] = (char *)NULL;
ptr->return_value = (*(info->proc))(info->clientData, ptr->ip,
2, argv);
#if USE_RUBY_ALLOC
free(argv);
#else /* not USE_RUBY_ALLOC */
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)argv); /* XXXXXXXX */
#else
/* free(argv); */
ckfree(argv);
#endif
#endif
#endif
#undef USE_RUBY_ALLOC
}
#endif
DUMP1("complete original_exit");
rb_thread_critical = thr_crit_bup;
}
/* Tk_ThreadTimer */
static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL;
/* timer callback */
static void _timer_for_tcl _((ClientData));
static void
_timer_for_tcl(clientData)
ClientData clientData;
{
int thr_crit_bup;
/* struct invoke_queue *q, *tmp; */
/* VALUE thread; */
DUMP1("call _timer_for_tcl");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tcl_DeleteTimerHandler(timer_token);
run_timer_flag = 1;
if (timer_tick > 0) {
timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
(ClientData)0);
} else {
timer_token = (Tcl_TimerToken)NULL;
}
rb_thread_critical = thr_crit_bup;
/* rb_thread_schedule(); */
/* tick_counter += event_loop_max; */
}
#ifdef RUBY_VM
#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
static int
toggle_eventloop_window_mode_for_idle()
{
if (window_event_mode & TCL_IDLE_EVENTS) {
/* idle -> event */
window_event_mode |= TCL_WINDOW_EVENTS;
window_event_mode &= ~TCL_IDLE_EVENTS;
return 1;
} else {
/* event -> idle */
window_event_mode |= TCL_IDLE_EVENTS;
window_event_mode &= ~TCL_WINDOW_EVENTS;
return 0;
}
}
#endif
#endif
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;
VALUE tick;
{
int ttick = NUM2INT(tick);
int thr_crit_bup;
rb_secure(4);
if (ttick < 0) {
rb_raise(rb_eArgError,
"timer-tick parameter must be 0 or positive number");
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* delete old timer callback */
Tcl_DeleteTimerHandler(timer_token);
timer_tick = req_timer_tick = ttick;
if (timer_tick > 0) {
/* start timer callback */
timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
(ClientData)0);
} else {
timer_token = (Tcl_TimerToken)NULL;
}
rb_thread_critical = thr_crit_bup;
return tick;
}
static VALUE
get_eventloop_tick(self)
VALUE self;
{
return INT2NUM(timer_tick);
}
static VALUE
ip_set_eventloop_tick(self, tick)
VALUE self;
VALUE tick;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return get_eventloop_tick(self);
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return get_eventloop_tick(self);
}
return set_eventloop_tick(self, tick);
}
static VALUE
ip_get_eventloop_tick(self)
VALUE self;
{
return get_eventloop_tick(self);
}
static VALUE
set_no_event_wait(self, wait)
VALUE self;
VALUE wait;
{
int t_wait = NUM2INT(wait);
rb_secure(4);
if (t_wait <= 0) {
rb_raise(rb_eArgError,
"no_event_wait parameter must be positive number");
}
no_event_wait = t_wait;
return wait;
}
static VALUE
get_no_event_wait(self)
VALUE self;
{
return INT2NUM(no_event_wait);
}
static VALUE
ip_set_no_event_wait(self, wait)
VALUE self;
VALUE wait;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return get_no_event_wait(self);
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return get_no_event_wait(self);
}
return set_no_event_wait(self, wait);
}
static VALUE
ip_get_no_event_wait(self)
VALUE self;
{
return get_no_event_wait(self);
}
static VALUE
set_eventloop_weight(self, loop_max, no_event)
VALUE self;
VALUE loop_max;
VALUE no_event;
{
int lpmax = NUM2INT(loop_max);
int no_ev = NUM2INT(no_event);
rb_secure(4);
if (lpmax <= 0 || no_ev <= 0) {
rb_raise(rb_eArgError, "weight parameters must be positive numbers");
}
event_loop_max = lpmax;
no_event_tick = no_ev;
return rb_ary_new3(2, loop_max, no_event);
}
static VALUE
get_eventloop_weight(self)
VALUE self;
{
return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick));
}
static VALUE
ip_set_eventloop_weight(self, loop_max, no_event)
VALUE self;
VALUE loop_max;
VALUE no_event;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return get_eventloop_weight(self);
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return get_eventloop_weight(self);
}
return set_eventloop_weight(self, loop_max, no_event);
}
static VALUE
ip_get_eventloop_weight(self)
VALUE self;
{
return get_eventloop_weight(self);
}
static VALUE
set_max_block_time(self, time)
VALUE self;
VALUE time;
{
struct Tcl_Time tcl_time;
VALUE divmod;
switch(TYPE(time)) {
case T_FIXNUM:
case T_BIGNUM:
/* time is micro-second value */
divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000));
tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]);
tcl_time.usec = NUM2LONG(RARRAY_PTR(divmod)[1]);
break;
case T_FLOAT:
/* time is second value */
divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1));
tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]);
tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000);
default:
{
VALUE tmp = rb_funcall(time, ID_inspect, 0, 0);
rb_raise(rb_eArgError, "invalid value for time: '%s'",
StringValuePtr(tmp));
}
}
Tcl_SetMaxBlockTime(&tcl_time);
return Qnil;
}
static VALUE
lib_evloop_thread_p(self)
VALUE self;
{
if (NIL_P(eventloop_thread)) {
return Qnil; /* no eventloop */
} else if (rb_thread_current() == eventloop_thread) {
return Qtrue; /* is eventloop */
} else {
return Qfalse; /* not eventloop */
}
}
static VALUE
lib_evloop_abort_on_exc(self)
VALUE self;
{
if (event_loop_abort_on_exc > 0) {
return Qtrue;
} else if (event_loop_abort_on_exc == 0) {
return Qfalse;
} else {
return Qnil;
}
}
static VALUE
ip_evloop_abort_on_exc(self)
VALUE self;
{
return lib_evloop_abort_on_exc(self);
}
static VALUE
lib_evloop_abort_on_exc_set(self, val)
VALUE self, val;
{
rb_secure(4);
if (RTEST(val)) {
event_loop_abort_on_exc = 1;
} else if (NIL_P(val)) {
event_loop_abort_on_exc = -1;
} else {
event_loop_abort_on_exc = 0;
}
return lib_evloop_abort_on_exc(self);
}
static VALUE
ip_evloop_abort_on_exc_set(self, val)
VALUE self, val;
{
struct tcltkip *ptr = get_ip(self);
rb_secure(4);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return lib_evloop_abort_on_exc(self);
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return lib_evloop_abort_on_exc(self);
}
return lib_evloop_abort_on_exc_set(self, val);
}
static VALUE
lib_num_of_mainwindows_core(self, argc, argv)
VALUE self;
int argc; /* dummy */
VALUE *argv; /* dummy */
{
if (tk_stubs_init_p()) {
return INT2FIX(Tk_GetNumMainWindows());
} else {
return INT2FIX(0);
}
}
static VALUE
lib_num_of_mainwindows(self)
VALUE self;
{
#ifdef RUBY_VM /* Ruby 1.9+ !!! */
return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self);
#else
return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL);
#endif
}
#ifdef RUBY_VM /* Ruby 1.9+ !!! */
static VALUE
call_DoOneEvent_core(flag_val)
VALUE flag_val;
{
int flag;
flag = FIX2INT(flag_val);
if (Tcl_DoOneEvent(flag)) {
return Qtrue;
} else {
return Qfalse;
}
}
static VALUE
call_DoOneEvent(flag_val)
VALUE flag_val;
{
return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val);
}
#else /* Ruby 1.8- */
static VALUE
call_DoOneEvent(flag_val)
VALUE flag_val;
{
int flag;
flag = FIX2INT(flag_val);
if (Tcl_DoOneEvent(flag)) {
return Qtrue;
} else {
return Qfalse;
}
}
#endif
static VALUE
eventloop_sleep(dummy)
VALUE dummy;
{
struct timeval t;
t.tv_sec = (time_t)0;
t.tv_usec = (time_t)(no_event_wait*1000.0);
#ifdef HAVE_NATIVETHREAD
#ifdef RUBY_VM
#if 0
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on eventloop_sleep()");
}
#endif
#else
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());
#ifdef HAVE_NATIVETHREAD
#ifdef RUBY_VM
#if 0
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on eventloop_sleep()");
}
#endif
#else
if (!is_ruby_native_thread()) {
rb_bug("cross-thread violation on eventloop_sleep()");
}
#endif
#endif
return Qnil;
}
#define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0
#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
static int
get_thread_alone_check_flag()
{
#ifdef RUBY_VM
return 0;
#else
set_tcltk_version();
if (tcltk_version.major < 8) {
/* Tcl/Tk 7.x */
return 1;
} else if (tcltk_version.major == 8) {
if (tcltk_version.minor < 5) {
/* Tcl/Tk 8.0 - 8.4 */
return 1;
} else if (tcltk_version.minor == 5) {
if (tcltk_version.type < TCL_FINAL_RELEASE) {
/* Tcl/Tk 8.5a? - 8.5b? */
return 1;
} else {
/* Tcl/Tk 8.5.x */
return 0;
}
} else {
/* Tcl/Tk 8.6 - 8.9 ?? */
return 0;
}
} else {
/* Tcl/Tk 9+ ?? */
return 0;
}
#endif
}
#endif
static int
lib_eventloop_core(check_root, update_flag, check_var, interp)
int check_root;
int update_flag;
int *check_var;
Tcl_Interp *interp;
{
volatile VALUE current = eventloop_thread;
int found_event = 1;
int event_flag;
struct timeval t;
int thr_crit_bup;
int status;
int depth = rbtk_eventloop_depth;
#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
int thread_alone_check_flag = 1;
#endif
if (update_flag) DUMP1("update loop start!!");
t.tv_sec = (time_t)0;
t.tv_usec = (time_t)(no_event_wait*1000.0);
Tcl_DeleteTimerHandler(timer_token);
run_timer_flag = 0;
if (timer_tick > 0) {
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
(ClientData)0);
rb_thread_critical = thr_crit_bup;
} else {
timer_token = (Tcl_TimerToken)NULL;
}
#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
/* version check */
thread_alone_check_flag = get_thread_alone_check_flag();
#endif
for(;;) {
#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
if (thread_alone_check_flag && rb_thread_alone()) {
#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 | TCL_DONT_WAIT; */
}
if (timer_tick == 0 && update_flag == 0) {
timer_tick = NO_THREAD_INTERRUPT_TIME;
timer_token = Tcl_CreateTimerHandler(timer_tick,
_timer_for_tcl,
(ClientData)0);
}
if (check_var != (int *)NULL) {
if (*check_var || !found_event) {
return found_event;
}
if (interp != (Tcl_Interp*)NULL
&& Tcl_InterpDeleted(interp)) {
/* IP for check_var is deleted */
return 0;
}
}
/* found_event = Tcl_DoOneEvent(event_flag); */
found_event = RTEST(rb_protect(call_DoOneEvent,
INT2FIX(event_flag), &status));
if (status) {
switch (status) {
case TAG_RAISE:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rbtk_pending_exception
= rb_exc_new2(rb_eException, "unknown exception");
} else {
#ifdef RUBY_VM
rbtk_pending_exception = rb_errinfo();
#else
rbtk_pending_exception = ruby_errinfo;
#endif
if (!NIL_P(rbtk_pending_exception)) {
if (rbtk_eventloop_depth == 0) {
VALUE exc = rbtk_pending_exception;
rbtk_pending_exception = Qnil;
rb_exc_raise(exc);
} else {
return 0;
}
}
}
break;
case TAG_FATAL:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
} else {
#ifdef RUBY_VM
rb_exc_raise(rb_errinfo());
#else
rb_exc_raise(ruby_errinfo);
#endif
}
}
}
if (depth != rbtk_eventloop_depth) {
DUMP2("DoOneEvent(1) abnormal exit!! %d",
rbtk_eventloop_depth);
}
if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) {
DUMP1("exception on wait");
return 0;
}
if (pending_exception_check0()) {
/* pending -> upper level */
return 0;
}
if (update_flag != 0) {
if (found_event) {
DUMP1("next update loop");
continue;
} else {
DUMP1("update complete");
return 0;
}
}
DUMP1("trap check");
if (rb_trap_pending) {
run_timer_flag = 0;
if (rb_prohibit_interrupt || check_var != (int*)NULL) {
/* pending or on wait command */
return 0;
} else {
rb_trap_exec();
}
}
DUMP1("check Root Widget");
if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
run_timer_flag = 0;
if (rb_trap_pending) {
if (rb_prohibit_interrupt || check_var != (int*)NULL) {
/* pending or on wait command */
return 0;
} else {
rb_trap_exec();
}
}
return 1;
}
if (loop_counter++ > 30000) {
/* fprintf(stderr, "loop_counter > 30000\n"); */
loop_counter = 0;
}
} else {
int tick_counter;
DUMP1("there are other threads");
event_loop_wait_event = 1;
found_event = 1;
if (update_flag) {
event_flag = update_flag | TCL_DONT_WAIT; /* for safety */
} else {
event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT;
}
timer_tick = req_timer_tick;
tick_counter = 0;
while(tick_counter < event_loop_max) {
if (check_var != (int *)NULL) {
if (*check_var || !found_event) {
return found_event;
}
if (interp != (Tcl_Interp*)NULL
&& Tcl_InterpDeleted(interp)) {
/* IP for check_var is deleted */
return 0;
}
}
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));
#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
if (!st) {
if (toggle_eventloop_window_mode_for_idle()) {
/* idle-mode -> event-mode*/
tick_counter = event_loop_max;
} else {
/* event-mode -> idle-mode */
tick_counter = 0;
}
}
#endif
}
#else
/* st = Tcl_DoOneEvent(event_flag); */
st = RTEST(rb_protect(call_DoOneEvent,
INT2FIX(event_flag), &status));
#endif
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
if (have_rb_thread_waiting_for_value) {
have_rb_thread_waiting_for_value = 0;
rb_thread_schedule();
}
#endif
if (status) {
switch (status) {
case TAG_RAISE:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rbtk_pending_exception
= rb_exc_new2(rb_eException,
"unknown exception");
} else {
#ifdef RUBY_VM
rbtk_pending_exception = rb_errinfo();
#else
rbtk_pending_exception = ruby_errinfo;
#endif
if (!NIL_P(rbtk_pending_exception)) {
if (rbtk_eventloop_depth == 0) {
VALUE exc = rbtk_pending_exception;
rbtk_pending_exception = Qnil;
rb_exc_raise(exc);
} else {
return 0;
}
}
}
break;
case TAG_FATAL:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
} else {
#ifdef RUBY_VM
rb_exc_raise(rb_errinfo());
#else
rb_exc_raise(ruby_errinfo);
#endif
}
}
}
if (depth != rbtk_eventloop_depth) {
DUMP2("DoOneEvent(2) abnormal exit!! %d",
rbtk_eventloop_depth);
return 0;
}
DUMP1("trap check");
if (rb_trap_pending) {
run_timer_flag = 0;
if (rb_prohibit_interrupt || check_var != (int*)NULL) {
/* pending or on wait command */
return 0;
} else {
rb_trap_exec();
}
}
if (check_var != (int*)NULL
&& !NIL_P(rbtk_pending_exception)) {
DUMP1("exception on wait");
return 0;
}
if (pending_exception_check0()) {
/* pending -> upper level */
return 0;
}
if (st) {
tick_counter++;
} else {
if (update_flag != 0) {
DUMP1("update complete");
return 0;
}
tick_counter += no_event_tick;
/* rb_thread_wait_for(t); */
rb_protect(eventloop_sleep, Qnil, &status);
if (status) {
switch (status) {
case TAG_RAISE:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rbtk_pending_exception
= rb_exc_new2(rb_eException,
"unknown exception");
} else {
#ifdef RUBY_VM
rbtk_pending_exception = rb_errinfo();
#else
rbtk_pending_exception = ruby_errinfo;
#endif
if (!NIL_P(rbtk_pending_exception)) {
if (rbtk_eventloop_depth == 0) {
VALUE exc = rbtk_pending_exception;
rbtk_pending_exception = Qnil;
rb_exc_raise(exc);
} else {
return 0;
}
}
}
break;
case TAG_FATAL:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rb_exc_raise(rb_exc_new2(rb_eFatal,
"FATAL"));
} else {
#ifdef RUBY_VM
rb_exc_raise(rb_errinfo());
#else
rb_exc_raise(ruby_errinfo);
#endif
}
}
}
}
} else {
DUMP2("sleep eventloop %lx", current);
DUMP2("eventloop thread is %lx", eventloop_thread);
/* rb_thread_stop(); */
rb_thread_sleep_forever();
}
if (!NIL_P(watchdog_thread) && eventloop_thread != current) {
return 1;
}
DUMP1("trap check");
if (rb_trap_pending) {
run_timer_flag = 0;
if (rb_prohibit_interrupt || check_var != (int*)NULL) {
/* pending or on wait command */
return 0;
} else {
rb_trap_exec();
}
}
DUMP1("check Root Widget");
if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
run_timer_flag = 0;
if (rb_trap_pending) {
if (rb_prohibit_interrupt || check_var != (int*)NULL) {
/* pending or on wait command */
return 0;
} else {
rb_trap_exec();
}
}
return 1;
}
if (loop_counter++ > 30000) {
/* fprintf(stderr, "loop_counter > 30000\n"); */
loop_counter = 0;
}
if (run_timer_flag) {
/*
DUMP1("timer interrupt");
run_timer_flag = 0;
*/
break; /* switch to other thread */
}
}
DUMP1("thread scheduling");
rb_thread_schedule();
}
DUMP1("trap check & thread scheduling");
#ifdef RUBY_VM
/* if (update_flag == 0) CHECK_INTS; */ /*XXXXXXXXXXXXX TODO !!!! */
#else
if (update_flag == 0) CHECK_INTS;
#endif
}
return 1;
}
struct evloop_params {
int check_root;
int update_flag;
int *check_var;
Tcl_Interp *interp;
int thr_crit_bup;
};
VALUE
lib_eventloop_main_core(args)
VALUE args;
{
struct evloop_params *params = (struct evloop_params *)args;
check_rootwidget_flag = params->check_root;
if (lib_eventloop_core(params->check_root,
params->update_flag,
params->check_var,
params->interp)) {
return Qtrue;
} else {
return Qfalse;
}
}
VALUE
lib_eventloop_main(args)
VALUE args;
{
return lib_eventloop_main_core(args);
#if 0
volatile VALUE ret;
int status = 0;
ret = rb_protect(lib_eventloop_main_core, args, &status);
switch (status) {
case TAG_RAISE:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rbtk_pending_exception
= rb_exc_new2(rb_eException, "unknown exception");
} else {
#ifdef RUBY_VM
rbtk_pending_exception = rb_errinfo();
#else
rbtk_pending_exception = ruby_errinfo;
#endif
}
return Qnil;
case TAG_FATAL:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
} else {
#ifdef RUBY_VM
rbtk_pending_exception = rb_errinfo();
#else
rbtk_pending_exception = ruby_errinfo;
#endif
}
return Qnil;
}
return ret;
#endif
}
VALUE
lib_eventloop_ensure(args)
VALUE args;
{
struct evloop_params *ptr = (struct evloop_params *)args;
volatile VALUE current_evloop = rb_thread_current();
DUMP2("eventloop_ensure: current-thread : %lx", current_evloop);
DUMP2("eventloop_ensure: eventloop-thread : %lx", eventloop_thread);
if (eventloop_thread != current_evloop) {
DUMP2("finish eventloop %lx (NOT current eventloop)", current_evloop);
rb_thread_critical = ptr->thr_crit_bup;
free(ptr);
/* ckfree((char*)ptr); */
return Qnil;
}
while((eventloop_thread = rb_ary_pop(eventloop_stack))) {
DUMP2("eventloop-ensure: new eventloop-thread -> %lx",
eventloop_thread);
if (eventloop_thread == current_evloop) {
rbtk_eventloop_depth--;
DUMP2("eventloop %lx : back from recursive call", current_evloop);
break;
}
if (NIL_P(eventloop_thread)) {
Tcl_DeleteTimerHandler(timer_token);
timer_token = (Tcl_TimerToken)NULL;
break;
}
/* if (RTEST(rb_funcall(eventloop_thread, ID_alive_p, 0, 0))) { */
if (RTEST(rb_thread_alive_p(eventloop_thread))) {
DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread);
rb_thread_wakeup(eventloop_thread);
break;
}
}
#ifdef RUBY_VM
if (NIL_P(eventloop_thread)) {
tk_eventloop_thread_id = (Tcl_ThreadId) 0;
}
#endif
rb_thread_critical = ptr->thr_crit_bup;
free(ptr);
/* ckfree((char*)ptr);*/
DUMP2("finish current eventloop %lx", current_evloop);
return Qnil;
}
static VALUE
lib_eventloop_launcher(check_root, update_flag, check_var, interp)
int check_root;
int update_flag;
int *check_var;
Tcl_Interp *interp;
{
volatile VALUE parent_evloop = eventloop_thread;
struct evloop_params *args = ALLOC(struct evloop_params);
/* struct evloop_params *args = (struct evloop_params *)ckalloc(sizeof(struct evloop_params)); */
tcl_stubs_check();
eventloop_thread = rb_thread_current();
#ifdef RUBY_VM
tk_eventloop_thread_id = Tcl_GetCurrentThread();
#endif
if (parent_evloop == eventloop_thread) {
DUMP2("eventloop: recursive call on %lx", parent_evloop);
rbtk_eventloop_depth++;
}
if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) {
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");
}
rb_ary_push(eventloop_stack, parent_evloop);
DUMP3("tcltklib: eventloop-thread : %lx -> %lx\n",
parent_evloop, eventloop_thread);
args->check_root = check_root;
args->update_flag = update_flag;
args->check_var = check_var;
args->interp = interp;
args->thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qfalse;
#if 0
return rb_ensure(lib_eventloop_main, (VALUE)args,
lib_eventloop_ensure, (VALUE)args);
#endif
return rb_ensure(lib_eventloop_main_core, (VALUE)args,
lib_eventloop_ensure, (VALUE)args);
}
/* execute Tk_MainLoop */
static VALUE
lib_mainloop(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE check_rootwidget;
if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
check_rootwidget = Qtrue;
} else if (RTEST(check_rootwidget)) {
check_rootwidget = Qtrue;
} else {
check_rootwidget = Qfalse;
}
return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
(int*)NULL, (Tcl_Interp*)NULL);
}
static VALUE
ip_mainloop(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return Qnil;
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return Qnil;
}
return lib_mainloop(argc, argv, self);
}
static VALUE
watchdog_evloop_launcher(check_rootwidget)
VALUE check_rootwidget;
{
return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
(int*)NULL, (Tcl_Interp*)NULL);
}
#define EVLOOP_WAKEUP_CHANCE 3
static VALUE
lib_watchdog_core(check_rootwidget)
VALUE check_rootwidget;
{
VALUE evloop;
int prev_val = -1;
int chance = 0;
int check = RTEST(check_rootwidget);
struct timeval t0, t1;
t0.tv_sec = (time_t)0;
t0.tv_usec = (time_t)((NO_THREAD_INTERRUPT_TIME)*1000.0);
t1.tv_sec = (time_t)0;
t1.tv_usec = (time_t)((WATCHDOG_INTERVAL)*1000.0);
/* check other watchdog thread */
if (!NIL_P(watchdog_thread)) {
if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) {
rb_funcall(watchdog_thread, ID_kill, 0);
} else {
return Qnil;
}
}
watchdog_thread = rb_thread_current();
/* watchdog start */
do {
if (NIL_P(eventloop_thread)
|| (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) {
/* start new eventloop thread */
DUMP2("eventloop thread %lx is sleeping or dead",
eventloop_thread);
evloop = rb_thread_create(watchdog_evloop_launcher,
(void*)&check_rootwidget);
DUMP2("create new eventloop thread %lx", evloop);
loop_counter = -1;
chance = 0;
rb_thread_run(evloop);
} else {
prev_val = loop_counter;
if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) {
++chance;
} else {
chance = 0;
}
if (event_loop_wait_event) {
rb_thread_wait_for(t0);
} else {
rb_thread_wait_for(t1);
}
/* rb_thread_schedule(); */
}
} while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0);
return Qnil;
}
VALUE
lib_watchdog_ensure(arg)
VALUE arg;
{
eventloop_thread = Qnil; /* stop eventloops */
#ifdef RUBY_VM
tk_eventloop_thread_id = (Tcl_ThreadId) 0;
#endif
return Qnil;
}
static VALUE
lib_mainloop_watchdog(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE check_rootwidget;
#ifdef RUBY_VM
rb_raise(rb_eNotImpError,
"eventloop_watchdog is not implemented on Ruby VM.");
#endif
if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
check_rootwidget = Qtrue;
} else if (RTEST(check_rootwidget)) {
check_rootwidget = Qtrue;
} else {
check_rootwidget = Qfalse;
}
return rb_ensure(lib_watchdog_core, check_rootwidget,
lib_watchdog_ensure, Qnil);
}
static VALUE
ip_mainloop_watchdog(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return Qnil;
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return Qnil;
}
return lib_mainloop_watchdog(argc, argv, self);
}
/* thread-safe(?) interaction between Ruby and Tk */
struct thread_call_proc_arg {
VALUE proc;
int *done;
};
void
_thread_call_proc_arg_mark(struct thread_call_proc_arg *q)
{
rb_gc_mark(q->proc);
}
static VALUE
_thread_call_proc_core(arg)
VALUE arg;
{
struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
return rb_funcall(q->proc, ID_call, 0);
}
static VALUE
_thread_call_proc_ensure(arg)
VALUE arg;
{
struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
*(q->done) = 1;
return Qnil;
}
static VALUE
_thread_call_proc(arg)
VALUE arg;
{
struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
return rb_ensure(_thread_call_proc_core, (VALUE)q,
_thread_call_proc_ensure, (VALUE)q);
}
static VALUE
_thread_call_proc_value(th)
VALUE th;
{
return rb_funcall(th, ID_value, 0);
}
static VALUE
lib_thread_callback(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
struct thread_call_proc_arg *q;
VALUE proc, th, ret;
int status, foundEvent;
if (rb_scan_args(argc, argv, "01", &proc) == 0) {
proc = rb_block_proc();
}
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*)ckalloc(sizeof(int)); */
*(q->done) = 0;
/* create call-proc thread */
th = rb_thread_create(_thread_call_proc, (void*)q);
rb_thread_schedule();
/* start sub-eventloop */
foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0, 0,
q->done, (Tcl_Interp*)NULL));
/* if (RTEST(rb_funcall(th, ID_alive_p, 0))) { */
if (RTEST(rb_thread_alive_p(th))) {
rb_funcall(th, ID_kill, 0);
ret = Qnil;
} else {
ret = rb_protect(_thread_call_proc_value, th, &status);
}
free(q->done);
free(q);
/* ckfree((char*)q->done); */
/* ckfree((char*)q); */
if (NIL_P(rbtk_pending_exception)) {
#ifdef RUBY_VM
/* return rb_errinfo(); */
if (status) {
rb_exc_raise(rb_errinfo());
}
#else
/* return ruby_errinfo; */
if (status) {
rb_exc_raise(ruby_errinfo);
}
#endif
} else {
VALUE exc = rbtk_pending_exception;
rbtk_pending_exception = Qnil;
/* return exc; */
rb_exc_raise(exc);
}
return ret;
}
/* do_one_event */
static VALUE
lib_do_one_event_core(argc, argv, self, is_ip)
int argc;
VALUE *argv;
VALUE self;
int is_ip;
{
volatile VALUE vflags;
int flags;
int found_event;
if (!NIL_P(eventloop_thread)) {
rb_raise(rb_eRuntimeError, "eventloop is already running");
}
tcl_stubs_check();
if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
flags = TCL_ALL_EVENTS | TCL_DONT_WAIT;
} else {
Check_Type(vflags, T_FIXNUM);
flags = FIX2INT(vflags);
}
if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) {
flags |= TCL_DONT_WAIT;
}
if (is_ip) {
/* check IP */
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return Qfalse;
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
flags |= TCL_DONT_WAIT;
}
}
/* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */
found_event = Tcl_DoOneEvent(flags);
if (pending_exception_check0()) {
return Qfalse;
}
if (found_event) {
return Qtrue;
} else {
return Qfalse;
}
}
static VALUE
lib_do_one_event(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
return lib_do_one_event_core(argc, argv, self, 0);
}
static VALUE
ip_do_one_event(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
return lib_do_one_event_core(argc, argv, self, 0);
}
static void
ip_set_exc_message(interp, exc)
Tcl_Interp *interp;
VALUE exc;
{
char *buf;
Tcl_DString dstr;
volatile VALUE msg;
int thr_crit_bup;
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
volatile VALUE enc;
Tcl_Encoding encoding;
#endif
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
msg = rb_funcall(exc, ID_message, 0, 0);
StringValue(msg);
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
enc = rb_attr_get(exc, ID_at_enc);
if (NIL_P(enc)) {
enc = rb_attr_get(msg, ID_at_enc);
}
if (NIL_P(enc)) {
encoding = (Tcl_Encoding)NULL;
} else if (TYPE(enc) == T_STRING) {
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
} else {
enc = rb_funcall(enc, ID_to_s, 0, 0);
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
}
/* to avoid a garbled error message dialog */
/* buf = ALLOC_N(char, (RSTRING(msg)->len)+1);*/
/* memcpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);*/
/* buf[RSTRING(msg)->len] = 0; */
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;
Tcl_DStringInit(&dstr);
Tcl_DStringFree(&dstr);
Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LEN(msg), &dstr);
Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
DUMP2("error message:%s", Tcl_DStringValue(&dstr));
Tcl_DStringFree(&dstr);
free(buf);
/* ckfree(buf); */
#else /* TCL_VERSION <= 8.0 */
Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL);
#endif
rb_thread_critical = thr_crit_bup;
}
static VALUE
TkStringValue(obj)
VALUE obj;
{
switch(TYPE(obj)) {
case T_STRING:
return obj;
case T_NIL:
return rb_str_new2("");
case T_TRUE:
return rb_str_new2("1");
case T_FALSE:
return rb_str_new2("0");
case T_ARRAY:
return rb_funcall(obj, ID_join, 1, rb_str_new2(" "));
default:
if (rb_respond_to(obj, ID_to_s)) {
return rb_funcall(obj, ID_to_s, 0, 0);
}
}
return rb_funcall(obj, ID_inspect, 0, 0);
}
static int
tcl_protect_core(interp, proc, data) /* should not raise exception */
Tcl_Interp *interp;
VALUE (*proc)();
VALUE data;
{
volatile VALUE ret, exc = Qnil;
int status = 0;
int thr_crit_bup = rb_thread_critical;
Tcl_ResetResult(interp);
rb_thread_critical = Qfalse;
ret = rb_protect(proc, data, &status);
rb_thread_critical = Qtrue;
if (status) {
char *buf;
VALUE old_gc;
volatile VALUE type, str;
old_gc = rb_gc_disable();
switch(status) {
case TAG_RETURN:
type = eTkCallbackReturn;
goto error;
case TAG_BREAK:
type = eTkCallbackBreak;
goto error;
case TAG_NEXT:
type = eTkCallbackContinue;
goto error;
error:
str = rb_str_new2("LocalJumpError: ");
#ifdef RUBY_VM
rb_str_append(str, rb_obj_as_string(rb_errinfo()));
#else
rb_str_append(str, rb_obj_as_string(ruby_errinfo));
#endif
exc = rb_exc_new3(type, str);
break;
case TAG_RETRY:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
DUMP1("rb_protect: retry");
exc = rb_exc_new2(eTkCallbackRetry, "retry jump error");
} else {
#ifdef RUBY_VM
exc = rb_errinfo();
#else
exc = ruby_errinfo;
#endif
}
break;
case TAG_REDO:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
DUMP1("rb_protect: redo");
exc = rb_exc_new2(eTkCallbackRedo, "redo jump error");
} else {
#ifdef RUBY_VM
exc = rb_errinfo();
#else
exc = ruby_errinfo;
#endif
}
break;
case TAG_RAISE:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
exc = rb_exc_new2(rb_eException, "unknown exception");
} else {
#ifdef RUBY_VM
exc = rb_errinfo();
#else
exc = ruby_errinfo;
#endif
}
break;
case TAG_FATAL:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
exc = rb_exc_new2(rb_eFatal, "FATAL");
} else {
#ifdef RUBY_VM
exc = rb_errinfo();
#else
exc = ruby_errinfo;
#endif
}
break;
case TAG_THROW:
#ifdef RUBY_VM
if (NIL_P(rb_errinfo())) {
#else
if (NIL_P(ruby_errinfo)) {
#endif
DUMP1("rb_protect: throw");
exc = rb_exc_new2(eTkCallbackThrow, "throw jump error");
} else {
#ifdef RUBY_VM
exc = rb_errinfo();
#else
exc = ruby_errinfo;
#endif
}
break;
default:
buf = ALLOC_N(char, 256);
/* buf = ckalloc(sizeof(char) * 256); */
sprintf(buf, "unknown loncaljmp status %d", status);
exc = rb_exc_new2(rb_eException, buf);
free(buf);
/* ckfree(buf); */
break;
}
if (old_gc == Qfalse) rb_gc_enable();
ret = Qnil;
}
rb_thread_critical = thr_crit_bup;
Tcl_ResetResult(interp);
/* status check */
if (!NIL_P(exc)) {
volatile VALUE eclass = rb_obj_class(exc);
volatile VALUE backtrace;
DUMP1("(failed)");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
DUMP1("set backtrace");
if (!NIL_P(backtrace = rb_funcall(exc, ID_backtrace, 0, 0))) {
backtrace = rb_ary_join(backtrace, rb_str_new2("\n"));
Tcl_AddErrorInfo(interp, StringValuePtr(backtrace));
}
rb_thread_critical = thr_crit_bup;
ip_set_exc_message(interp, exc);
if (eclass == eTkCallbackReturn)
return TCL_RETURN;
if (eclass == eTkCallbackBreak)
return TCL_BREAK;
if (eclass == eTkCallbackContinue)
return TCL_CONTINUE;
if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) {
rbtk_pending_exception = exc;
return TCL_RETURN;
}
if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) {
rbtk_pending_exception = exc;
return TCL_ERROR;
}
if (rb_obj_is_kind_of(exc, eLocalJumpError)) {
VALUE reason = rb_ivar_get(exc, ID_at_reason);
if (TYPE(reason) == T_SYMBOL) {
if (SYM2ID(reason) == ID_return)
return TCL_RETURN;
if (SYM2ID(reason) == ID_break)
return TCL_BREAK;
if (SYM2ID(reason) == ID_next)
return TCL_CONTINUE;
}
}
return TCL_ERROR;
}
/* result must be string or nil */
if (!NIL_P(ret)) {
/* copy result to the tcl interpreter */
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
ret = TkStringValue(ret);
DUMP1("Tcl_AppendResult");
Tcl_AppendResult(interp, RSTRING_PTR(ret), (char *)NULL);
rb_thread_critical = thr_crit_bup;
}
DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING_PTR(ret));
return TCL_OK;
}
static int
tcl_protect(interp, proc, data)
Tcl_Interp *interp;
VALUE (*proc)();
VALUE data;
{
int old_trapflag = rb_trap_immediate;
int code;
#ifdef HAVE_NATIVETHREAD
#ifdef RUBY_VM
#if 0
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on tcl_protect()");
}
#endif
#else
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);
rb_trap_immediate = old_trapflag;
return code;
}
static int
#if TCL_MAJOR_VERSION >= 8
ip_ruby_eval(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#else /* TCL_MAJOR_VERSION < 8 */
ip_ruby_eval(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
{
char *arg;
int thr_crit_bup;
int code;
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
/* ruby command has 1 arg. */
if (argc != 2) {
#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);
rbtk_pending_exception = rb_exc_new2(rb_eArgError,
Tcl_GetStringResult(interp));
return TCL_ERROR;
#endif
}
/* get C string from Tcl object */
#if TCL_MAJOR_VERSION >= 8
{
char *str;
int len;
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
str = Tcl_GetStringFromObj(argv[1], &len);
arg = ALLOC_N(char, len + 1);
/* arg = ckalloc(sizeof(char) * (len + 1)); */
memcpy(arg, str, len);
arg[len] = 0;
rb_thread_critical = thr_crit_bup;
}
#else /* TCL_MAJOR_VERSION < 8 */
arg = argv[1];
#endif
/* evaluate the argument string by ruby */
DUMP2("rb_eval_string(%s)", arg);
code = tcl_protect(interp, rb_eval_string, (VALUE)arg);
#if TCL_MAJOR_VERSION >= 8
free(arg);
/* ckfree(arg); */
#endif
return code;
}
/* Tcl command `ruby_cmd' */
static VALUE
ip_ruby_cmd_core(arg)
struct cmd_body_arg *arg;
{
volatile VALUE ret;
int thr_crit_bup;
DUMP1("call ip_ruby_cmd_core");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qfalse;
ret = rb_apply(arg->receiver, arg->method, arg->args);
rb_thread_critical = thr_crit_bup;
DUMP1("finish ip_ruby_cmd_core");
return ret;
}
#define SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 1
static VALUE
ip_ruby_cmd_receiver_const_get(name)
char *name;
{
volatile VALUE klass = rb_cObject;
char *head, *tail;
int state;
#if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
klass = rb_eval_string_protect(name, &state);
if (state) {
return Qnil;
} else {
return klass;
}
#else
return rb_const_get(klass, rb_intern(name));
#endif
/* TODO!!!!!! */
/* support nest of classes/modules */
/* return rb_eval_string(name); */
/* return rb_eval_string_protect(name, &state); */
#if 0 /* doesn't work!! (fail to autoload?) */
/* duplicate */
head = name = strdup(name);
/* has '::' at head ? */
if (*head == ':') head += 2;
tail = head;
/* search */
while(*tail) {
if (*tail == ':') {
*tail = '\0';
klass = rb_const_get(klass, rb_intern(head));
tail += 2;
head = tail;
} else {
tail++;
}
}
free(name);
return rb_const_get(klass, rb_intern(head));
#endif
}
static VALUE
ip_ruby_cmd_receiver_get(str)
char *str;
{
volatile VALUE receiver;
volatile VALUE klass = rb_cObject;
int state;
if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
/* class | module | constant */
#if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
receiver = ip_ruby_cmd_receiver_const_get(str);
#else
receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state);
if (state) return Qnil;
#endif
} else if (str[0] == '$') {
/* global variable */
receiver = rb_gv_get(str);
} else {
/* global variable omitted '$' */
char *buf;
int len;
len = strlen(str);
buf = ALLOC_N(char, len + 2);
/* buf = ckalloc(sizeof(char) * (len + 2)); */
buf[0] = '$';
memcpy(buf + 1, str, len);
buf[len + 1] = 0;
receiver = rb_gv_get(buf);
free(buf);
/* ckfree(buf); */
}
return receiver;
}
/* ruby_cmd receiver method arg ... */
static int
#if TCL_MAJOR_VERSION >= 8
ip_ruby_cmd(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#else /* TCL_MAJOR_VERSION < 8 */
ip_ruby_cmd(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
{
volatile VALUE receiver;
volatile ID method;
volatile VALUE args;
char *str;
int i;
int len;
struct cmd_body_arg *arg;
int thr_crit_bup;
VALUE old_gc;
int code;
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
if (argc < 3) {
#if 0
rb_raise(rb_eArgError, "too few arguments");
#else
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "too few arguments", (char *)NULL);
rbtk_pending_exception = rb_exc_new2(rb_eArgError,
Tcl_GetStringResult(interp));
return TCL_ERROR;
#endif
}
/* get arguments from Tcl objects */
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
old_gc = rb_gc_disable();
/* get receiver */
#if TCL_MAJOR_VERSION >= 8
str = Tcl_GetStringFromObj(argv[1], &len);
#else /* TCL_MAJOR_VERSION < 8 */
str = argv[1];
#endif
DUMP2("receiver:%s",str);
/* receiver = rb_protect(ip_ruby_cmd_receiver_get, (VALUE)str, &code); */
receiver = ip_ruby_cmd_receiver_get(str);
if (NIL_P(receiver)) {
#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);
rbtk_pending_exception = rb_exc_new2(rb_eArgError,
Tcl_GetStringResult(interp));
if (old_gc == Qfalse) rb_gc_enable();
return TCL_ERROR;
#endif
}
/* get metrhod */
#if TCL_MAJOR_VERSION >= 8
str = Tcl_GetStringFromObj(argv[2], &len);
#else /* TCL_MAJOR_VERSION < 8 */
str = argv[2];
#endif
method = rb_intern(str);
/* get args */
args = rb_ary_new2(argc - 2);
#ifdef RUBY_VM
#else
RARRAY(args)->len = 0;
#endif
for(i = 3; i < argc; i++) {
#if TCL_MAJOR_VERSION >= 8
str = Tcl_GetStringFromObj(argv[i], &len);
DUMP2("arg:%s",str);
#ifdef RUBY_VM
rb_ary_push(args, rb_tainted_str_new(str, len));
#else
RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new(str, len);
#endif
#else /* TCL_MAJOR_VERSION < 8 */
DUMP2("arg:%s",argv[i]);
#ifdef RUBY_VM
rb_ary_push(args, rb_tainted_str_new2(argv[i]));
#else
RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new2(argv[i]);
#endif
#endif
}
if (old_gc == Qfalse) rb_gc_enable();
rb_thread_critical = thr_crit_bup;
/* allocate */
arg = ALLOC(struct cmd_body_arg);
/* arg = (struct cmd_body_arg *)ckalloc(sizeof(struct cmd_body_arg)); */
arg->receiver = receiver;
arg->method = method;
arg->args = args;
/* evaluate the argument string by ruby */
code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg);
free(arg);
/* ckfree((char*)arg); */
return code;
}
/*****************************/
/* relpace of 'exit' command */
/*****************************/
static int
#if TCL_MAJOR_VERSION >= 8
ip_InterpExitObjCmd(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#else /* TCL_MAJOR_VERSION < 8 */
ip_InterpExitCommand(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
{
DUMP1("start ip_InterpExitCommand");
if (interp != (Tcl_Interp*)NULL
&& !Tcl_InterpDeleted(interp)
#if TCL_NAMESPACE_DEBUG
&& !ip_null_namespace(interp)
#endif
) {
Tcl_ResetResult(interp);
/* Tcl_Preserve(interp); */
/* Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); */
ip_finalize(interp);
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
}
return TCL_OK;
}
static int
#if TCL_MAJOR_VERSION >= 8
ip_RubyExitObjCmd(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#else /* TCL_MAJOR_VERSION < 8 */
ip_RubyExitCommand(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
{
int state;
char *cmd, *param;
#if TCL_MAJOR_VERSION < 8
char *endptr;
cmd = argv[0];
#endif
DUMP1("start ip_RubyExitCommand");
#if TCL_MAJOR_VERSION >= 8
/* cmd = Tcl_GetString(argv[0]); */
cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL);
#endif
if (argc < 1 || argc > 2) {
/* arguemnt error */
Tcl_AppendResult(interp,
"wrong number of arguments: should be \"",
cmd, " ?returnCode?\"", (char *)NULL);
return TCL_ERROR;
}
if (interp == (Tcl_Interp*)NULL) return TCL_OK;
Tcl_ResetResult(interp);
if (rb_safe_level() >= 4 || Tcl_IsSafe(interp)) {
ip_finalize(interp);
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
return TCL_OK;
}
switch(argc) {
case 1:
/* rb_exit(0); */ /* not return if succeed */
Tcl_AppendResult(interp,
"fail to call \"", cmd, "\"", (char *)NULL);
rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
Tcl_GetStringResult(interp));
rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0));
return TCL_RETURN;
case 2:
#if TCL_MAJOR_VERSION >= 8
if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) {
return TCL_ERROR;
}
/* param = Tcl_GetString(argv[1]); */
param = Tcl_GetStringFromObj(argv[1], (int*)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
state = (int)strtol(argv[1], &endptr, 0);
if (*endptr) {
Tcl_AppendResult(interp,
"expected integer but got \"",
argv[1], "\"", (char *)NULL);
return TCL_ERROR;
}
param = argv[1];
#endif
/* rb_exit(state); */ /* not return if succeed */
Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
param, "\"", (char *)NULL);
rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
Tcl_GetStringResult(interp));
rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state));
return TCL_RETURN;
default:
/* arguemnt error */
Tcl_AppendResult(interp,
"wrong number of arguments: should be \"",
cmd, " ?returnCode?\"", (char *)NULL);
return TCL_ERROR;
}
}
/**************************/
/* based on tclEvent.c */
/**************************/
/*********************/
/* replace of update */
/*********************/
#if TCL_MAJOR_VERSION >= 8
static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
static int
ip_rbUpdateObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[]));
static int
ip_rbUpdateCommand(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
int optionIndex;
int ret;
int flags = 0;
static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
enum updateOptions {REGEXP_IDLETASKS};
DUMP1("Ruby's 'update' is called");
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
#ifdef HAVE_NATIVETHREAD
#ifdef RUBY_VM
#if 0
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on ip_ruby_eval()");
}
#endif
#else
if (!is_ruby_native_thread()) {
rb_bug("cross-thread violation on ip_ruby_eval()");
}
#endif
#endif
Tcl_ResetResult(interp);
if (objc == 1) {
flags = TCL_DONT_WAIT;
} else if (objc == 2) {
#if TCL_MAJOR_VERSION >= 8
if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
case REGEXP_IDLETASKS: {
flags = TCL_IDLE_EVENTS;
break;
}
default: {
rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions");
}
}
#else
if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
Tcl_AppendResult(interp, "bad option \"", objv[1],
"\": must be idletasks", (char *) NULL);
return TCL_ERROR;
}
flags = TCL_IDLE_EVENTS;
#endif
} else {
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
#else
# if TCL_MAJOR_VERSION >= 8
int dummy;
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
Tcl_GetStringFromObj(objv[0], &dummy),
" [ idletasks ]\"",
(char *) NULL);
# else /* TCL_MAJOR_VERSION < 8 */
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
objv[0], " [ idletasks ]\"", (char *) NULL);
# endif
#endif
return TCL_ERROR;
}
Tcl_Preserve(interp);
/* call eventloop */
/* ret = lib_eventloop_core(0, flags, (int *)NULL);*/ /* ignore result */
ret = RTEST(lib_eventloop_launcher(0, flags, (int *)NULL, interp)); /* ignore result */
/* exception check */
if (!NIL_P(rbtk_pending_exception)) {
Tcl_Release(interp);
/*
if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
*/
if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
|| rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
return TCL_RETURN;
} else{
return TCL_ERROR;
}
}
/* trap check */
if (rb_trap_pending) {
Tcl_Release(interp);
return TCL_RETURN;
}
/*
* Must clear the interpreter's result because event handlers could
* have executed commands.
*/
DUMP2("last result '%s'", Tcl_GetStringResult(interp));
Tcl_ResetResult(interp);
Tcl_Release(interp);
DUMP1("finish Ruby's 'update'");
return TCL_OK;
}
/**********************/
/* update with thread */
/**********************/
struct th_update_param {
VALUE thread;
int done;
};
static void rb_threadUpdateProc _((ClientData));
static void
rb_threadUpdateProc(clientData)
ClientData clientData; /* Pointer to integer to set to 1. */
{
struct th_update_param *param = (struct th_update_param *) clientData;
DUMP1("threadUpdateProc is called");
param->done = 1;
rb_thread_wakeup(param->thread);
return;
}
#if TCL_MAJOR_VERSION >= 8
static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
static int
ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int,
char *[]));
static int
ip_rb_threadUpdateCommand(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
int optionIndex;
int flags = 0;
struct th_update_param *param;
static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
enum updateOptions {REGEXP_IDLETASKS};
volatile VALUE current_thread = rb_thread_current();
DUMP1("Ruby's 'thread_update' is called");
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
#ifdef HAVE_NATIVETHREAD
#ifdef RUBY_VM
#if 0
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()");
}
#endif
#else
if (!is_ruby_native_thread()) {
rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()");
}
#endif
#endif
if (rb_thread_alone()
|| NIL_P(eventloop_thread) || eventloop_thread == current_thread) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rbUpdateObjCmd");
return ip_rbUpdateObjCmd(clientData, interp, objc, objv);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call ip_rbUpdateCommand");
return ip_rbUpdateCommand(clientData, interp, objc, objv);
#endif
}
DUMP1("start Ruby's 'thread_update' body");
Tcl_ResetResult(interp);
if (objc == 1) {
flags = TCL_DONT_WAIT;
} else if (objc == 2) {
#if TCL_MAJOR_VERSION >= 8
if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
case REGEXP_IDLETASKS: {
flags = TCL_IDLE_EVENTS;
break;
}
default: {
rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions");
}
}
#else
if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
Tcl_AppendResult(interp, "bad option \"", objv[1],
"\": must be idletasks", (char *) NULL);
return TCL_ERROR;
}
flags = TCL_IDLE_EVENTS;
#endif
} else {
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
#else
# if TCL_MAJOR_VERSION >= 8
int dummy;
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
Tcl_GetStringFromObj(objv[0], &dummy),
" [ idletasks ]\"",
(char *) NULL);
# else /* TCL_MAJOR_VERSION < 8 */
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
objv[0], " [ idletasks ]\"", (char *) NULL);
# endif
#endif
return TCL_ERROR;
}
DUMP1("pass argument check");
/* param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); */
param = (struct th_update_param *)ckalloc(sizeof(struct th_update_param));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)param);
#endif
param->thread = current_thread;
param->done = 0;
DUMP1("set idle proc");
Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param);
while(!param->done) {
DUMP1("wait for complete idle proc");
/* rb_thread_stop(); */
rb_thread_sleep_forever();
}
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
DUMP1("finish Ruby's 'thread_update'");
return TCL_OK;
}
/***************************/
/* replace of vwait/tkwait */
/***************************/
#if TCL_MAJOR_VERSION >= 8
static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
#else
static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int,
char *[]));
static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int,
char *[]));
#endif
#if TCL_MAJOR_VERSION >= 8
static char *VwaitVarProc _((ClientData, Tcl_Interp *,
CONST84 char *,CONST84 char *, int));
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST84 char *name1; /* Name of variable. */
CONST84 char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
#else /* TCL_MAJOR_VERSION < 8 */
static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int));
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
char *name1; /* Name of variable. */
char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
#endif
{
int *donePtr = (int *) clientData;
*donePtr = 1;
return (char *) NULL;
}
#if TCL_MAJOR_VERSION >= 8
static int
ip_rbVwaitObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int
ip_rbVwaitCommand(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
int ret, done, foundEvent;
char *nameString;
int dummy;
int thr_crit_bup;
DUMP1("Ruby's 'vwait' is called");
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
#if 0
if (!rb_thread_alone()
&& eventloop_thread != Qnil
&& eventloop_thread != rb_thread_current()) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rb_threadVwaitObjCmd");
return ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call ip_rb_threadVwaitCommand");
return ip_rb_threadVwaitCommand(clientData, interp, objc, objv);
#endif
}
#endif
Tcl_Preserve(interp);
#ifdef HAVE_NATIVETHREAD
#ifdef RUBY_VM
#if 0
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on ip_rbVwaitCommand()");
}
#endif
#else
if (!is_ruby_native_thread()) {
rb_bug("cross-thread violation on ip_rbVwaitCommand()");
}
#endif
#endif
Tcl_ResetResult(interp);
if (objc != 2) {
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "name");
#else
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[0]); */
nameString = Tcl_GetStringFromObj(objv[0], &dummy);
#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[0];
#endif
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
nameString, " name\"", (char *) NULL);
rb_thread_critical = thr_crit_bup;
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if TCL_MAJOR_VERSION >= 8
Tcl_IncrRefCount(objv[1]);
/* nameString = Tcl_GetString(objv[1]); */
nameString = Tcl_GetStringFromObj(objv[1], &dummy);
#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[1];
#endif
/*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done) != TCL_OK) {
return TCL_ERROR;
}
*/
ret = Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
rb_thread_critical = thr_crit_bup;
if (ret != TCL_OK) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
done = 0;
foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0,
0, &done, interp));
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
rb_thread_critical = thr_crit_bup;
/* exception check */
if (!NIL_P(rbtk_pending_exception)) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
/*
if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
*/
if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
|| rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
return TCL_RETURN;
} else{
return TCL_ERROR;
}
}
/* trap check */
if (rb_trap_pending) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
return TCL_RETURN;
}
/*
* Clear out the interpreter's result, since it may have been set
* by event handlers.
*/
Tcl_ResetResult(interp);
if (!foundEvent) {
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", (char *) NULL);
rb_thread_critical = thr_crit_bup;
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
return TCL_OK;
}
/**************************/
/* based on tkCmd.c */
/**************************/
#if TCL_MAJOR_VERSION >= 8
static char *WaitVariableProc _((ClientData, Tcl_Interp *,
CONST84 char *,CONST84 char *, int));
static char *
WaitVariableProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST84 char *name1; /* Name of variable. */
CONST84 char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
#else /* TCL_MAJOR_VERSION < 8 */
static char *WaitVariableProc _((ClientData, Tcl_Interp *,
char *, char *, int));
static char *
WaitVariableProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
char *name1; /* Name of variable. */
char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
#endif
{
int *donePtr = (int *) clientData;
*donePtr = 1;
return (char *) NULL;
}
static void WaitVisibilityProc _((ClientData, XEvent *));
static void
WaitVisibilityProc(clientData, eventPtr)
ClientData clientData; /* Pointer to integer to set to 1. */
XEvent *eventPtr; /* Information about event (not used). */
{
int *donePtr = (int *) clientData;
if (eventPtr->type == VisibilityNotify) {
*donePtr = 1;
}
if (eventPtr->type == DestroyNotify) {
*donePtr = 2;
}
}
static void WaitWindowProc _((ClientData, XEvent *));
static void
WaitWindowProc(clientData, eventPtr)
ClientData clientData; /* Pointer to integer to set to 1. */
XEvent *eventPtr; /* Information about event. */
{
int *donePtr = (int *) clientData;
if (eventPtr->type == DestroyNotify) {
*donePtr = 1;
}
}
#if TCL_MAJOR_VERSION >= 8
static int
ip_rbTkWaitObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int
ip_rbTkWaitCommand(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
Tk_Window tkwin = (Tk_Window) clientData;
Tk_Window window;
int done, index;
static CONST char *optionStrings[] = { "variable", "visibility", "window",
(char *) NULL };
enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
char *nameString;
int ret, dummy;
int thr_crit_bup;
DUMP1("Ruby's 'tkwait' is called");
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
#if 0
if (!rb_thread_alone()
&& eventloop_thread != Qnil
&& eventloop_thread != rb_thread_current()) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rb_threadTkWaitObjCmd");
return ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call ip_rb_threadTkWaitCommand");
return ip_rb_threadTkWwaitCommand(clientData, interp, objc, objv);
#endif
}
#endif
Tcl_Preserve(interp);
Tcl_ResetResult(interp);
if (objc != 3) {
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
#else
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if TCL_MAJOR_VERSION >= 8
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
Tcl_GetStringFromObj(objv[0], &dummy),
" variable|visibility|window name\"",
(char *) NULL);
#else /* TCL_MAJOR_VERSION < 8 */
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
objv[0], " variable|visibility|window name\"",
(char *) NULL);
#endif
rb_thread_critical = thr_crit_bup;
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
#if TCL_MAJOR_VERSION >= 8
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/*
if (Tcl_GetIndexFromObj(interp, objv[1],
(CONST84 char **)optionStrings,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
*/
ret = Tcl_GetIndexFromObj(interp, objv[1],
(CONST84 char **)optionStrings,
"option", 0, &index);
rb_thread_critical = thr_crit_bup;
if (ret != TCL_OK) {
Tcl_Release(interp);
return TCL_ERROR;
}
#else /* TCL_MAJOR_VERSION < 8 */
{
int c = objv[1][0];
size_t length = strlen(objv[1]);
if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
&& (length >= 2)) {
index = TKWAIT_VARIABLE;
} else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
&& (length >= 2)) {
index = TKWAIT_VISIBILITY;
} else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
index = TKWAIT_WINDOW;
} else {
Tcl_AppendResult(interp, "bad option \"", objv[1],
"\": must be variable, visibility, or window",
(char *) NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
}
#endif
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if TCL_MAJOR_VERSION >= 8
Tcl_IncrRefCount(objv[2]);
/* nameString = Tcl_GetString(objv[2]); */
nameString = Tcl_GetStringFromObj(objv[2], &dummy);
#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[2];
#endif
rb_thread_critical = thr_crit_bup;
switch ((enum options) index) {
case TKWAIT_VARIABLE:
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
WaitVariableProc, (ClientData) &done) != TCL_OK) {
return TCL_ERROR;
}
*/
ret = Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
WaitVariableProc, (ClientData) &done);
rb_thread_critical = thr_crit_bup;
if (ret != TCL_OK) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
done = 0;
/* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
WaitVariableProc, (ClientData) &done);
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
rb_thread_critical = thr_crit_bup;
/* exception check */
if (!NIL_P(rbtk_pending_exception)) {
Tcl_Release(interp);
/*
if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) {
*/
if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
|| rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
return TCL_RETURN;
} else{
return TCL_ERROR;
}
}
/* trap check */
if (rb_trap_pending) {
Tcl_Release(interp);
return TCL_RETURN;
}
break;
case TKWAIT_VISIBILITY:
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* This function works on the Tk eventloop thread only. */
if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
window = NULL;
} else {
window = Tk_NameToWindow(interp, nameString, tkwin);
}
if (window == NULL) {
Tcl_AppendResult(interp, ": tkwait: ",
"no main-window (not Tk application?)",
(char*)NULL);
rb_thread_critical = thr_crit_bup;
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
Tk_CreateEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,