/ext/tk/tcltklib.c

Large files files are truncated, but you can click here to view the full file

/*
 *      tcltklib.c
 *              Aug. 27, 1997   Y. Shigehiro
 *              Oct. 24, 1997   Y. Matsumoto
 */

#define TCLTKLIB_RELEASE_DATE "2010-05-31"
/* #define CREATE_RUBYTK_KIT */

#include "ruby.h"

#ifdef HAVE_RUBY_ENCODING_H
#include "ruby/encoding.h"
#endif
#ifndef RUBY_VERSION
#define RUBY_VERSION "(unknown version)"
#endif
#ifndef RUBY_RELEASE_DATE
#define RUBY_RELEASE_DATE "unknown release-date"
#endif

#ifdef RUBY_VM
static VALUE rb_thread_critical; /* dummy */
int rb_thread_check_trap_pending();
#else
/* use rb_thread_critical on Ruby 1.8.x */
#include "rubysig.h"
#endif

#if !defined(RSTRING_PTR)
#define RSTRING_PTR(s) (RSTRING(s)->ptr)
#define RSTRING_LEN(s) (RSTRING(s)->len)
#endif
#if !defined(RARRAY_PTR)
#define RARRAY_PTR(s) (RARRAY(s)->ptr)
#define RARRAY_LEN(s) (RARRAY(s)->len)
#endif

#ifdef OBJ_UNTRUST
#define RbTk_OBJ_UNTRUST(x)  do {OBJ_TAINT(x); OBJ_UNTRUST(x);} while (0)
#else
#define RbTk_OBJ_UNTRUST(x)  OBJ_TAINT(x)
#endif

#if defined(HAVE_RB_PROC_NEW) && !defined(RUBY_VM)
/* Ruby 1.8 :: rb_proc_new() was hidden from intern.h at 2008/04/22 */
extern VALUE rb_proc_new _((VALUE (*)(ANYARGS/* VALUE yieldarg[, VALUE procarg] */), VALUE));
#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>

#if !defined HAVE_VSNPRINTF && !defined vsnprintf
#  ifdef WIN32
     /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */
#    define vsnprintf _vsnprintf
#  else
#    ifdef HAVE_RUBY_RUBY_H
#      include "ruby/missing.h"
#    else
#      include "missing.h"
#    endif
#  endif
#endif

#include <tcl.h>
#include <tk.h>

#ifndef HAVE_RUBY_NATIVE_THREAD_P
#define ruby_native_thread_p() is_ruby_native_thread()
#undef RUBY_USE_NATIVE_THREAD
#else
#define RUBY_USE_NATIVE_THREAD 1
#endif

#ifndef HAVE_RB_ERRINFO
#define rb_errinfo() (ruby_errinfo+0) /* cannot be l-value */
#else
VALUE rb_errinfo(void);
#endif
#ifndef HAVE_RB_SAFE_LEVEL
#define rb_safe_level() (ruby_safe_level+0)
#endif
#ifndef HAVE_RB_SOURCEFILE
#define rb_sourcefile() (ruby_sourcefile+0)
#endif

#include "stubs.h"

#ifndef TCL_ALPHA_RELEASE
#define TCL_ALPHA_RELEASE       0  /* "alpha" */
#define TCL_BETA_RELEASE        1  /* "beta"  */
#define TCL_FINAL_RELEASE       2  /* "final" */
#endif

static struct {
  int major;
  int minor;
  int type;  /* ALPHA==0, BETA==1, FINAL==2 */
  int patchlevel;
} 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

#ifndef CONST86
# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 5 /* Tcl8.0.x -- 8.5.x */
#  define CONST86
# else
#  define CONST86 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 */
static const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE;

/* finalize_proc_name */
static const char finalize_hook_name[] = "INTERP_FINALIZE_HOOK";

static void ip_finalize _((Tcl_Interp*));

static int at_exit = 0;

#ifdef HAVE_RUBY_ENCODING_H
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));
static VALUE callq_safelevel_handler _((VALUE, VALUE));

/* Tcl's object type */
#if TCL_MAJOR_VERSION >= 8
static const char Tcl_ObjTypeName_ByteArray[] = "bytearray";
static CONST86 Tcl_ObjType *Tcl_ObjType_ByteArray;

static const char Tcl_ObjTypeName_String[]    = "string";
static CONST86 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 HAVE_PROTOTYPES
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 HAVE_PROTOTYPES
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;
static Tcl_Interp *eventloop_interp;
#ifdef RUBY_USE_NATIVE_THREAD
Tcl_ThreadId tk_eventloop_thread_id;  /* native thread ID of Tcl interpreter */
#endif
static VALUE eventloop_stack;
static int   window_event_mode = ~0;

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
*/
#ifdef RUBY_USE_NATIVE_THREAD
#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 1
#else /* ! RUBY_USE_NATIVE_THREAD */
#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
#endif

#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_USE_NATIVE_THREAD
#define DEFAULT_EVENT_LOOP_MAX        800/*counts*/
#define DEFAULT_NO_EVENT_TICK          10/*counts*/
#define DEFAULT_NO_EVENT_WAIT           1/*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_USE_NATIVE_THREAD */
#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

#define EVENT_HANDLER_TIMEOUT         100/*milliseconds*/

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_USE_NATIVE_THREAD
    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;
}

/*-------------------------------------------------------*/
#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT

/* Tcl/Tk stubs may work, but probably it is meaningless. */
#if defined USE_TCL_STUBS || defined USE_TK_STUBS
#  error Not support Tcl/Tk stubs with Ruby/Tk-Kit or Rubykit.
#endif

#ifndef KIT_INCLUDES_TK
#  define KIT_INCLUDES_TK  1
#endif
/* #define KIT_INCLUDES_ITCL 1 */
/* #define KIT_INCLUDES_THREAD  1 */

#ifdef KIT_INCLUDES_ITCL
Tcl_AppInitProc Itcl_Init;
#endif
Tcl_AppInitProc Mk4tcl_Init, Vfs_Init, Rechan_Init, Zlib_Init;
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
Tcl_AppInitProc Pwb_Init;
#endif
#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
Tcl_AppInitProc Thread_Init;
#endif
#ifdef _WIN32
Tcl_AppInitProc Dde_Init, Registry_Init;
#endif

static const char *tcltklib_filepath = "[info nameofexecutable]";
static char *rubytkkit_preInitCmd = (char *)NULL;
static const char *rubytkkit_preInitCmd_head = "set ::rubytkkit_exe [list ";
static const char *rubytkkit_preInitCmd_tail =
"]\n"
/*=== following init scripts are quoted from kitInit.c of Tclkit ===*/
/* Tclkit license terms ---
 LICENSE

   The Tclkit-specific sources are license free, they just have a copyright.
   Hold the author(s) harmless and any lawful use is permitted.

   This does *not* apply to any of the sources of the other major Open Source
   Software used in Tclkit, which each have very liberal BSD/MIT-like licenses:
         Tcl/Tk, Incrtcl, Metakit, TclVFS, Zlib
*/
#ifdef _WIN32_WCE
/* silly hack to get wince port to launch, some sort of std{in,out,err} problem
*/
"open /kitout.txt a; open /kitout.txt a; open /kitout.txt a\n"
/* this too seems to be needed on wince - it appears to be related to the above
*/
"catch {rename source ::tcl::source}\n"
"proc source file {\n"
    "set old [info script]\n"
    "info script $file\n"
    "set fid [open $file]\n"
    "set data [read $fid]\n"
    "close $fid\n"
    "set code [catch {uplevel 1 $data} res]\n"
    "info script $old\n"
    "if {$code == 2} { set code 0 }\n"
    "return -code $code $res\n"
"}\n"
#endif
"proc tclKitInit {} {\n"
    "rename tclKitInit {}\n"
    "load {} Mk4tcl\n"
#if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT
    /* running command cannot open itself for writing */
    "mk::file open exe $::rubytkkit_exe\n"
#else
    "mk::file open exe $::rubytkkit_exe -readonly\n"
#endif
    "set n [mk::select exe.dirs!0.files name boot.tcl]\n"
    "if {$n != \"\"} {\n"
        "set s [mk::get exe.dirs!0.files!$n contents]\n"
        "if {![string length $s]} { error \"empty boot.tcl\" }\n"
        "catch {load {} zlib}\n"
        "if {[mk::get exe.dirs!0.files!$n size] != [string length $s]} {\n"
            "set s [zlib decompress $s]\n"
        "}\n"
    "} else {\n"
        "set f [open setup.tcl]\n"
        "set s [read $f]\n"
        "close $f\n"
    "}\n"
    "uplevel #0 $s\n"
#ifdef _WIN32
    "package ifneeded dde 1.3.1 {load {} dde}\n"
    "package ifneeded registry 1.1.5 {load {} registry}\n"
#endif
"}\n"
"tclKitInit"
;

#if 0
/* Not use this script. 
   It's a memo to support an initScript for Tcl interpreters in the future. */
static const char initScript[] =
"if {[file isfile [file join $::rubytkkit_exe main.tcl]]} {\n"
    "if {[info commands console] != {}} { console hide }\n"
    "set tcl_interactive 0\n"
    "incr argc\n"
    "set argv [linsert $argv 0 $argv0]\n"
    "set argv0 [file join $::rubytkkit_exe main.tcl]\n"
"} else continue\n"
;
#endif

#if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED)
EXTERN char* TclSetPreInitScript _((char *));
#endif
static char*
setup_preInitCmd(const char *path)
{
  int head_len, path_len, tail_len;
  char *ptr;

  head_len = strlen(rubytkkit_preInitCmd_head);
  path_len = strlen(path);
  tail_len = strlen(rubytkkit_preInitCmd_tail);

  rubytkkit_preInitCmd = ALLOC_N(char, head_len + path_len + tail_len + 1);

  ptr = rubytkkit_preInitCmd;
  memcpy(ptr, rubytkkit_preInitCmd_head, head_len);

  ptr += head_len;
  memcpy(ptr, path, path_len);

  ptr += path_len;
  memcpy(ptr, rubytkkit_preInitCmd_tail, tail_len);

  ptr += tail_len;
  *ptr = '\0';

  return TclSetPreInitScript(rubytkkit_preInitCmd);
}

static void
init_static_tcltk_packages()
{
#ifdef KIT_INCLUDES_ITCL
    Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
#endif
    Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
    Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
#endif
    Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
    Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
    Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
    Tcl_StaticPackage(0, "Thread", Thread_Init, NULL);
#endif
#ifdef _WIN32
    Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
    Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
#endif
#ifdef KIT_INCLUDES_TK
    Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
#endif
}

/* SetExecName --  Hack to get around Tcl bug 1224888. */
void SetExecName(Tcl_Interp *interp) {
  /* dummy */
}
#endif /* defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT */

static int
call_tclkit_init_script(Tcl_Interp  *interp)
{
#if 0
  /* Currently, nothing do in this function. 
     It's a memo (quoted from kitInit.c of Tclkit) 
     to support an initScript for Tcl interpreters in the future. */
  if (Tcl_Eval(interp, initScript) == TCL_OK) {
    Tcl_Obj* path = TclGetStartupScriptPath();
    TclSetStartupScriptPath(Tcl_GetObjResult(interp));
    if (path == NULL)
      Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
  }
#endif

  return 1;
}


/**********************************************************************/

/* 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_USE_NATIVE_THREAD
    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
        xfree(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 */
        CONST84 char **argv;
#define USE_RUBY_ALLOC 0
#if USE_RUBY_ALLOC
        argv = ALLOC_N(char *, 3); /* XXXXXXXXXX */
#else /* not USE_RUBY_ALLOC */
        argv = (CONST84 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, argv);

#if USE_RUBY_ALLOC
        xfree(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
        xfree(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_USE_NATIVE_THREAD
#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;
    }

    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_USE_NATIVE_THREAD  /* 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_USE_NATIVE_THREAD  /* Ruby 1.9+ !!! */
static VALUE
#ifdef HAVE_PROTOTYPES
call_DoOneEvent_core(VALUE flag_val)
#else
call_DoOneEvent_core(flag_val)
    VALUE flag_val;
#endif
{
    int flag;

    flag = FIX2INT(flag_val);
    if (Tcl_DoOneEvent(flag)) {
        return Qtrue;
    } else {
        return Qfalse;
    }
}

static VALUE
#ifdef HAVE_PROTOTYPES
call_DoOneEvent(VALUE flag_val)
#else
call_DoOneEvent(flag_val)
    VALUE flag_val;
#endif
{
  return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val);
}

#else  /* Ruby 1.8- */
static VALUE
#ifdef HAVE_PROTOTYPES
call_DoOneEvent(VALUE flag_val)
#else
call_DoOneEvent(flag_val)
    VALUE flag_val;
#endif
{
    int flag;

    flag = FIX2INT(flag_val);
    if (Tcl_DoOneEvent(flag)) {
        return Qtrue;
    } else {
        return Qfalse;
    }
}
#endif


static VALUE
#ifdef HAVE_PROTOTYPES
eventloop_sleep(VALUE dummy)
#else
eventloop_sleep(dummy)
    VALUE dummy;
#endif
{
    struct timeval t;

    if (no_event_wait <= 0) {
      return Qnil;
    }

    t.tv_sec = 0;
    t.tv_usec = (long)(no_event_wait*1000.0);

#ifdef HAVE_NATIVETHREAD
#ifndef RUBY_USE_NATIVE_THREAD
    if (!ruby_native_thread_p()) {
        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
#ifndef RUBY_USE_NATIVE_THREAD
    if (!ruby_native_thread_p()) {
        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_USE_NATIVE_THREAD
  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

#define TRAP_CHECK() do { \
    if (trap_check(check_var) == 0) return 0; \
} while (0)

static int
trap_check(int *check_var)
{
    DUMP1("trap check");

#ifdef RUBY_VM
    if (rb_thread_check_trap_pending()) {
	if (check_var != (int*)NULL) {
	    /* wait command */
	    return 0;
	}
	else {
	    rb_thread_check_ints();
	}
    }
#else
    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();
      }
    }
#endif

    return 1;
}

static int
check_eventloop_interp()
{
  DUMP1("check eventloop_interp");
  if (eventloop_interp != (Tcl_Interp*)NULL
      && Tcl_InterpDeleted(eventloop_interp)) {
    DUMP2("eventloop_interp(%p) was deleted", eventloop_interp);
    return 1;
  }

  return 0;
}

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 = 0;
    t.tv_usec = (long)(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 (check_eventloop_interp()) return 0;

#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) {
                ti…