/* ![[previous]](../icons/n_left.png)
![[next]](../icons/n_right.png)
![[first]](../icons/first.png)
![[last]](../icons/last.png)
![[top]](../icons/n_top.png)
![[bottom]](../icons/bottom.png)
![[index]](../icons/index.png)
![[help]](../icons/help.png)
*/
DEFINITIONS
This source file includes following definitions.
- set_tcltk_version
- tcl_eval
- tcl_global_eval
- Tcl_GetVar2Ex
- Tcl_SetVar2Ex
- invoke_queue_mark
- eval_queue_mark
- call_queue_mark
- Tcl_PopCallFrame
- Tcl_PushCallFrame
- get_ip
- deleted_ip
- rbtk_preserve_ip
- rbtk_release_ip
- create_ip_exc
- set_rubytk_kitpath
- check_tclkit_std_channels
- rubytk_kitpathObjCmd
- rubytk_kitpath_init
- init_static_tcltk_packages
- call_tclkit_init_script
- rbtk_win32_SetHINSTANCE
- setup_rubytkkit
- tcl_stubs_check
- tcltkip_init_tk
- pending_exception_check0
- pending_exception_check1
- call_original_exit
- _timer_for_tcl
- toggle_eventloop_window_mode_for_idle
- set_eventloop_window_mode
- get_eventloop_window_mode
- set_eventloop_tick
- get_eventloop_tick
- ip_set_eventloop_tick
- ip_get_eventloop_tick
- set_no_event_wait
- get_no_event_wait
- ip_set_no_event_wait
- ip_get_no_event_wait
- set_eventloop_weight
- get_eventloop_weight
- ip_set_eventloop_weight
- ip_get_eventloop_weight
- set_max_block_time
- lib_evloop_thread_p
- lib_evloop_abort_on_exc
- ip_evloop_abort_on_exc
- lib_evloop_abort_on_exc_set
- ip_evloop_abort_on_exc_set
- lib_num_of_mainwindows_core
- lib_num_of_mainwindows
- rbtk_EventSetupProc
- rbtk_EventCheckProc
- call_DoOneEvent_core
- call_DoOneEvent
- call_DoOneEvent
- eventloop_sleep
- get_thread_alone_check_flag
- trap_check
- check_eventloop_interp
- lib_eventloop_core
- lib_eventloop_main_core
- lib_eventloop_main
- lib_eventloop_ensure
- lib_eventloop_launcher
- lib_mainloop
- ip_mainloop
- watchdog_evloop_launcher
- lib_watchdog_core
- lib_watchdog_ensure
- lib_mainloop_watchdog
- ip_mainloop_watchdog
- _thread_call_proc_arg_mark
- _thread_call_proc_core
- _thread_call_proc_ensure
- _thread_call_proc
- _thread_call_proc_value
- lib_thread_callback
- lib_do_one_event_core
- lib_do_one_event
- ip_do_one_event
- ip_set_exc_message
- TkStringValue
- tcl_protect_core
- tcl_protect
- ip_ruby_eval
- ip_ruby_cmd_core
- ip_ruby_cmd_receiver_const_get
- ip_ruby_cmd_receiver_get
- ip_ruby_cmd
- ip_InterpExitObjCmd
- ip_RubyExitObjCmd
- ip_rbUpdateObjCmd
- rb_threadUpdateProc
- ip_rb_threadUpdateObjCmd
- VwaitVarProc
- ip_rbVwaitObjCmd
- WaitVariableProc
- WaitVisibilityProc
- WaitWindowProc
- ip_rbTkWaitObjCmd
- rb_threadVwaitProc
- rb_threadWaitVisibilityProc
- rb_threadWaitWindowProc
- ip_rb_threadVwaitObjCmd
- ip_rb_threadTkWaitObjCmd
- ip_thread_vwait
- ip_thread_tkwait
- delete_slaves
- delete_slaves
- lib_mark_at_exit
- ip_null_proc
- ip_finalize
- ip_free
- ip_alloc
- ip_replace_wait_commands
- ip_rb_replaceSlaveTkCmdsObjCmd
- ip_rbNamespaceObjCmd
- ip_wrap_namespace_command
- ip_CallWhenDeleted
- ip_init
- ip_create_slave_core
- ip_create_slave
- ip_is_slave_of_p
- ip_create_console_core
- ip_create_console
- ip_make_safe_core
- ip_make_safe
- ip_is_safe_p
- ip_allow_ruby_exit_p
- ip_allow_ruby_exit_set
- ip_delete
- ip_has_invalid_namespace_p
- ip_is_deleted_p
- ip_has_mainwindow_p_core
- ip_has_mainwindow_p
- get_str_from_obj
- get_obj_from_str
- ip_get_result_string_obj
- callq_safelevel_handler
- call_queue_handler
- tk_funcall
- call_tcl_eval
- ip_eval_real
- evq_safelevel_handler
- eval_queue_handler
- ip_eval
- ip_cancel_eval_core
- ip_cancel_eval
- ip_cancel_eval_unwind
- lib_restart_core
- lib_restart
- ip_restart
- lib_toUTF8_core
- lib_toUTF8
- ip_toUTF8
- lib_fromUTF8_core
- lib_fromUTF8
- ip_fromUTF8
- lib_UTF_backslash_core
- lib_UTF_backslash
- lib_Tcl_backslash
- lib_get_system_encoding
- lib_set_system_encoding
- invoke_tcl_proc
- ip_invoke_core
- alloc_invoke_arguments
- free_invoke_arguments
- ip_invoke_real
- ivq_safelevel_handler
- invoke_queue_handler
- ip_invoke_with_position
- ip_retval
- ip_invoke
- ip_invoke_immediate
- ip_get_variable2_core
- ip_get_variable2
- ip_get_variable
- ip_set_variable2_core
- ip_set_variable2
- ip_set_variable
- ip_unset_variable2_core
- ip_unset_variable2
- ip_unset_variable
- ip_get_global_var
- ip_get_global_var2
- ip_set_global_var
- ip_set_global_var2
- ip_unset_global_var
- ip_unset_global_var2
- lib_split_tklist_core
- lib_split_tklist
- ip_split_tklist
- lib_merge_tklist
- lib_conv_listelement
- lib_getversion
- lib_get_reltype_name
- tcltklib_compile_info
- create_dummy_encoding_for_tk_core
- create_dummy_encoding_for_tk
- update_encoding_table
- encoding_table_get_name_core
- encoding_table_get_obj_core
- update_encoding_table
- encoding_table_get_name_core
- encoding_table_get_obj_core
- encoding_table_get_name_core
- encoding_table_get_obj_core
- encoding_table_get_name
- encoding_table_get_obj
- create_encoding_table_core
- create_encoding_table_core
- create_encoding_table_core
- create_encoding_table
- ip_get_encoding_table
- ip_make_menu_embeddable_core
- ip_make_menu_embeddable
- Init_tcltklib
/*
* tcltklib.c
* Aug. 27, 1997 Y. Shigehiro
* Oct. 24, 1997 Y. Matsumoto
*/
#define TCLTKLIB_RELEASE_DATE "2010-08-25"
/* #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
#undef RUBY_UNTYPED_DATA_WARNING
#define RUBY_UNTYPED_DATA_WARNING 0
#ifdef HAVE_RB_THREAD_CHECK_TRAP_PENDING
static int rb_thread_critical; /* dummy */
int rb_thread_check_trap_pending(void);
#else
/* use rb_thread_critical on Ruby 1.8.x */
#include "rubysig.h"
#define rb_thread_check_trap_pending() (0+rb_trap_pending)
#endif
#if !defined(RSTRING_PTR)
#define RSTRING_PTR(s) (RSTRING(s)->ptr)
#define RSTRING_LEN(s) (RSTRING(s)->len)
#endif
#if !defined(RSTRING_LENINT)
#define RSTRING_LENINT(s) ((int)RSTRING_LEN(s))
#endif
#if !defined(RARRAY_PTR)
#define RARRAY_PTR(s) (RARRAY(s)->ptr)
#define RARRAY_LEN(s) (RARRAY(s)->len)
#endif
#if !defined(RARRAY_CONST_PTR)
#define RARRAY_CONST_PTR(s) (const VALUE *)RARRAY_PTR(s)
#endif
#if !defined(RARRAY_AREF)
#define RARRAY_AREF(a, i) RARRAY_CONST_PTR(a)[i]
#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
#define RbTk_ALLOC_N(type, n) (type *)ckalloc((int)(sizeof(type) * (n)))
#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(void)
{
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 void ip_free _((void *p));
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
#ifndef HAVE_RB_THREAD_ALIVE_P
#define rb_thread_alive_p(thread) rb_funcall2((thread), ID_alive_p, 0, NULL)
#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__
/*
* 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 5/*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 const rb_data_type_t tcltkip_type = {
"tcltkip",
{0, ip_free, 0,},
};
static struct tcltkip *
get_ip(self)
VALUE self;
{
struct tcltkip *ptr;
TypedData_Get_Struct(self, struct tcltkip, &tcltkip_type, 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;
VALUE msg;
VALUE einfo;
struct tcltkip *ptr = get_ip(interp);
va_init_list(args,fmt);
msg = rb_vsprintf(fmt, args);
va_end(args);
einfo = rb_exc_new_str(exc, msg);
rb_ivar_set(einfo, ID_at_interp, interp);
if (ptr) {
Tcl_ResetResult(ptr->ip);
}
return einfo;
}
/*####################################################################*/
#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
/*--------------------------------------------------------*/
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 84
#error Ruby/Tk-Kit requires Tcl/Tk8.4 or later.
#endif
/*--------------------------------------------------------*/
/* Many part of code to support Ruby/Tk-Kit is quoted from Tclkit. */
/* But, never ask Tclkit community about Ruby/Tk-Kit. */
/* Please ask Ruby (Ruby/Tk) community (e.g. "ruby-dev" mailing list). */
/*
----<< license terms of TclKit (from kitgen's "README" file) >>---------------
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, TclVFS, Thread, Vlerq, Zlib
------------------------------------------------------------------------------
*/
/* 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_ZLIB
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
#define KIT_INCLUDES_ZLIB 1
#else
#define KIT_INCLUDES_ZLIB 0
#endif
#endif
#ifdef _WIN32
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
#endif
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
EXTERN Tcl_Obj* TclGetStartupScriptPath();
EXTERN void TclSetStartupScriptPath _((Tcl_Obj*));
#define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath()
#define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path)
#endif
#if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED)
EXTERN char* TclSetPreInitScript _((char *));
#endif
#ifndef KIT_INCLUDES_TK
# define KIT_INCLUDES_TK 1
#endif
/* #define KIT_INCLUDES_ITCL 1 */
/* #define KIT_INCLUDES_THREAD 1 */
Tcl_AppInitProc Vfs_Init, Rechan_Init;
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
Tcl_AppInitProc Pwb_Init;
#endif
#ifdef KIT_LITE
Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit;
#else
Tcl_AppInitProc Mk4tcl_Init;
#endif
#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
Tcl_AppInitProc Thread_Init;
#endif
#if KIT_INCLUDES_ZLIB
Tcl_AppInitProc Zlib_Init;
#endif
#ifdef KIT_INCLUDES_ITCL
Tcl_AppInitProc Itcl_Init;
#endif
#ifdef _WIN32
Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init;
#endif
/*--------------------------------------------------------*/
#define RUBYTK_KITPATH_CONST_NAME "RUBYTK_KITPATH"
static char *rubytk_kitpath = NULL;
static char rubytkkit_preInitCmd[] =
"proc tclKitPreInit {} {\n"
"rename tclKitPreInit {}\n"
"load {} rubytk_kitpath\n"
#if KIT_INCLUDES_ZLIB
"catch {load {} zlib}\n"
#endif
#ifdef KIT_LITE
"load {} vlerq\n"
"namespace eval ::vlerq {}\n"
"if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n"
"set n -1\n"
"} else {\n"
"set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n"
"set n [lsearch [vlerq get $files * name] boot.tcl]\n"
"}\n"
"if {$n >= 0} {\n"
"array set a [vlerq get $files $n]\n"
#else
"load {} Mk4tcl\n"
#if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT
/* running command cannot open itself for writing */
"mk::file open exe $::tcl::kitpath\n"
#else
"mk::file open exe $::tcl::kitpath -readonly\n"
#endif
"set n [mk::select exe.dirs!0.files name boot.tcl]\n"
"if {[llength $n] == 1} {\n"
"array set a [mk::get exe.dirs!0.files!$n]\n"
#endif
"if {![info exists a(contents)]} { error {no boot.tcl file} }\n"
"if {$a(size) != [string length $a(contents)]} {\n"
"set a(contents) [zlib decompress $a(contents)]\n"
"}\n"
"if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n"
"uplevel #0 $a(contents)\n"
#if 0
"} elseif {[lindex $::argv 0] eq \"-init-\"} {\n"
"uplevel #0 { source [lindex $::argv 1] }\n"
"exit\n"
#endif
"} else {\n"
/* When cannot find VFS data, try to use a real directory */
"set vfsdir \"[file rootname $::tcl::kitpath].vfs\"\n"
"if {[file isdirectory $vfsdir]} {\n"
"set ::tcl_library [file join $vfsdir lib tcl$::tcl_version]\n"
"set ::tcl_libPath [list $::tcl_library [file join $vfsdir lib]]\n"
"catch {uplevel #0 [list source [file join $vfsdir config.tcl]]}\n"
"uplevel #0 [list source [file join $::tcl_library init.tcl]]\n"
"set ::auto_path $::tcl_libPath\n"
"} else {\n"
"error \"\n $::tcl::kitpath has no VFS data to start up\"\n"
"}\n"
"}\n"
"}\n"
"tclKitPreInit"
;
#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 $::tcl::kitpath 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 $::tcl::kitpath main.tcl]\n"
"} else continue\n"
;
#endif
/*--------------------------------------------------------*/
static char*
set_rubytk_kitpath(const char *kitpath)
{
if (kitpath) {
int len = (int)strlen(kitpath);
if (rubytk_kitpath) {
ckfree(rubytk_kitpath);
}
rubytk_kitpath = (char *)ckalloc(len + 1);
memcpy(rubytk_kitpath, kitpath, len);
rubytk_kitpath[len] = '\0';
}
return rubytk_kitpath;
}
/*--------------------------------------------------------*/
#ifdef WIN32
#define DEV_NULL "NUL"
#else
#define DEV_NULL "/dev/null"
#endif
static void
check_tclkit_std_channels(void)
{
Tcl_Channel chan;
/*
* We need to verify if we have the standard channels and create them if
* not. Otherwise internals channels may get used as standard channels
* (like for encodings) and panic.
*/
chan = Tcl_GetStdChannel(TCL_STDIN);
if (chan == NULL) {
chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0);
if (chan != NULL) {
Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
}
Tcl_SetStdChannel(chan, TCL_STDIN);
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan == NULL) {
chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
if (chan != NULL) {
Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
}
Tcl_SetStdChannel(chan, TCL_STDOUT);
}
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan == NULL) {
chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
if (chan != NULL) {
Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
}
Tcl_SetStdChannel(chan, TCL_STDERR);
}
}
/*--------------------------------------------------------*/
static int
rubytk_kitpathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
const char* str;
if (objc == 2) {
set_rubytk_kitpath(Tcl_GetString(objv[1]));
} else if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?path?");
}
str = rubytk_kitpath ? rubytk_kitpath : Tcl_GetNameOfExecutable();
Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1));
return TCL_OK;
}
/*
* Public entry point for ::tcl::kitpath.
* Creates both link variable name and Tcl command ::tcl::kitpath.
*/
static int
rubytk_kitpath_init(Tcl_Interp *interp)
{
Tcl_CreateObjCommand(interp, "::tcl::kitpath", rubytk_kitpathObjCmd, 0, 0);
if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &rubytk_kitpath,
TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
Tcl_ResetResult(interp);
}
Tcl_CreateObjCommand(interp, "::tcl::rubytk_kitpath", rubytk_kitpathObjCmd, 0, 0);
if (Tcl_LinkVar(interp, "::tcl::rubytk_kitpath", (char *) &rubytk_kitpath,
TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
Tcl_ResetResult(interp);
}
if (rubytk_kitpath == NULL) {
/*
* XXX: We may want to avoid doing this to allow tcl::kitpath calls
* XXX: to obtain changes in nameofexe, if they occur.
*/
set_rubytk_kitpath(Tcl_GetNameOfExecutable());
}
return Tcl_PkgProvide(interp, "rubytk_kitpath", "1.0");
}
/*--------------------------------------------------------*/
static void
init_static_tcltk_packages(void)
{
/*
* Ensure that std channels exist (creating them if necessary)
*/
check_tclkit_std_channels();
#ifdef KIT_INCLUDES_ITCL
Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
#endif
#ifdef KIT_LITE
Tcl_StaticPackage(0, "Vlerq", Vlerq_Init, Vlerq_SafeInit);
#else
Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
#endif
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
#endif
Tcl_StaticPackage(0, "rubytk_kitpath", rubytk_kitpath_init, NULL);
Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
#if KIT_INCLUDES_ZLIB
Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
#endif
#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit);
#endif
#ifdef _WIN32
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit);
#else
Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
#endif
Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
#endif
#ifdef KIT_INCLUDES_TK
Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
#endif
}
/*--------------------------------------------------------*/
static int
call_tclkit_init_script(Tcl_Interp *interp)
{
#if 0
/* Currently, do nothing 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_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) {
const char *encoding = NULL;
Tcl_Obj* path = Tcl_GetStartupScript(&encoding);
Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding);
if (path == NULL) {
Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
}
}
#endif
return 1;
}
/*--------------------------------------------------------*/
#ifdef __WIN32__
/* #include <tkWinInt.h> *//* conflict definition of struct timezone */
/* #include <tkIntPlatDecls.h> */
/* #include <windows.h> */
EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance);
void rbtk_win32_SetHINSTANCE(const char *module_name)
{
/* TCHAR szBuf[256]; */
HINSTANCE hInst;
/* hInst = GetModuleHandle(NULL); */
/* hInst = GetModuleHandle("tcltklib.so"); */
hInst = GetModuleHandle(module_name);
TkWinSetHINSTANCE(hInst);
/* GetModuleFileName(hInst, szBuf, sizeof(szBuf) / sizeof(TCHAR)); */
/* MessageBox(NULL, szBuf, TEXT("OK"), MB_OK); */
}
#endif
/*--------------------------------------------------------*/
static void
setup_rubytkkit(void)
{
init_static_tcltk_packages();
{
ID const_id;
const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME);
if (rb_const_defined(rb_cObject, const_id)) {
volatile VALUE pathobj;
pathobj = rb_const_get(rb_cObject, const_id);
if (rb_obj_is_kind_of(pathobj, rb_cString)) {
#ifdef HAVE_RUBY_ENCODING_H
pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding());
#endif
set_rubytk_kitpath(RSTRING_PTR(pathobj));
}
}
}
#ifdef CREATE_RUBYTK_KIT
if (rubytk_kitpath == NULL) {
#ifdef __WIN32__
/* rbtk_win32_SetHINSTANCE("tcltklib.so"); */
{
# ifdef HAVE_RUBY_ENC_FIND_BASENAME
const char *base = ruby_enc_find_basename(rb_sourcefile(), NULL, NULL,
rb_filesystem_encoding());
rbtk_win32_SetHINSTANCE(base);
# else
VALUE basename;
basename = rb_funcall(rb_cFile, rb_intern("basename"), 1,
rb_str_new2(rb_sourcefile()));
rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename));
RB_GC_GUARD(basename);
# endif
}
#endif
set_rubytk_kitpath(rb_sourcefile());
}
#endif
if (rubytk_kitpath == NULL) {
set_rubytk_kitpath(Tcl_GetNameOfExecutable());
}
TclSetPreInitScript(rubytkkit_preInitCmd);
}
/*--------------------------------------------------------*/
#endif /* defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT */
/*####################################################################*/
/**********************************************************************/
/* stub status */
static void
tcl_stubs_check(void)
{
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 exception 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(void)
{
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;
}
UNREACHABLE;
}
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;
}
UNREACHABLE;
}
/* 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 = RbTk_ALLOC_N(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 = RbTk_ALLOC_N(CONST84 char *, 3);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
#endif
argv[0] = (char *)"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 = RbTk_ALLOC_N(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(void)
{
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;
{
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;
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);
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);
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_AREF(divmod, 0));
tcl_time.usec = NUM2LONG(RARRAY_AREF(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_AREF(divmod, 0));
tcl_time.usec = (long)(NUM2DBL(RARRAY_AREF(divmod, 1)) * 1000000);
default:
{
VALUE tmp = rb_funcallv(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;
{
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);
/* 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
}
void
rbtk_EventSetupProc(ClientData clientData, int flag)
{
Tcl_Time tcl_time;
tcl_time.sec = 0;
tcl_time.usec = 1000L * (long)no_event_tick;
Tcl_SetMaxBlockTime(&tcl_time);
}
void
rbtk_EventCheckProc(ClientData clientData, int flag)
{
rb_thread_schedule();
}
#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
#if 0
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 = (int)(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 : %"PRIxVALUE, rb_thread_current());
rb_thread_wait_for(t);
DUMP2("eventloop_sleep: finish at thread : %"PRIxVALUE, 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;
}
#endif
#define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0
#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
static int
get_thread_alone_check_flag(void)
{
#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(void)
{
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;
#if 0
struct timeval t;
#endif
int thr_crit_bup;
int status;
int depth = rbtk_eventloop_depth;
#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
int thread_alone_check_flag = 1;
#else
enum {thread_alone_check_flag = 1};
#endif
if (update_flag) DUMP1("update loop start!!");
#if 0
t.tv_sec = 0;
t.tv_usec = 1000 * no_event_wait;
#endif
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 (thread_alone_check_flag && rb_thread_alone()) {
DUMP1("no other thread");
event_loop_wait_event = 0;
if (update_flag) {
event_flag = 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:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception
= rb_exc_new2(rb_eException, "unknown exception");
} else {
rbtk_pending_exception = rb_errinfo();
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:
if (NIL_P(rb_errinfo())) {
rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
} else {
rb_exc_raise(rb_errinfo());
}
}
}
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;
}
}
TRAP_CHECK();
if (check_eventloop_interp()) return 0;
DUMP1("check Root Widget");
if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
run_timer_flag = 0;
TRAP_CHECK();
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; /* for safety */
/* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */
} else {
event_flag = TCL_ALL_EVENTS;
/* 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_USE_NATIVE_THREAD
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:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception
= rb_exc_new2(rb_eException,
"unknown exception");
} else {
rbtk_pending_exception = rb_errinfo();
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:
if (NIL_P(rb_errinfo())) {
rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
} else {
rb_exc_raise(rb_errinfo());
}
}
}
if (depth != rbtk_eventloop_depth) {
DUMP2("DoOneEvent(2) abnormal exit!! %d",
rbtk_eventloop_depth);
return 0;
}
TRAP_CHECK();
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;
#if 0
/* rb_thread_wait_for(t); */
rb_protect(eventloop_sleep, Qnil, &status);
if (status) {
switch (status) {
case TAG_RAISE:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception
= rb_exc_new2(rb_eException,
"unknown exception");
} else {
rbtk_pending_exception = rb_errinfo();
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:
if (NIL_P(rb_errinfo())) {
rb_exc_raise(rb_exc_new2(rb_eFatal,
"FATAL"));
} else {
rb_exc_raise(rb_errinfo());
}
}
}
#endif
}
} else {
DUMP2("sleep eventloop %"PRIxVALUE, current);
DUMP2("eventloop thread is %"PRIxVALUE, eventloop_thread);
/* rb_thread_stop(); */
rb_thread_sleep_forever();
}
if (!NIL_P(watchdog_thread) && eventloop_thread != current) {
return 1;
}
TRAP_CHECK();
if (check_eventloop_interp()) return 0;
DUMP1("check Root Widget");
if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
run_timer_flag = 0;
TRAP_CHECK();
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("check interrupts");
#if defined(RUBY_USE_NATIVE_THREAD) || defined(RUBY_VM)
if (update_flag == 0) rb_thread_check_ints();
#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;
Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
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:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception
= rb_exc_new2(rb_eException, "unknown exception");
} else {
rbtk_pending_exception = rb_errinfo();
}
return Qnil;
case TAG_FATAL:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
} else {
rbtk_pending_exception = rb_errinfo();
}
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();
Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
DUMP2("eventloop_ensure: current-thread : %"PRIxVALUE, current_evloop);
DUMP2("eventloop_ensure: eventloop-thread : %"PRIxVALUE, eventloop_thread);
if (eventloop_thread != current_evloop) {
DUMP2("finish eventloop %"PRIxVALUE" (NOT current eventloop)", current_evloop);
rb_thread_critical = ptr->thr_crit_bup;
xfree(ptr);
/* ckfree((char*)ptr); */
return Qnil;
}
while((eventloop_thread = rb_ary_pop(eventloop_stack))) {
DUMP2("eventloop-ensure: new eventloop-thread -> %"PRIxVALUE,
eventloop_thread);
if (eventloop_thread == current_evloop) {
rbtk_eventloop_depth--;
DUMP2("eventloop %"PRIxVALUE" : 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_thread_alive_p(eventloop_thread))) {
DUMP2("eventloop-enshure: wake up parent %"PRIxVALUE, eventloop_thread);
rb_thread_wakeup(eventloop_thread);
break;
}
}
#ifdef RUBY_USE_NATIVE_THREAD
if (NIL_P(eventloop_thread)) {
tk_eventloop_thread_id = (Tcl_ThreadId) 0;
}
#endif
rb_thread_critical = ptr->thr_crit_bup;
xfree(ptr);
/* ckfree((char*)ptr);*/
DUMP2("finish current eventloop %"PRIxVALUE, 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 = RbTk_ALLOC_N(struct evloop_params, 1); */
tcl_stubs_check();
eventloop_thread = rb_thread_current();
#ifdef RUBY_USE_NATIVE_THREAD
tk_eventloop_thread_id = Tcl_GetCurrentThread();
#endif
if (parent_evloop == eventloop_thread) {
DUMP2("eventloop: recursive call on %"PRIxVALUE, parent_evloop);
rbtk_eventloop_depth++;
}
if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) {
DUMP2("wait for stop of parent_evloop %"PRIxVALUE, parent_evloop);
while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) {
DUMP2("parent_evloop %"PRIxVALUE" 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 : %"PRIxVALUE" -> %"PRIxVALUE"\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;
{
volatile VALUE ret;
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;
}
eventloop_interp = ptr->ip;
ret = lib_mainloop(argc, argv, self);
eventloop_interp = (Tcl_Interp*)NULL;
return ret;
}
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 = 0;
t0.tv_usec = (long)((NO_THREAD_INTERRUPT_TIME)*1000.0);
t1.tv_sec = 0;
t1.tv_usec = (long)((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 %"PRIxVALUE" is sleeping or dead",
eventloop_thread);
evloop = rb_thread_create(watchdog_evloop_launcher,
(void*)&check_rootwidget);
DUMP2("create new eventloop thread %"PRIxVALUE, 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_USE_NATIVE_THREAD
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
#ifdef HAVE_PROTOTYPES
_thread_call_proc_value(VALUE th)
#else
_thread_call_proc_value(th)
VALUE th;
#endif
{
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;
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 = RbTk_ALLOC_N(struct thread_call_proc_arg, 1); */
q->proc = proc;
q->done = (int*)ALLOC(int);
/* q->done = RbTk_ALLOC_N(int, 1); */
*(q->done) = 0;
/* create call-proc thread */
th = rb_thread_create(_thread_call_proc, (void*)q);
rb_thread_schedule();
/* start sub-eventloop */
lib_eventloop_launcher(/* not check root-widget */0, 0,
q->done, (Tcl_Interp*)NULL);
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);
}
xfree(q->done);
xfree(q);
/* ckfree((char*)q->done); */
/* ckfree((char*)q); */
if (NIL_P(rbtk_pending_exception)) {
/* return rb_errinfo(); */
if (status) {
rb_exc_raise(rb_errinfo());
}
} 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;
{
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 = (int)FIX2LONG(vflags);
}
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_funcallv(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 (RB_TYPE_P(enc, T_STRING)) {
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
} else {
enc = rb_funcallv(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_LENINT(msg)+1);
/* buf = ckalloc(RSTRING_LENINT(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_LENINT(msg), &dstr);
Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
DUMP2("error message:%s", Tcl_DStringValue(&dstr));
Tcl_DStringFree(&dstr);
xfree(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_funcallv(obj, ID_to_s, 0, 0);
}
}
return rb_funcallv(obj, ID_inspect, 0, 0);
}
static int
#ifdef HAVE_PROTOTYPES
tcl_protect_core(Tcl_Interp *interp, VALUE (*proc)(VALUE), VALUE data)
#else
tcl_protect_core(interp, proc, data) /* should not raise exception */
Tcl_Interp *interp;
VALUE (*proc)();
VALUE data;
#endif
{
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: ");
rb_str_append(str, rb_obj_as_string(rb_errinfo()));
exc = rb_exc_new3(type, str);
break;
case TAG_RETRY:
if (NIL_P(rb_errinfo())) {
DUMP1("rb_protect: retry");
exc = rb_exc_new2(eTkCallbackRetry, "retry jump error");
} else {
exc = rb_errinfo();
}
break;
case TAG_REDO:
if (NIL_P(rb_errinfo())) {
DUMP1("rb_protect: redo");
exc = rb_exc_new2(eTkCallbackRedo, "redo jump error");
} else {
exc = rb_errinfo();
}
break;
case TAG_RAISE:
if (NIL_P(rb_errinfo())) {
exc = rb_exc_new2(rb_eException, "unknown exception");
} else {
exc = rb_errinfo();
}
break;
case TAG_FATAL:
if (NIL_P(rb_errinfo())) {
exc = rb_exc_new2(rb_eFatal, "FATAL");
} else {
exc = rb_errinfo();
}
break;
case TAG_THROW:
if (NIL_P(rb_errinfo())) {
DUMP1("rb_protect: throw");
exc = rb_exc_new2(eTkCallbackThrow, "throw jump error");
} else {
exc = rb_errinfo();
}
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);
xfree(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_funcallv(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 (RB_TYPE_P(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 code;
#ifdef HAVE_NATIVETHREAD
#ifndef RUBY_USE_NATIVE_THREAD
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on tcl_protect()");
}
#endif
#endif
#ifdef RUBY_VM
code = tcl_protect_core(interp, proc, data);
#else
do {
int old_trapflag = rb_trap_immediate;
rb_trap_immediate = 0;
code = tcl_protect_core(interp, proc, data);
rb_trap_immediate = old_trapflag;
} while (0);
#endif
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
xfree(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);
DUMP2("rb_apply return:%"PRIxVALUE, ret);
rb_thread_critical = thr_crit_bup;
DUMP1("finish ip_ruby_cmd_core");
return ret;
}
static VALUE
ip_ruby_cmd_receiver_const_get(name)
char *name;
{
return rb_path2class(name);
}
static VALUE
ip_ruby_cmd_receiver_get(str)
char *str;
{
volatile VALUE receiver;
int state;
if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
/* class | module | constant */
receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state);
if (state) return Qnil;
} else if (str[0] == '$') {
/* global variable */
receiver = rb_gv_get(str);
} else {
/* global variable omitted '$' */
char *buf;
size_t 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);
xfree(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);
for(i = 3; i < argc; i++) {
VALUE s;
#if TCL_MAJOR_VERSION >= 8
str = Tcl_GetStringFromObj(argv[i], &len);
s = rb_tainted_str_new(str, len);
#else /* TCL_MAJOR_VERSION < 8 */
str = argv[i];
s = rb_tainted_str_new2(str);
#endif
DUMP2("arg:%s",str);
rb_ary_push(args, s);
}
if (old_gc == Qfalse) rb_gc_enable();
rb_thread_critical = thr_crit_bup;
/* allocate */
arg = ALLOC(struct cmd_body_arg);
/* arg = RbTk_ALLOC_N(struct cmd_body_arg, 1); */
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);
xfree(arg);
/* ckfree((char*)arg); */
return code;
}
/*****************************/
/* relpace of 'exit' command */
/*****************************/
static int
#if TCL_MAJOR_VERSION >= 8
#ifdef HAVE_PROTOTYPES
ip_InterpExitObjCmd(ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST argv[])
#else
ip_InterpExitObjCmd(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#endif
#else /* TCL_MAJOR_VERSION < 8 */
#ifdef HAVE_PROTOTYPES
ip_InterpExitCommand(ClientData clientData, Tcl_Interp *interp,
int argc, char *argv[])
#else
ip_InterpExitCommand(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
#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 {}"); */
if (!Tcl_InterpDeleted(interp)) {
ip_finalize(interp);
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
}
}
return TCL_OK;
}
static int
#if TCL_MAJOR_VERSION >= 8
#ifdef HAVE_PROTOTYPES
ip_RubyExitObjCmd(ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST argv[])
#else
ip_RubyExitObjCmd(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#endif
#else /* TCL_MAJOR_VERSION < 8 */
#ifdef HAVE_PROTOTYPES
ip_RubyExitCommand(ClientData clientData, Tcl_Interp *interp,
int argc, char *argv[])
#else
ip_RubyExitCommand(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
#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) {
/* argument 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 (Tcl_IsSafe(interp)) {
if (!Tcl_InterpDeleted(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:
/* argument 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 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
#ifndef RUBY_USE_NATIVE_THREAD
if (!ruby_native_thread_p()) {
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
int optionIndex;
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 */
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_thread_check_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
{
# if 0
int flags = 0;
# endif
struct th_update_param *param;
static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
enum updateOptions {REGEXP_IDLETASKS};
volatile VALUE current_thread = rb_thread_current();
struct timeval t;
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
#ifndef RUBY_USE_NATIVE_THREAD
if (!ruby_native_thread_p()) {
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) {
# if 0
flags = TCL_DONT_WAIT;
# endif
} else if (objc == 2) {
#if TCL_MAJOR_VERSION >= 8
int optionIndex;
if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
case REGEXP_IDLETASKS: {
# if 0
flags = TCL_IDLE_EVENTS;
# endif
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;
}
# if 0
flags = TCL_IDLE_EVENTS;
# endif
#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 = RbTk_ALLOC_N(struct th_update_param, 1);
#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);
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
while(!param->done) {
DUMP1("wait for complete idle proc");
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
if (NIL_P(eventloop_thread)) {
break;
}
}
#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; /* Not used */
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int
ip_rbVwaitCommand(clientData, interp, objc, objv)
ClientData clientData; /* Not used */
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
#ifndef RUBY_USE_NATIVE_THREAD
if (!ruby_native_thread_p()) {
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_thread_check_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)tkwin, interp, objc, objv);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call ip_rb_threadTkWaitCommand");
return ip_rb_threadTkWwaitCommand((ClientData)tkwin, 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_thread_check_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,
WaitVisibilityProc, (ClientData) &done);
rb_thread_critical = thr_crit_bup;
done = 0;
/* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
/* exception check */
if (!NIL_P(rbtk_pending_exception)) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#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_thread_check_trap_pending()) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(interp);
return TCL_RETURN;
}
if (done != 1) {
/*
* Note that we do not delete the event handler because it
* was deleted automatically when the window was destroyed.
*/
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "window \"", nameString,
"\" was deleted before its visibility changed",
(char *) NULL);
rb_thread_critical = thr_crit_bup;
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tk_DeleteEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,
WaitVisibilityProc, (ClientData) &done);
rb_thread_critical = thr_crit_bup;
break;
case TKWAIT_WINDOW:
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 TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
if (window == NULL) {
Tcl_AppendResult(interp, ": tkwait: ",
"no main-window (not Tk application?)",
(char*)NULL);
rb_thread_critical = thr_crit_bup;
Tcl_Release(interp);
return TCL_ERROR;
}
Tk_CreateEventHandler(window, StructureNotifyMask,
WaitWindowProc, (ClientData) &done);
rb_thread_critical = thr_crit_bup;
done = 0;
/* lib_eventloop_core(check_rootwidget_flag, 0, &done); */
lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
/* 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_thread_check_trap_pending()) {
Tcl_Release(interp);
return TCL_RETURN;
}
/*
* Note: there's no need to delete the event handler. It was
* deleted automatically when the window was destroyed.
*/
break;
}
/*
* Clear out the interpreter's result, since it may have been set
* by event handlers.
*/
Tcl_ResetResult(interp);
Tcl_Release(interp);
return TCL_OK;
}
/****************************/
/* vwait/tkwait with thread */
/****************************/
struct th_vwait_param {
VALUE thread;
int done;
};
#if TCL_MAJOR_VERSION >= 8
static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
CONST84 char *,CONST84 char *, int));
static char *
rb_threadVwaitProc(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 *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
char *, char *, int));
static char *
rb_threadVwaitProc(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
{
struct th_vwait_param *param = (struct th_vwait_param *) clientData;
if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) {
param->done = -1;
} else {
param->done = 1;
}
if (param->done != 0) rb_thread_wakeup(param->thread);
return (char *)NULL;
}
#define TKWAIT_MODE_VISIBILITY 1
#define TKWAIT_MODE_DESTROY 2
static void rb_threadWaitVisibilityProc _((ClientData, XEvent *));
static void
rb_threadWaitVisibilityProc(clientData, eventPtr)
ClientData clientData; /* Pointer to integer to set to 1. */
XEvent *eventPtr; /* Information about event (not used). */
{
struct th_vwait_param *param = (struct th_vwait_param *) clientData;
if (eventPtr->type == VisibilityNotify) {
param->done = TKWAIT_MODE_VISIBILITY;
}
if (eventPtr->type == DestroyNotify) {
param->done = TKWAIT_MODE_DESTROY;
}
if (param->done != 0) rb_thread_wakeup(param->thread);
}
static void rb_threadWaitWindowProc _((ClientData, XEvent *));
static void
rb_threadWaitWindowProc(clientData, eventPtr)
ClientData clientData; /* Pointer to integer to set to 1. */
XEvent *eventPtr; /* Information about event. */
{
struct th_vwait_param *param = (struct th_vwait_param *) clientData;
if (eventPtr->type == DestroyNotify) {
param->done = TKWAIT_MODE_DESTROY;
}
if (param->done != 0) rb_thread_wakeup(param->thread);
}
#if TCL_MAJOR_VERSION >= 8
static int
ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int
ip_rb_threadVwaitCommand(clientData, interp, objc, objv)
ClientData clientData; /* Not used */
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
struct th_vwait_param *param;
char *nameString;
int ret, dummy;
int thr_crit_bup;
volatile VALUE current_thread = rb_thread_current();
struct timeval t;
DUMP1("Ruby's 'thread_vwait' is called");
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
if (rb_thread_alone() || eventloop_thread == current_thread) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rbVwaitObjCmd");
return ip_rbVwaitObjCmd(clientData, interp, objc, objv);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call ip_rbVwaitCommand");
return ip_rbVwaitCommand(clientData, interp, objc, objv);
#endif
}
Tcl_Preserve(interp);
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;
}
#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
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */
param = RbTk_ALLOC_N(struct th_vwait_param, 1);
#if 1 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)param);
#endif
param->thread = current_thread;
param->done = 0;
/*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
return TCL_ERROR;
}
*/
ret = Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param);
rb_thread_critical = thr_crit_bup;
if (ret != TCL_OK) {
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
return TCL_ERROR;
}
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
while(!param->done) {
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
if (NIL_P(eventloop_thread)) {
break;
}
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if (param->done > 0) {
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param);
}
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
rb_thread_critical = thr_crit_bup;
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[1]);
#endif
Tcl_Release(interp);
return TCL_OK;
}
#if TCL_MAJOR_VERSION >= 8
static int
ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int
ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
struct th_vwait_param *param;
Tk_Window tkwin = (Tk_Window) clientData;
Tk_Window window;
int 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;
volatile VALUE current_thread = rb_thread_current();
struct timeval t;
DUMP1("Ruby's 'thread_tkwait' is called");
if (interp == (Tcl_Interp*)NULL) {
rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
"IP is deleted");
return TCL_ERROR;
}
if (rb_thread_alone() || eventloop_thread == current_thread) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rbTkWaitObjCmd");
DUMP2("eventloop_thread %"PRIxVALUE, eventloop_thread);
DUMP2("current_thread %"PRIxVALUE, current_thread);
return ip_rbTkWaitObjCmd(clientData, interp, objc, objv);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call rb_VwaitCommand");
return ip_rbTkWaitCommand(clientData, interp, objc, objv);
#endif
}
Tcl_Preserve(interp);
Tcl_Preserve(tkwin);
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(tkwin);
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(tkwin);
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(tkwin);
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
/* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */
param = RbTk_ALLOC_N(struct th_vwait_param, 1);
#if 1 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)param);
#endif
param->thread = current_thread;
param->done = 0;
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,
rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
return TCL_ERROR;
}
*/
ret = Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param);
rb_thread_critical = thr_crit_bup;
if (ret != TCL_OK) {
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release(param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(tkwin);
Tcl_Release(interp);
return TCL_ERROR;
}
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
while(!param->done) {
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
if (NIL_P(eventloop_thread)) {
break;
}
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if (param->done > 0) {
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param);
}
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
rb_thread_critical = thr_crit_bup;
break;
case TKWAIT_VISIBILITY:
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if 0 /* variable 'tkwin' must keep the token of MainWindow */
if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
window = NULL;
} else {
window = Tk_NameToWindow(interp, nameString, tkwin);
}
#else
if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
window = NULL;
} else {
/* Tk_NameToWindow() returns right token on non-eventloop thread */
Tcl_CmdInfo info;
if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */
window = Tk_NameToWindow(interp, nameString, tkwin);
} else {
window = NULL;
}
}
#endif
if (window == NULL) {
Tcl_AppendResult(interp, ": thread_tkwait: ",
"no main-window (not Tk application?)",
(char*)NULL);
rb_thread_critical = thr_crit_bup;
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release(param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(tkwin);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Preserve(window);
Tk_CreateEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,
rb_threadWaitVisibilityProc, (ClientData) param);
rb_thread_critical = thr_crit_bup;
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
while(param->done != TKWAIT_MODE_VISIBILITY) {
if (param->done == TKWAIT_MODE_DESTROY) break;
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
if (NIL_P(eventloop_thread)) {
break;
}
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* when a window is destroyed, no need to call Tk_DeleteEventHandler */
if (param->done != TKWAIT_MODE_DESTROY) {
Tk_DeleteEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,
rb_threadWaitVisibilityProc,
(ClientData) param);
}
if (param->done != 1) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "window \"", nameString,
"\" was deleted before its visibility changed",
(char *) NULL);
rb_thread_critical = thr_crit_bup;
Tcl_Release(window);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release(param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
Tcl_Release(tkwin);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Release(window);
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
rb_thread_critical = thr_crit_bup;
break;
case TKWAIT_WINDOW:
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if 0 /* variable 'tkwin' must keep the token of MainWindow */
if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
window = NULL;
} else {
window = Tk_NameToWindow(interp, nameString, tkwin);
}
#else
if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
window = NULL;
} else {
/* Tk_NameToWindow() returns right token on non-eventloop thread */
Tcl_CmdInfo info;
if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */
window = Tk_NameToWindow(interp, nameString, tkwin);
} else {
window = NULL;
}
}
#endif
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[2]);
#endif
if (window == NULL) {
Tcl_AppendResult(interp, ": thread_tkwait: ",
"no main-window (not Tk application?)",
(char*)NULL);
rb_thread_critical = thr_crit_bup;
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release(param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
Tcl_Release(tkwin);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Preserve(window);
Tk_CreateEventHandler(window, StructureNotifyMask,
rb_threadWaitWindowProc, (ClientData) param);
rb_thread_critical = thr_crit_bup;
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
while(param->done != TKWAIT_MODE_DESTROY) {
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
if (NIL_P(eventloop_thread)) {
break;
}
}
Tcl_Release(window);
/* when a window is destroyed, no need to call Tk_DeleteEventHandler
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
Tk_DeleteEventHandler(window, StructureNotifyMask,
rb_threadWaitWindowProc, (ClientData) param);
rb_thread_critical = thr_crit_bup;
*/
break;
} /* end of 'switch' statement */
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 1 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)param);
#else
/* Tcl_Free((char *)param); */
ckfree((char *)param);
#endif
#endif
/*
* Clear out the interpreter's result, since it may have been set
* by event handlers.
*/
Tcl_ResetResult(interp);
Tcl_Release(tkwin);
Tcl_Release(interp);
return TCL_OK;
}
static VALUE
ip_thread_vwait(self, var)
VALUE self;
VALUE var;
{
VALUE argv[2];
volatile VALUE cmd_str = rb_str_new2("thread_vwait");
argv[0] = cmd_str;
argv[1] = var;
return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL);
}
static VALUE
ip_thread_tkwait(self, mode, target)
VALUE self;
VALUE mode;
VALUE target;
{
VALUE argv[3];
volatile VALUE cmd_str = rb_str_new2("thread_tkwait");
argv[0] = cmd_str;
argv[1] = mode;
argv[2] = target;
return ip_invoke_with_position(3, argv, self, TCL_QUEUE_TAIL);
}
/* delete slave interpreters */
#if TCL_MAJOR_VERSION >= 8
static void
delete_slaves(ip)
Tcl_Interp *ip;
{
int thr_crit_bup;
Tcl_Interp *slave;
Tcl_Obj *slave_list, *elem;
char *slave_name;
int i, len;
DUMP1("delete slaves");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
slave_list = Tcl_GetObjResult(ip);
Tcl_IncrRefCount(slave_list);
if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) {
for(i = 0; i < len; i++) {
Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem);
if (elem == (Tcl_Obj*)NULL) continue;
Tcl_IncrRefCount(elem);
/* get slave */
/* slave_name = Tcl_GetString(elem); */
slave_name = Tcl_GetStringFromObj(elem, (int*)NULL);
DUMP2("delete slave:'%s'", slave_name);
Tcl_DecrRefCount(elem);
slave = Tcl_GetSlave(ip, slave_name);
if (slave == (Tcl_Interp*)NULL) continue;
if (!Tcl_InterpDeleted(slave)) {
/* call ip_finalize */
ip_finalize(slave);
Tcl_DeleteInterp(slave);
/* Tcl_Release(slave); */
}
}
}
Tcl_DecrRefCount(slave_list);
}
rb_thread_critical = thr_crit_bup;
}
#else /* TCL_MAJOR_VERSION < 8 */
static void
delete_slaves(ip)
Tcl_Interp *ip;
{
int thr_crit_bup;
Tcl_Interp *slave;
int argc;
char **argv;
char *slave_list;
char *slave_name;
int i, len;
DUMP1("delete slaves");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
slave_list = ip->result;
if (Tcl_SplitList((Tcl_Interp*)NULL,
slave_list, &argc, &argv) == TCL_OK) {
for(i = 0; i < argc; i++) {
slave_name = argv[i];
DUMP2("delete slave:'%s'", slave_name);
slave = Tcl_GetSlave(ip, slave_name);
if (slave == (Tcl_Interp*)NULL) continue;
if (!Tcl_InterpDeleted(slave)) {
/* call ip_finalize */
ip_finalize(slave);
Tcl_DeleteInterp(slave);
}
}
}
}
rb_thread_critical = thr_crit_bup;
}
#endif
/* finalize operation */
static void
#ifdef HAVE_PROTOTYPES
lib_mark_at_exit(VALUE self)
#else
lib_mark_at_exit(self)
VALUE self;
#endif
{
at_exit = 1;
}
static int
#if TCL_MAJOR_VERSION >= 8
#ifdef HAVE_PROTOTYPES
ip_null_proc(ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST argv[])
#else
ip_null_proc(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
#endif
#else /* TCL_MAJOR_VERSION < 8 */
#ifdef HAVE_PROTOTYPES
ip_null_proc(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
#else
ip_null_proc(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
#endif
{
Tcl_ResetResult(interp);
return TCL_OK;
}
static void
ip_finalize(ip)
Tcl_Interp *ip;
{
Tcl_CmdInfo info;
int thr_crit_bup;
VALUE rb_debug_bup, rb_verbose_bup;
/* When ruby is exiting, printing debug messages in some callback
operations from Tcl-IP sometimes cause SEGV. I don't know the
reason. But I got SEGV when calling "rb_io_write(rb_stdout, ...)".
So, in some part of this function, debug mode and verbose mode
are disabled. If you know the reason, please fix it.
-- Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) */
DUMP1("start ip_finalize");
if (ip == (Tcl_Interp*)NULL) {
DUMP1("ip is NULL");
return;
}
if (Tcl_InterpDeleted(ip)) {
DUMP2("ip(%p) is already deleted", ip);
return;
}
#if TCL_NAMESPACE_DEBUG
if (ip_null_namespace(ip)) {
DUMP2("ip(%p) has null namespace", ip);
return;
}
#endif
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
rb_debug_bup = ruby_debug;
rb_verbose_bup = ruby_verbose;
Tcl_Preserve(ip);
/* delete slaves */
delete_slaves(ip);
/* shut off some connections from Tcl-proc to Ruby */
if (at_exit) {
/* NOTE: Only when at exit.
Because, ruby removes objects, which depends on the deleted
interpreter, on some callback operations.
It is important for GC. */
#if TCL_MAJOR_VERSION >= 8
Tcl_CreateObjCommand(ip, "ruby", ip_null_proc,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(ip, "ruby_eval", ip_null_proc,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(ip, "ruby_cmd", ip_null_proc,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
Tcl_CreateCommand(ip, "ruby", ip_null_proc,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateCommand(ip, "ruby_eval", ip_null_proc,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#endif
/*
rb_thread_critical = thr_crit_bup;
return;
*/
}
/* delete root widget */
#ifdef RUBY_VM
/* cause SEGV on Ruby 1.9 */
#else
DUMP1("check `destroy'");
if (Tcl_GetCommandInfo(ip, "destroy", &info)) {
DUMP1("call `destroy .'");
Tcl_GlobalEval(ip, "catch {destroy .}");
}
#endif
#if 1
DUMP1("destroy root widget");
if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) {
/*
* On Ruby VM, this code piece may be not called, because
* Tk_MainWindow() returns NULL on a native thread except
* the thread which initialize Tk environment.
* Of course, that is a problem. But maybe not so serious.
* All widgets are destroyed when the Tcl interp is deleted.
* At then, Ruby may raise exceptions on the delete hook
* callbacks which registered for the deleted widgets, and
* may fail to clear objects which depends on the widgets.
* Although it is the problem, it is possibly avoidable by
* rescuing exceptions and the finalize hook of the interp.
*/
Tk_Window win = Tk_MainWindow(ip);
DUMP1("call Tk_DestroyWindow");
ruby_debug = Qfalse;
ruby_verbose = Qnil;
if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) {
Tk_DestroyWindow(win);
}
ruby_debug = rb_debug_bup;
ruby_verbose = rb_verbose_bup;
}
#endif
/* call finalize-hook-proc */
DUMP1("check `finalize-hook-proc'");
if ( Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) {
DUMP2("call finalize hook proc '%s'", finalize_hook_name);
ruby_debug = Qfalse;
ruby_verbose = Qnil;
Tcl_GlobalEval(ip, finalize_hook_name);
ruby_debug = rb_debug_bup;
ruby_verbose = rb_verbose_bup;
}
DUMP1("check `foreach' & `after'");
if ( Tcl_GetCommandInfo(ip, "foreach", &info)
&& Tcl_GetCommandInfo(ip, "after", &info) ) {
DUMP1("cancel after callbacks");
ruby_debug = Qfalse;
ruby_verbose = Qnil;
Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}");
ruby_debug = rb_debug_bup;
ruby_verbose = rb_verbose_bup;
}
Tcl_Release(ip);
DUMP1("finish ip_finalize");
ruby_debug = rb_debug_bup;
ruby_verbose = rb_verbose_bup;
rb_thread_critical = thr_crit_bup;
}
/* destroy interpreter */
static void
ip_free(p)
void *p;
{
struct tcltkip *ptr = p;
int thr_crit_bup;
DUMP2("free Tcl Interp %p", ptr->ip);
if (ptr) {
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if ( ptr->ip != (Tcl_Interp*)NULL
&& !Tcl_InterpDeleted(ptr->ip)
&& Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL
&& !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) {
DUMP2("parent IP(%p) is not deleted",
Tcl_GetMaster(ptr->ip));
DUMP2("slave IP(%p) should not be deleted",
ptr->ip);
xfree(ptr);
/* ckfree((char*)ptr); */
rb_thread_critical = thr_crit_bup;
return;
}
if (ptr->ip == (Tcl_Interp*)NULL) {
DUMP1("ip_free is called for deleted IP");
xfree(ptr);
/* ckfree((char*)ptr); */
rb_thread_critical = thr_crit_bup;
return;
}
if (!Tcl_InterpDeleted(ptr->ip)) {
ip_finalize(ptr->ip);
Tcl_DeleteInterp(ptr->ip);
Tcl_Release(ptr->ip);
}
ptr->ip = (Tcl_Interp*)NULL;
xfree(ptr);
/* ckfree((char*)ptr); */
rb_thread_critical = thr_crit_bup;
}
DUMP1("complete freeing Tcl Interp");
}
/* create and initialize interpreter */
static VALUE ip_alloc _((VALUE));
static VALUE
ip_alloc(self)
VALUE self;
{
return TypedData_Wrap_Struct(self, &tcltkip_type, 0);
}
static void
ip_replace_wait_commands(interp, mainWin)
Tcl_Interp *interp;
Tk_Window mainWin;
{
/* replace 'vwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"vwait\")");
Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"vwait\")");
Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#endif
/* replace 'tkwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"tkwait\")");
Tcl_CreateCommand(interp, "tkwait", ip_rbTkWaitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* add 'thread_vwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")");
Tcl_CreateObjCommand(interp, "thread_vwait", ip_rb_threadVwaitObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
Tcl_CreateCommand(interp, "thread_vwait", ip_rb_threadVwaitCommand,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#endif
/* add 'thread_tkwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
Tcl_CreateObjCommand(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* replace 'update' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"update\")");
Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"update\")");
Tcl_CreateCommand(interp, "update", ip_rbUpdateCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* add 'thread_update' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"thread_update\")");
Tcl_CreateObjCommand(interp, "thread_update", ip_rb_threadUpdateObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"thread_update\")");
Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
}
#if TCL_MAJOR_VERSION >= 8
static int
ip_rb_replaceSlaveTkCmdsObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
#else /* TCL_MAJOR_VERSION < 8 */
static int
ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
char *objv[];
#endif
{
char *slave_name;
Tcl_Interp *slave;
Tk_Window mainWin;
if (objc != 2) {
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "slave_name");
#else
char *nameString;
#if TCL_MAJOR_VERSION >= 8
nameString = Tcl_GetStringFromObj(objv[0], (int*)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[0];
#endif
Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
nameString, " slave_name\"", (char *) NULL);
#endif
}
#if TCL_MAJOR_VERSION >= 8
slave_name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
#else
slave_name = objv[1];
#endif
slave = Tcl_GetSlave(interp, slave_name);
if (slave == NULL) {
Tcl_AppendResult(interp, "cannot find slave \"",
slave_name, "\"", (char *)NULL);
return TCL_ERROR;
}
mainWin = Tk_MainWindow(slave);
/* replace 'exit' command --> 'interp_exit' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateObjCommand(slave, "exit", ip_InterpExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateCommand(slave, "exit", ip_InterpExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* replace vwait and tkwait */
ip_replace_wait_commands(slave, mainWin);
return TCL_OK;
}
#ifndef ORIG_NAMESPACE_CMD
#define ORIG_NAMESPACE_CMD "__orig_namespace_command__"
#endif
#if TCL_MAJOR_VERSION >= 8
static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int,
Tcl_Obj *CONST []));
static int
ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Tcl_CmdInfo info;
int ret;
DUMP1("call ip_rbNamespaceObjCmd");
DUMP2("objc = %d", objc);
DUMP2("objv[0] = '%s'", Tcl_GetString(objv[0]));
DUMP2("objv[1] = '%s'", Tcl_GetString(objv[1]));
if (!Tcl_GetCommandInfo(interp, ORIG_NAMESPACE_CMD, &(info))) {
DUMP1("fail to get "ORIG_NAMESPACE_CMD);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"invalid command name \"namespace\"", (char*)NULL);
return TCL_ERROR;
}
rbtk_eventloop_depth++;
DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth);
if (info.isNativeObjectProc) {
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6
DUMP1("call a native-object-proc");
ret = (*(info.objProc))(info.objClientData, interp, objc, objv);
#else
/* Tcl8.6 or later */
int i;
Tcl_Obj **cp_objv;
char org_ns_cmd_name[] = ORIG_NAMESPACE_CMD;
DUMP1("call a native-object-proc for tcl8.6 or later");
cp_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc + 1));
cp_objv[0] = Tcl_NewStringObj(org_ns_cmd_name, strlen(org_ns_cmd_name));
for(i = 1; i < objc; i++) {
cp_objv[i] = objv[i];
}
cp_objv[objc] = (Tcl_Obj *)NULL;
/* ret = Tcl_EvalObjv(interp, objc, cp_objv, TCL_EVAL_DIRECT); */
ret = Tcl_EvalObjv(interp, objc, cp_objv, 0);
ckfree((char*)cp_objv);
#endif
} else {
/* string interface */
int i;
char **argv;
DUMP1("call with the string-interface");
/* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */
argv = RbTk_ALLOC_N(char *, (objc + 1));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
for(i = 0; i < objc; i++) {
/* argv[i] = Tcl_GetString(objv[i]); */
argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
}
argv[objc] = (char *)NULL;
ret = (*(info.proc))(info.clientData, interp,
objc, (CONST84 char **)argv);
#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
/* Tcl_Free((char*)argv); */
ckfree((char*)argv);
#endif
#endif
}
DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth);
rbtk_eventloop_depth--;
DUMP1("end of ip_rbNamespaceObjCmd");
return ret;
}
#endif
static void
ip_wrap_namespace_command(interp)
Tcl_Interp *interp;
{
#if TCL_MAJOR_VERSION >= 8
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6
Tcl_CmdInfo orig_info;
if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) {
return;
}
if (orig_info.isNativeObjectProc) {
Tcl_CreateObjCommand(interp, ORIG_NAMESPACE_CMD,
orig_info.objProc, orig_info.objClientData,
orig_info.deleteProc);
} else {
Tcl_CreateCommand(interp, ORIG_NAMESPACE_CMD,
orig_info.proc, orig_info.clientData,
orig_info.deleteProc);
}
#else /* tcl8.6 or later */
Tcl_Eval(interp, "rename namespace "ORIG_NAMESPACE_CMD);
#endif
Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *)NULL);
#endif
}
/* call when interpreter is deleted */
static void
#ifdef HAVE_PROTOTYPES
ip_CallWhenDeleted(ClientData clientData, Tcl_Interp *ip)
#else
ip_CallWhenDeleted(clientData, ip)
ClientData clientData;
Tcl_Interp *ip;
#endif
{
int thr_crit_bup;
/* Tk_Window main_win = (Tk_Window) clientData; */
DUMP1("start ip_CallWhenDeleted");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
ip_finalize(ip);
DUMP1("finish ip_CallWhenDeleted");
rb_thread_critical = thr_crit_bup;
}
/*--------------------------------------------------------*/
/* initialize interpreter */
static VALUE
ip_init(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
struct tcltkip *ptr; /* tcltkip data struct */
VALUE argv0, opts;
int cnt;
int st;
int with_tk = 1;
Tk_Window mainWin = (Tk_Window)NULL;
/* create object */
TypedData_Get_Struct(self, struct tcltkip, &tcltkip_type, ptr);
if (DATA_PTR(self)) {
rb_raise(rb_eArgError, "already initialized interpreter");
}
ptr = ALLOC(struct tcltkip);
/* ptr = RbTk_ALLOC_N(struct tcltkip, 1); */
DATA_PTR(self) = ptr;
#ifdef RUBY_USE_NATIVE_THREAD
ptr->tk_thread_id = 0;
#endif
ptr->ref_count = 0;
ptr->allow_ruby_exit = 1;
ptr->return_value = 0;
/* from Tk_Main() */
DUMP1("Tcl_CreateInterp");
ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st);
if (ptr->ip == NULL) {
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");
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_create_ip_and_stubs_init", st);
}
}
#if TCL_MAJOR_VERSION >= 8
#if TCL_NAMESPACE_DEBUG
DUMP1("get current namespace");
if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip))
== (Tcl_Namespace*)NULL) {
rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace");
}
#endif
#endif
rbtk_preserve_ip(ptr);
DUMP2("IP ref_count = %d", ptr->ref_count);
current_interp = ptr->ip;
ptr->has_orig_exit
= Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info));
#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
call_tclkit_init_script(current_interp);
# if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
{
Tcl_DString encodingName;
Tcl_GetEncodingNameFromEnvironment(&encodingName);
if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
/* fails, so we set a variable and do it in the boot.tcl script */
Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
}
Tcl_SetVar(current_interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0);
Tcl_DStringFree(&encodingName);
}
# endif
#endif
/* set variables */
Tcl_Eval(ptr->ip, "set argc 0; set argv {}; set argv0 tcltklib.so");
cnt = rb_scan_args(argc, argv, "02", &argv0, &opts);
switch(cnt) {
case 2:
/* options */
if (NIL_P(opts) || opts == Qfalse) {
/* without Tk */
with_tk = 0;
} else {
/* Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); */
Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY);
Tcl_Eval(ptr->ip, "set argc [llength $argv]");
}
case 1:
/* argv0 */
if (!NIL_P(argv0)) {
if (strncmp(StringValuePtr(argv0), "-e", 3) == 0
|| strncmp(StringValuePtr(argv0), "-", 2) == 0) {
Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY);
} else {
/* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */
Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0),
TCL_GLOBAL_ONLY);
}
}
case 0:
/* no args */
;
}
/* from Tcl_AppInit() */
DUMP1("Tcl_Init");
#if (defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT) && (!defined KIT_LITE) && (10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION == 85)
/*************************************************************************/
/* FIX ME (2010/06/28) */
/* Don't use ::chan command for Mk4tcl + tclvfs-1.4 on Tcl8.5. */
/* It fails to access VFS files because of vfs::zstream. */
/* So, force to use ::rechan by temporarily hiding ::chan. */
/*************************************************************************/
Tcl_Eval(ptr->ip, "catch {rename ::chan ::_tmp_chan}");
if (Tcl_Init(ptr->ip) == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
}
Tcl_Eval(ptr->ip, "catch {rename ::_tmp_chan ::chan}");
#else
if (Tcl_Init(ptr->ip) == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
}
#endif
st = ruby_tcl_stubs_init();
/* from Tcl_AppInit() */
if (with_tk) {
DUMP1("Tk_Init");
st = ruby_tk_stubs_init(ptr->ip);
switch(st) {
case TCLTK_STUBS_OK:
break;
case NO_Tk_Init:
rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()");
case FAIL_Tk_Init:
rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s",
Tcl_GetStringResult(ptr->ip));
case FAIL_Tk_InitStubs:
rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s",
Tcl_GetStringResult(ptr->ip));
default:
rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
}
DUMP1("Tcl_StaticPackage(\"Tk\")");
#if TCL_MAJOR_VERSION >= 8
Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
#else /* TCL_MAJOR_VERSION < 8 */
Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
(Tcl_PackageInitProc *) NULL);
#endif
#ifdef RUBY_USE_NATIVE_THREAD
/* set Tk thread ID */
ptr->tk_thread_id = Tcl_GetCurrentThread();
#endif
/* get main window */
mainWin = Tk_MainWindow(ptr->ip);
Tk_Preserve((ClientData)mainWin);
}
/* add ruby command to the interpreter */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"ruby\")");
Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")");
Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")");
Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"ruby\")");
Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateCommand(\"ruby_eval\")");
Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateCommand(\"ruby_cmd\")");
Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
#endif
/* add 'interp_exit', 'ruby_exit' and replace 'exit' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"interp_exit\")");
Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")");
Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"interp_exit\")");
Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateCommand(\"ruby_exit\")");
Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* replace vwait and tkwait */
ip_replace_wait_commands(ptr->ip, mainWin);
/* wrap namespace command */
ip_wrap_namespace_command(ptr->ip);
/* define command to replace commands which depend on slave's MainWindow */
#if TCL_MAJOR_VERSION >= 8
Tcl_CreateObjCommand(ptr->ip, "__replace_slave_tk_commands__",
ip_rb_replaceSlaveTkCmdsObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
Tcl_CreateCommand(ptr->ip, "__replace_slave_tk_commands__",
ip_rb_replaceSlaveTkCmdsCommand,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#endif
/* set finalizer */
Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin);
if (mainWin != (Tk_Window)NULL) {
Tk_Release((ClientData)mainWin);
}
return self;
}
static VALUE
ip_create_slave_core(interp, argc, argv)
VALUE interp;
int argc;
VALUE *argv;
{
struct tcltkip *master = get_ip(interp);
struct tcltkip *slave;
/* struct tcltkip *slave = RbTk_ALLOC_N(struct tcltkip, 1); */
VALUE safemode;
VALUE name;
VALUE new_ip;
int safe;
int thr_crit_bup;
Tk_Window mainWin;
/* ip is deleted? */
if (deleted_ip(master)) {
return rb_exc_new2(rb_eRuntimeError,
"deleted master cannot create a new slave");
}
name = argv[0];
safemode = argv[1];
if (Tcl_IsSafe(master->ip) == 1) {
safe = 1;
} else if (safemode == Qfalse || NIL_P(safemode)) {
safe = 0;
} else {
safe = 1;
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if 0
/* init Tk */
if (RTEST(with_tk)) {
volatile VALUE exc;
if (!tk_stubs_init_p()) {
exc = tcltkip_init_tk(interp);
if (!NIL_P(exc)) {
rb_thread_critical = thr_crit_bup;
return exc;
}
}
}
#endif
new_ip = TypedData_Make_Struct(CLASS_OF(interp), struct tcltkip,
&tcltkip_type, slave);
/* create slave-ip */
#ifdef RUBY_USE_NATIVE_THREAD
/* slave->tk_thread_id = 0; */
slave->tk_thread_id = master->tk_thread_id; /* == current thread */
#endif
slave->ref_count = 0;
slave->allow_ruby_exit = 0;
slave->return_value = 0;
slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
if (slave->ip == NULL) {
rb_thread_critical = thr_crit_bup;
return rb_exc_new2(rb_eRuntimeError,
"fail to create the new slave interpreter");
}
#if TCL_MAJOR_VERSION >= 8
#if TCL_NAMESPACE_DEBUG
slave->default_ns = Tcl_GetCurrentNamespace(slave->ip);
#endif
#endif
rbtk_preserve_ip(slave);
slave->has_orig_exit
= Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info));
/* replace 'exit' command --> 'interp_exit' command */
mainWin = (tk_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL;
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* replace vwait and tkwait */
ip_replace_wait_commands(slave->ip, mainWin);
/* wrap namespace command */
ip_wrap_namespace_command(slave->ip);
/* define command to replace cmds which depend on slave-slave's MainWin */
#if TCL_MAJOR_VERSION >= 8
Tcl_CreateObjCommand(slave->ip, "__replace_slave_tk_commands__",
ip_rb_replaceSlaveTkCmdsObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
Tcl_CreateCommand(slave->ip, "__replace_slave_tk_commands__",
ip_rb_replaceSlaveTkCmdsCommand,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#endif
/* set finalizer */
Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin);
rb_thread_critical = thr_crit_bup;
return new_ip;
}
static VALUE
ip_create_slave(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
struct tcltkip *master = get_ip(self);
VALUE safemode;
VALUE name;
VALUE callargv[2];
/* ip is deleted? */
if (deleted_ip(master)) {
rb_raise(rb_eRuntimeError,
"deleted master cannot create a new slave interpreter");
}
/* argument check */
if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
safemode = Qfalse;
}
if (Tcl_IsSafe(master->ip) != 1
&& (safemode == Qfalse || NIL_P(safemode))) {
}
StringValue(name);
callargv[0] = name;
callargv[1] = safemode;
return tk_funcall(ip_create_slave_core, 2, callargv, self);
}
/* self is slave of master? */
static VALUE
ip_is_slave_of_p(self, master)
VALUE self, master;
{
if (!rb_obj_is_kind_of(master, tcltkip_class)) {
rb_raise(rb_eArgError, "expected TclTkIp object");
}
if (Tcl_GetMaster(get_ip(self)->ip) == get_ip(master)->ip) {
return Qtrue;
} else {
return Qfalse;
}
}
/* create console (if supported) */
#if defined(MAC_TCL) || defined(__WIN32__)
#if TCL_MAJOR_VERSION < 8 \
|| (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \
|| (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
&& (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \
|| (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
&& TCL_RELEASE_SERIAL < 2) ) )
EXTERN void TkConsoleCreate _((void));
#endif
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
&& ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
&& TCL_RELEASE_SERIAL == 0) \
|| (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
&& TCL_RELEASE_SERIAL >= 2) )
EXTERN void TkConsoleCreate_ _((void));
#endif
#endif
static VALUE
ip_create_console_core(interp, argc, argv)
VALUE interp;
int argc; /* dummy */
VALUE *argv; /* dummy */
{
struct tcltkip *ptr = get_ip(interp);
if (!tk_stubs_init_p()) {
tcltkip_init_tk(interp);
}
if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) {
Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
}
#if TCL_MAJOR_VERSION > 8 \
|| (TCL_MAJOR_VERSION == 8 \
&& (TCL_MINOR_VERSION > 1 \
|| (TCL_MINOR_VERSION == 1 \
&& TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
&& TCL_RELEASE_SERIAL >= 1) ) )
Tk_InitConsoleChannels(ptr->ip);
if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) {
rb_raise(rb_eRuntimeError, "fail to create console-window");
}
#else
#if defined(MAC_TCL) || defined(__WIN32__)
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
&& ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \
|| (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) )
TkConsoleCreate_();
#else
TkConsoleCreate();
#endif
if (TkConsoleInit(ptr->ip) != TCL_OK) {
rb_raise(rb_eRuntimeError, "fail to create console-window");
}
#else
rb_notimplement();
#endif
#endif
return interp;
}
static VALUE
ip_create_console(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self);
}
/* make ip "safe" */
static VALUE
ip_make_safe_core(interp, argc, argv)
VALUE interp;
int argc; /* dummy */
VALUE *argv; /* dummy */
{
struct tcltkip *ptr = get_ip(interp);
Tk_Window mainWin;
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
}
if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
/* return rb_exc_new2(rb_eRuntimeError,
Tcl_GetStringResult(ptr->ip)); */
return create_ip_exc(interp, rb_eRuntimeError, "%s",
Tcl_GetStringResult(ptr->ip));
}
ptr->allow_ruby_exit = 0;
/* replace 'exit' command --> 'interp_exit' command */
mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
return interp;
}
static VALUE
ip_make_safe(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self);
}
/* is safe? */
static VALUE
ip_is_safe_p(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
if (Tcl_IsSafe(ptr->ip)) {
return Qtrue;
} else {
return Qfalse;
}
}
/* allow_ruby_exit? */
static VALUE
ip_allow_ruby_exit_p(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
if (ptr->allow_ruby_exit) {
return Qtrue;
} else {
return Qfalse;
}
}
/* allow_ruby_exit = mode */
static VALUE
ip_allow_ruby_exit_set(self, val)
VALUE self, val;
{
struct tcltkip *ptr = get_ip(self);
Tk_Window mainWin;
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
if (Tcl_IsSafe(ptr->ip)) {
rb_raise(rb_eSecurityError,
"insecure operation on a safe interpreter");
}
/*
* Because of cross-threading, the following line may fail to find
* the MainWindow, even if the Tcl/Tk interpreter has one or more.
* But it has no problem. Current implementation of both type of
* the "exit" command don't need maiinWin token.
*/
mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
if (RTEST(val)) {
ptr->allow_ruby_exit = 1;
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
return Qtrue;
} else {
ptr->allow_ruby_exit = 0;
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
(ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
return Qfalse;
}
}
/* delete interpreter */
static VALUE
ip_delete(self)
VALUE self;
{
int thr_crit_bup;
struct tcltkip *ptr = get_ip(self);
/* if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL) { */
if (deleted_ip(ptr)) {
DUMP1("delete deleted IP");
return Qnil;
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
DUMP1("delete interp");
if (!Tcl_InterpDeleted(ptr->ip)) {
DUMP1("call ip_finalize");
ip_finalize(ptr->ip);
Tcl_DeleteInterp(ptr->ip);
Tcl_Release(ptr->ip);
}
rb_thread_critical = thr_crit_bup;
return Qnil;
}
/* is deleted? */
static VALUE
ip_has_invalid_namespace_p(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) {
/* deleted IP */
return Qtrue;
}
#if TCL_NAMESPACE_DEBUG
if (rbtk_invalid_namespace(ptr)) {
return Qtrue;
} else {
return Qfalse;
}
#else
return Qfalse;
#endif
}
static VALUE
ip_is_deleted_p(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
if (deleted_ip(ptr)) {
return Qtrue;
} else {
return Qfalse;
}
}
static VALUE
ip_has_mainwindow_p_core(self, argc, argv)
VALUE self;
int argc; /* dummy */
VALUE *argv; /* dummy */
{
struct tcltkip *ptr = get_ip(self);
if (deleted_ip(ptr) || !tk_stubs_init_p()) {
return Qnil;
} else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) {
return Qfalse;
} else {
return Qtrue;
}
}
static VALUE
ip_has_mainwindow_p(self)
VALUE self;
{
return tk_funcall(ip_has_mainwindow_p_core, 0, (VALUE*)NULL, self);
}
/*** ruby string <=> tcl object ***/
#if TCL_MAJOR_VERSION >= 8
static VALUE
get_str_from_obj(obj)
Tcl_Obj *obj;
{
int len, binary = 0;
const char *s;
volatile VALUE str;
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
s = Tcl_GetStringFromObj(obj, &len);
#else
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 3
/* TCL_VERSION 8.1 -- 8.3 */
if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) {
/* possibly binary string */
s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
binary = 1;
} else {
/* possibly text string */
s = Tcl_GetStringFromObj(obj, &len);
}
#else /* TCL_VERSION >= 8.4 */
if (IS_TCL_BYTEARRAY(obj)) {
s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
binary = 1;
} else {
s = Tcl_GetStringFromObj(obj, &len);
}
#endif
#endif
str = s ? rb_str_new(s, len) : rb_str_new2("");
if (binary) {
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
} else {
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
#endif
}
return str;
}
static Tcl_Obj *
get_obj_from_str(str)
VALUE str;
{
const char *s = StringValuePtr(str);
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
return Tcl_NewStringObj((char*)s, RSTRING_LEN(str));
#else /* TCL_VERSION >= 8.1 */
VALUE enc = rb_attr_get(str, ID_at_enc);
if (!NIL_P(enc)) {
StringValue(enc);
if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
/* binary string */
return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
} else {
/* text string */
return Tcl_NewStringObj(s, RSTRING_LENINT(str));
}
#ifdef HAVE_RUBY_ENCODING_H
} else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
/* binary string */
return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
#endif
} else if (memchr(s, 0, RSTRING_LEN(str))) {
/* probably binary string */
return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
} else {
/* probably text string */
return Tcl_NewStringObj(s, RSTRING_LENINT(str));
}
#endif
}
#endif /* ruby string <=> tcl object */
static VALUE
ip_get_result_string_obj(interp)
Tcl_Interp *interp;
{
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj *retObj;
volatile VALUE strval;
retObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(retObj);
strval = get_str_from_obj(retObj);
RbTk_OBJ_UNTRUST(strval);
Tcl_ResetResult(interp);
Tcl_DecrRefCount(retObj);
return strval;
#else
return rb_tainted_str_new2(interp->result);
#endif
}
/* call Tcl/Tk functions on the eventloop thread */
static VALUE
callq_safelevel_handler(arg, callq)
VALUE arg;
VALUE callq;
{
struct call_queue *q;
Data_Get_Struct(callq, struct call_queue, q);
DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
rb_set_safe_level(q->safe_level);
return((q->func)(q->interp, q->argc, q->argv));
}
static int call_queue_handler _((Tcl_Event *, int));
static int
call_queue_handler(evPtr, flags)
Tcl_Event *evPtr;
int flags;
{
struct call_queue *q = (struct call_queue *)evPtr;
volatile VALUE ret;
volatile VALUE q_dat;
volatile VALUE thread = q->thread;
struct tcltkip *ptr;
DUMP2("do_call_queue_handler : evPtr = %p", evPtr);
DUMP2("call_queue_handler thread : %"PRIxVALUE, rb_thread_current());
DUMP2("added by thread : %"PRIxVALUE, thread);
if (*(q->done)) {
DUMP1("processed by another event-loop");
return 0;
} else {
DUMP1("process it on current event-loop");
}
if (RTEST(rb_thread_alive_p(thread))
&& ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
DUMP1("caller is not yet ready to receive the result -> pending");
return 0;
}
/* process it */
*(q->done) = 1;
/* deleted ipterp ? */
ptr = get_ip(q->interp);
if (deleted_ip(ptr)) {
/* deleted IP --> ignore */
return 1;
}
/* incr internal handler mark */
rbtk_internal_eventloop_handler++;
/* check safe-level */
if (rb_safe_level() != q->safe_level) {
/* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
q_dat = Data_Wrap_Struct(0,call_queue_mark,-1,q);
ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat),
ID_call, 0);
rb_gc_force_recycle(q_dat);
q_dat = (VALUE)NULL;
} else {
DUMP2("call function (for caller thread:%"PRIxVALUE")", thread);
DUMP2("call function (current thread:%"PRIxVALUE")", rb_thread_current());
ret = (q->func)(q->interp, q->argc, q->argv);
}
/* set result */
RARRAY_ASET(q->result, 0, ret);
ret = (VALUE)NULL;
/* decr internal handler mark */
rbtk_internal_eventloop_handler--;
/* complete */
*(q->done) = -1;
/* unlink ruby objects */
q->argv = (VALUE*)NULL;
q->interp = (VALUE)NULL;
q->result = (VALUE)NULL;
q->thread = (VALUE)NULL;
/* back to caller */
if (RTEST(rb_thread_alive_p(thread))) {
DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread);
DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current());
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
have_rb_thread_waiting_for_value = 1;
rb_thread_wakeup(thread);
#else
rb_thread_run(thread);
#endif
DUMP1("finish back to caller");
#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
rb_thread_schedule();
#endif
} else {
DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread);
DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current());
}
/* end of handler : remove it */
return 1;
}
static VALUE
tk_funcall(func, argc, argv, obj)
VALUE (*func)();
int argc;
VALUE *argv;
VALUE obj;
{
struct call_queue *callq;
struct tcltkip *ptr;
int *alloc_done;
int thr_crit_bup;
int is_tk_evloop_thread;
volatile VALUE current = rb_thread_current();
volatile VALUE ip_obj = obj;
volatile VALUE result;
volatile VALUE ret;
struct timeval t;
if (!NIL_P(ip_obj) && rb_obj_is_kind_of(ip_obj, tcltkip_class)) {
ptr = get_ip(ip_obj);
if (deleted_ip(ptr)) return Qnil;
} else {
ptr = (struct tcltkip *)NULL;
}
#ifdef RUBY_USE_NATIVE_THREAD
if (ptr) {
/* on Tcl interpreter */
is_tk_evloop_thread = (ptr->tk_thread_id == (Tcl_ThreadId) 0
|| ptr->tk_thread_id == Tcl_GetCurrentThread());
} else {
/* on Tcl/Tk library */
is_tk_evloop_thread = (tk_eventloop_thread_id == (Tcl_ThreadId) 0
|| tk_eventloop_thread_id == Tcl_GetCurrentThread());
}
#else
is_tk_evloop_thread = 1;
#endif
if (is_tk_evloop_thread
&& (NIL_P(eventloop_thread) || current == eventloop_thread)
) {
if (NIL_P(eventloop_thread)) {
DUMP2("tk_funcall from thread:%"PRIxVALUE" but no eventloop", current);
} else {
DUMP2("tk_funcall from current eventloop %"PRIxVALUE, current);
}
result = (func)(ip_obj, argc, argv);
if (rb_obj_is_kind_of(result, rb_eException)) {
rb_exc_raise(result);
}
return result;
}
DUMP2("tk_funcall from thread %"PRIxVALUE" (NOT current eventloop)", current);
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* allocate memory (argv cross over thread : must be in heap) */
if (argv) {
/* VALUE *temp = ALLOC_N(VALUE, argc); */
VALUE *temp = RbTk_ALLOC_N(VALUE, argc);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)temp); /* XXXXXXXX */
#endif
MEMCPY(temp, argv, VALUE, argc);
argv = temp;
}
/* allocate memory (keep result) */
/* alloc_done = (int*)ALLOC(int); */
alloc_done = RbTk_ALLOC_N(int, 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
#endif
*alloc_done = 0;
/* allocate memory (freed by Tcl_ServiceEvent) */
/* callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */
callq = RbTk_ALLOC_N(struct call_queue, 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve(callq);
#endif
/* allocate result obj */
result = rb_ary_new3(1, Qnil);
/* construct event data */
callq->done = alloc_done;
callq->func = func;
callq->argc = argc;
callq->argv = argv;
callq->interp = ip_obj;
callq->result = result;
callq->thread = current;
callq->safe_level = rb_safe_level();
callq->ev.proc = call_queue_handler;
/* add the handler to Tcl event queue */
DUMP1("add handler");
#ifdef RUBY_USE_NATIVE_THREAD
if (ptr && ptr->tk_thread_id) {
/* Tcl_ThreadQueueEvent(ptr->tk_thread_id,
&(callq->ev), TCL_QUEUE_HEAD); */
Tcl_ThreadQueueEvent(ptr->tk_thread_id,
(Tcl_Event*)callq, TCL_QUEUE_HEAD);
Tcl_ThreadAlert(ptr->tk_thread_id);
} else if (tk_eventloop_thread_id) {
/* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
&(callq->ev), TCL_QUEUE_HEAD); */
Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
(Tcl_Event*)callq, TCL_QUEUE_HEAD);
Tcl_ThreadAlert(tk_eventloop_thread_id);
} else {
/* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */
Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
}
#else
/* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */
Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
#endif
rb_thread_critical = thr_crit_bup;
/* wait for the handler to be processed */
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
DUMP2("callq wait for handler (current thread:%"PRIxVALUE")", current);
while(*alloc_done >= 0) {
DUMP2("*** callq wait for handler (current thread:%"PRIxVALUE")", current);
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
DUMP2("*** callq wakeup (current thread:%"PRIxVALUE")", current);
DUMP2("*** (eventloop thread:%"PRIxVALUE")", eventloop_thread);
if (NIL_P(eventloop_thread)) {
DUMP1("*** callq lost eventloop thread");
break;
}
}
DUMP2("back from handler (current thread:%"PRIxVALUE")", current);
/* get result & free allocated memory */
ret = RARRAY_AREF(result, 0);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
#else
/* free(alloc_done); */
ckfree((char*)alloc_done);
#endif
#endif
/* if (argv) free(argv); */
if (argv) {
/* if argv != NULL, alloc as 'temp' */
int i;
for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; }
#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
ckfree((char*)argv);
#endif
#endif
}
#if 0 /* callq is freed by Tcl_ServiceEvent */
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release(callq);
#else
ckfree((char*)callq);
#endif
#endif
/* exception? */
if (rb_obj_is_kind_of(ret, rb_eException)) {
DUMP1("raise exception");
/* rb_exc_raise(ret); */
rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
rb_funcallv(ret, ID_to_s, 0, 0)));
}
DUMP1("exit tk_funcall");
return ret;
}
/* eval string in tcl by Tcl_Eval() */
#if TCL_MAJOR_VERSION >= 8
struct call_eval_info {
struct tcltkip *ptr;
Tcl_Obj *cmd;
};
static VALUE
#ifdef HAVE_PROTOTYPES
call_tcl_eval(VALUE arg)
#else
call_tcl_eval(arg)
VALUE arg;
#endif
{
struct call_eval_info *inf = (struct call_eval_info *)arg;
Tcl_AllowExceptions(inf->ptr->ip);
inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd);
return Qnil;
}
#endif
static VALUE
ip_eval_real(self, cmd_str, cmd_len)
VALUE self;
char *cmd_str;
int cmd_len;
{
volatile VALUE ret;
struct tcltkip *ptr = get_ip(self);
int thr_crit_bup;
#if TCL_MAJOR_VERSION >= 8
/* call Tcl_EvalObj() */
{
Tcl_Obj *cmd;
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
cmd = Tcl_NewStringObj(cmd_str, cmd_len);
Tcl_IncrRefCount(cmd);
/* ip is deleted? */
if (deleted_ip(ptr)) {
Tcl_DecrRefCount(cmd);
rb_thread_critical = thr_crit_bup;
ptr->return_value = TCL_OK;
return rb_tainted_str_new2("");
} else {
int status;
struct call_eval_info inf;
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
#if 0
ptr->return_value = Tcl_EvalObj(ptr->ip, cmd);
/* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */
#else
inf.ptr = ptr;
inf.cmd = cmd;
ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status);
switch(status) {
case TAG_RAISE:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception = rb_exc_new2(rb_eException,
"unknown exception");
} else {
rbtk_pending_exception = rb_errinfo();
}
break;
case TAG_FATAL:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
} else {
rbtk_pending_exception = rb_errinfo();
}
}
#endif
}
Tcl_DecrRefCount(cmd);
}
if (pending_exception_check1(thr_crit_bup, ptr)) {
rbtk_release_ip(ptr);
return rbtk_pending_exception;
}
/* if (ptr->return_value == TCL_ERROR) { */
if (ptr->return_value != TCL_OK) {
if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
volatile VALUE exc;
switch (ptr->return_value) {
case TCL_RETURN:
exc = create_ip_exc(self, eTkCallbackReturn,
"ip_eval_real receives TCL_RETURN");
case TCL_BREAK:
exc = create_ip_exc(self, eTkCallbackBreak,
"ip_eval_real receives TCL_BREAK");
case TCL_CONTINUE:
exc = create_ip_exc(self, eTkCallbackContinue,
"ip_eval_real receives TCL_CONTINUE");
default:
exc = create_ip_exc(self, rb_eRuntimeError, "%s",
Tcl_GetStringResult(ptr->ip));
}
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return exc;
} else {
if (event_loop_abort_on_exc < 0) {
rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
} else {
rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
}
Tcl_ResetResult(ptr->ip);
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return rb_tainted_str_new2("");
}
}
/* pass back the result (as string) */
ret = ip_get_result_string_obj(ptr->ip);
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return ret;
#else /* TCL_MAJOR_VERSION < 8 */
DUMP2("Tcl_Eval(%s)", cmd_str);
/* ip is deleted? */
if (deleted_ip(ptr)) {
ptr->return_value = TCL_OK;
return rb_tainted_str_new2("");
} else {
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
ptr->return_value = Tcl_Eval(ptr->ip, cmd_str);
/* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */
}
if (pending_exception_check1(thr_crit_bup, ptr)) {
rbtk_release_ip(ptr);
return rbtk_pending_exception;
}
/* if (ptr->return_value == TCL_ERROR) { */
if (ptr->return_value != TCL_OK) {
volatile VALUE exc;
switch (ptr->return_value) {
case TCL_RETURN:
exc = create_ip_exc(self, eTkCallbackReturn,
"ip_eval_real receives TCL_RETURN");
case TCL_BREAK:
exc = create_ip_exc(self, eTkCallbackBreak,
"ip_eval_real receives TCL_BREAK");
case TCL_CONTINUE:
exc = create_ip_exc(self, eTkCallbackContinue,
"ip_eval_real receives TCL_CONTINUE");
default:
exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
}
rbtk_release_ip(ptr);
return exc;
}
DUMP2("(TCL_Eval result) %d", ptr->return_value);
/* pass back the result (as string) */
ret = ip_get_result_string_obj(ptr->ip);
rbtk_release_ip(ptr);
return ret;
#endif
}
static VALUE
evq_safelevel_handler(arg, evq)
VALUE arg;
VALUE evq;
{
struct eval_queue *q;
Data_Get_Struct(evq, struct eval_queue, q);
DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
rb_set_safe_level(q->safe_level);
return ip_eval_real(q->interp, q->str, q->len);
}
int eval_queue_handler _((Tcl_Event *, int));
int
eval_queue_handler(evPtr, flags)
Tcl_Event *evPtr;
int flags;
{
struct eval_queue *q = (struct eval_queue *)evPtr;
volatile VALUE ret;
volatile VALUE q_dat;
volatile VALUE thread = q->thread;
struct tcltkip *ptr;
DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
DUMP2("eval_queue_thread : %"PRIxVALUE, rb_thread_current());
DUMP2("added by thread : %"PRIxVALUE, thread);
if (*(q->done)) {
DUMP1("processed by another event-loop");
return 0;
} else {
DUMP1("process it on current event-loop");
}
if (RTEST(rb_thread_alive_p(thread))
&& ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
DUMP1("caller is not yet ready to receive the result -> pending");
return 0;
}
/* process it */
*(q->done) = 1;
/* deleted ipterp ? */
ptr = get_ip(q->interp);
if (deleted_ip(ptr)) {
/* deleted IP --> ignore */
return 1;
}
/* incr internal handler mark */
rbtk_internal_eventloop_handler++;
/* check safe-level */
if (rb_safe_level() != q->safe_level) {
#ifdef HAVE_NATIVETHREAD
#ifndef RUBY_USE_NATIVE_THREAD
if (!ruby_native_thread_p()) {
rb_bug("cross-thread violation on eval_queue_handler()");
}
#endif
#endif
/* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
q_dat = Data_Wrap_Struct(0,eval_queue_mark,-1,q);
ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
ID_call, 0);
rb_gc_force_recycle(q_dat);
q_dat = (VALUE)NULL;
} else {
ret = ip_eval_real(q->interp, q->str, q->len);
}
/* set result */
RARRAY_ASET(q->result, 0, ret);
ret = (VALUE)NULL;
/* decr internal handler mark */
rbtk_internal_eventloop_handler--;
/* complete */
*(q->done) = -1;
/* unlink ruby objects */
q->interp = (VALUE)NULL;
q->result = (VALUE)NULL;
q->thread = (VALUE)NULL;
/* back to caller */
if (RTEST(rb_thread_alive_p(thread))) {
DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread);
DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current());
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
have_rb_thread_waiting_for_value = 1;
rb_thread_wakeup(thread);
#else
rb_thread_run(thread);
#endif
DUMP1("finish back to caller");
#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
rb_thread_schedule();
#endif
} else {
DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread);
DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current());
}
/* end of handler : remove it */
return 1;
}
static VALUE
ip_eval(self, str)
VALUE self;
VALUE str;
{
struct eval_queue *evq;
#ifdef RUBY_USE_NATIVE_THREAD
struct tcltkip *ptr;
#endif
char *eval_str;
int *alloc_done;
int thr_crit_bup;
volatile VALUE current = rb_thread_current();
volatile VALUE ip_obj = self;
volatile VALUE result;
volatile VALUE ret;
Tcl_QueuePosition position;
struct timeval t;
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
StringValue(str);
rb_thread_critical = thr_crit_bup;
#ifdef RUBY_USE_NATIVE_THREAD
ptr = get_ip(ip_obj);
DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id);
DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#else
DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#endif
DUMP2("status: eventloopt_thread %"PRIxVALUE, eventloop_thread);
if (
#ifdef RUBY_USE_NATIVE_THREAD
(ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
&&
#endif
(NIL_P(eventloop_thread) || current == eventloop_thread)
) {
if (NIL_P(eventloop_thread)) {
DUMP2("eval from thread:%"PRIxVALUE" but no eventloop", current);
} else {
DUMP2("eval from current eventloop %"PRIxVALUE, current);
}
result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str));
if (rb_obj_is_kind_of(result, rb_eException)) {
rb_exc_raise(result);
}
return result;
}
DUMP2("eval from thread %"PRIxVALUE" (NOT current eventloop)", current);
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* allocate memory (keep result) */
/* alloc_done = (int*)ALLOC(int); */
alloc_done = RbTk_ALLOC_N(int, 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
#endif
*alloc_done = 0;
/* eval_str = ALLOC_N(char, RSTRING_LEN(str) + 1); */
eval_str = ckalloc(RSTRING_LENINT(str) + 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)eval_str); /* XXXXXXXX */
#endif
memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str));
eval_str[RSTRING_LEN(str)] = 0;
/* allocate memory (freed by Tcl_ServiceEvent) */
/* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */
evq = RbTk_ALLOC_N(struct eval_queue, 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve(evq);
#endif
/* allocate result obj */
result = rb_ary_new3(1, Qnil);
/* construct event data */
evq->done = alloc_done;
evq->str = eval_str;
evq->len = RSTRING_LENINT(str);
evq->interp = ip_obj;
evq->result = result;
evq->thread = current;
evq->safe_level = rb_safe_level();
evq->ev.proc = eval_queue_handler;
position = TCL_QUEUE_TAIL;
/* add the handler to Tcl event queue */
DUMP1("add handler");
#ifdef RUBY_USE_NATIVE_THREAD
if (ptr->tk_thread_id) {
/* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */
Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position);
Tcl_ThreadAlert(ptr->tk_thread_id);
} else if (tk_eventloop_thread_id) {
Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position);
/* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
&(evq->ev), position); */
Tcl_ThreadAlert(tk_eventloop_thread_id);
} else {
/* Tcl_QueueEvent(&(evq->ev), position); */
Tcl_QueueEvent((Tcl_Event*)evq, position);
}
#else
/* Tcl_QueueEvent(&(evq->ev), position); */
Tcl_QueueEvent((Tcl_Event*)evq, position);
#endif
rb_thread_critical = thr_crit_bup;
/* wait for the handler to be processed */
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
DUMP2("evq wait for handler (current thread:%"PRIxVALUE")", current);
while(*alloc_done >= 0) {
DUMP2("*** evq wait for handler (current thread:%"PRIxVALUE")", current);
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
DUMP2("*** evq wakeup (current thread:%"PRIxVALUE")", current);
DUMP2("*** (eventloop thread:%"PRIxVALUE")", eventloop_thread);
if (NIL_P(eventloop_thread)) {
DUMP1("*** evq lost eventloop thread");
break;
}
}
DUMP2("back from handler (current thread:%"PRIxVALUE")", current);
/* get result & free allocated memory */
ret = RARRAY_AREF(result, 0);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
#else
/* free(alloc_done); */
ckfree((char*)alloc_done);
#endif
#endif
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)eval_str); /* XXXXXXXX */
#else
/* free(eval_str); */
ckfree(eval_str);
#endif
#endif
#if 0 /* evq is freed by Tcl_ServiceEvent */
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release(evq);
#else
ckfree((char*)evq);
#endif
#endif
if (rb_obj_is_kind_of(ret, rb_eException)) {
DUMP1("raise exception");
/* rb_exc_raise(ret); */
rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
rb_funcallv(ret, ID_to_s, 0, 0)));
}
return ret;
}
static int
ip_cancel_eval_core(interp, msg, flag)
Tcl_Interp *interp;
VALUE msg;
int flag;
{
#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6)
rb_raise(rb_eNotImpError,
"cancel_eval is supported Tcl/Tk8.6 or later.");
UNREACHABLE;
#else
Tcl_Obj *msg_obj;
if (NIL_P(msg)) {
msg_obj = NULL;
} else {
char *s = StringValuePtr(msg);
msg_obj = Tcl_NewStringObj(s, RSTRING_LENINT(msg));
Tcl_IncrRefCount(msg_obj);
}
return Tcl_CancelEval(interp, msg_obj, 0, flag);
#endif
}
static VALUE
ip_cancel_eval(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE retval;
if (rb_scan_args(argc, argv, "01", &retval) == 0) {
retval = Qnil;
}
if (ip_cancel_eval_core(get_ip(self)->ip, retval, 0) == TCL_OK) {
return Qtrue;
} else {
return Qfalse;
}
}
#ifndef TCL_CANCEL_UNWIND
#define TCL_CANCEL_UNWIND 0x100000
#endif
static VALUE
ip_cancel_eval_unwind(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
int flag = 0;
VALUE retval;
if (rb_scan_args(argc, argv, "01", &retval) == 0) {
retval = Qnil;
}
flag |= TCL_CANCEL_UNWIND;
if (ip_cancel_eval_core(get_ip(self)->ip, retval, flag) == TCL_OK) {
return Qtrue;
} else {
return Qfalse;
}
}
/* restart Tk */
static VALUE
lib_restart_core(interp, argc, argv)
VALUE interp;
int argc; /* dummy */
VALUE *argv; /* dummy */
{
volatile VALUE exc;
struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
/* tcl_stubs_check(); */ /* already checked */
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
/* destroy the root wdiget */
ptr->return_value = Tcl_Eval(ptr->ip, "destroy .");
/* ignore ERROR */
DUMP2("(TCL_Eval result) %d", ptr->return_value);
Tcl_ResetResult(ptr->ip);
#if TCL_MAJOR_VERSION >= 8
/* delete namespace ( tested on tk8.4.5 ) */
ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
/* ignore ERROR */
DUMP2("(TCL_Eval result) %d", ptr->return_value);
Tcl_ResetResult(ptr->ip);
#endif
/* delete trace proc ( tested on tk8.4.5 ) */
ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
/* ignore ERROR */
DUMP2("(TCL_Eval result) %d", ptr->return_value);
Tcl_ResetResult(ptr->ip);
/* execute Tk_Init or Tk_SafeInit */
exc = tcltkip_init_tk(interp);
if (!NIL_P(exc)) {
rb_thread_critical = thr_crit_bup;
rbtk_release_ip(ptr);
return exc;
}
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
/* return Qnil; */
return interp;
}
static VALUE
lib_restart(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
tcl_stubs_check();
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self);
}
static VALUE
ip_restart(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
tcl_stubs_check();
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_raise(rb_eRuntimeError, "interpreter is deleted");
}
if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
/* slave IP */
return Qnil;
}
return lib_restart(self);
}
static VALUE
lib_toUTF8_core(ip_obj, src, encodename)
VALUE ip_obj;
VALUE src;
VALUE encodename;
{
volatile VALUE str = src;
#ifdef TCL_UTF_MAX
# if 0
Tcl_Interp *interp;
# endif
Tcl_Encoding encoding;
Tcl_DString dstr;
int taint_flag = OBJ_TAINTED(str);
struct tcltkip *ptr;
char *buf;
int thr_crit_bup;
#endif
tcl_stubs_check();
if (NIL_P(src)) {
return rb_str_new2("");
}
#ifdef TCL_UTF_MAX
if (NIL_P(ip_obj)) {
# if 0
interp = (Tcl_Interp *)NULL;
# endif
} else {
ptr = get_ip(ip_obj);
/* ip is deleted? */
if (deleted_ip(ptr)) {
# if 0
interp = (Tcl_Interp *)NULL;
} else {
interp = ptr->ip;
# endif
}
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if (NIL_P(encodename)) {
if (RB_TYPE_P(str, T_STRING)) {
volatile VALUE enc;
#ifdef HAVE_RUBY_ENCODING_H
enc = rb_funcallv(rb_obj_encoding(str), ID_to_s, 0, 0);
#else
enc = rb_attr_get(str, ID_at_enc);
#endif
if (NIL_P(enc)) {
if (NIL_P(ip_obj)) {
encoding = (Tcl_Encoding)NULL;
} else {
enc = rb_attr_get(ip_obj, ID_at_enc);
if (NIL_P(enc)) {
encoding = (Tcl_Encoding)NULL;
} else {
/* StringValue(enc); */
enc = rb_funcallv(enc, ID_to_s, 0, 0);
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
if (!RSTRING_LEN(enc)) {
encoding = (Tcl_Encoding)NULL;
} else {
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
RSTRING_PTR(enc));
if (encoding == (Tcl_Encoding)NULL) {
rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
}
}
}
}
} else {
StringValue(enc);
if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
rb_thread_critical = thr_crit_bup;
return str;
}
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
RSTRING_PTR(enc));
if (encoding == (Tcl_Encoding)NULL) {
rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
}
}
} else {
encoding = (Tcl_Encoding)NULL;
}
} else {
StringValue(encodename);
if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
rb_thread_critical = thr_crit_bup;
return str;
}
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
if (encoding == (Tcl_Encoding)NULL) {
/*
rb_warning("unknown encoding name '%s'",
RSTRING_PTR(encodename));
*/
rb_raise(rb_eArgError, "unknown encoding name '%s'",
RSTRING_PTR(encodename));
}
}
StringValue(str);
if (!RSTRING_LEN(str)) {
rb_thread_critical = thr_crit_bup;
return str;
}
buf = ALLOC_N(char, RSTRING_LEN(str)+1);
/* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */
memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
buf[RSTRING_LEN(str)] = 0;
Tcl_DStringInit(&dstr);
Tcl_DStringFree(&dstr);
/* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */
Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(str), &dstr);
/* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
/* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
#endif
if (taint_flag) RbTk_OBJ_UNTRUST(str);
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
/*
if (encoding != (Tcl_Encoding)NULL) {
Tcl_FreeEncoding(encoding);
}
*/
Tcl_DStringFree(&dstr);
xfree(buf);
/* ckfree(buf); */
rb_thread_critical = thr_crit_bup;
#endif
return str;
}
static VALUE
lib_toUTF8(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE str, encodename;
if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
encodename = Qnil;
}
return lib_toUTF8_core(Qnil, str, encodename);
}
static VALUE
ip_toUTF8(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE str, encodename;
if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
encodename = Qnil;
}
return lib_toUTF8_core(self, str, encodename);
}
static VALUE
lib_fromUTF8_core(ip_obj, src, encodename)
VALUE ip_obj;
VALUE src;
VALUE encodename;
{
volatile VALUE str = src;
#ifdef TCL_UTF_MAX
Tcl_Interp *interp;
Tcl_Encoding encoding;
Tcl_DString dstr;
int taint_flag = OBJ_TAINTED(str);
char *buf;
int thr_crit_bup;
#endif
tcl_stubs_check();
if (NIL_P(src)) {
return rb_str_new2("");
}
#ifdef TCL_UTF_MAX
if (NIL_P(ip_obj)) {
interp = (Tcl_Interp *)NULL;
} else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
interp = (Tcl_Interp *)NULL;
} else {
interp = get_ip(ip_obj)->ip;
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
if (NIL_P(encodename)) {
volatile VALUE enc;
if (RB_TYPE_P(str, T_STRING)) {
enc = rb_attr_get(str, ID_at_enc);
if (!NIL_P(enc)) {
StringValue(enc);
if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
rb_thread_critical = thr_crit_bup;
return str;
}
#ifdef HAVE_RUBY_ENCODING_H
} else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
rb_thread_critical = thr_crit_bup;
return str;
#endif
}
}
if (NIL_P(ip_obj)) {
encoding = (Tcl_Encoding)NULL;
} else {
enc = rb_attr_get(ip_obj, ID_at_enc);
if (NIL_P(enc)) {
encoding = (Tcl_Encoding)NULL;
} else {
/* StringValue(enc); */
enc = rb_funcallv(enc, ID_to_s, 0, 0);
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */
if (!RSTRING_LEN(enc)) {
encoding = (Tcl_Encoding)NULL;
} else {
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
RSTRING_PTR(enc));
if (encoding == (Tcl_Encoding)NULL) {
rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
} else {
encodename = rb_obj_dup(enc);
}
}
}
}
} else {
StringValue(encodename);
if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
Tcl_Obj *tclstr;
char *s;
int len;
StringValue(str);
tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LENINT(str));
Tcl_IncrRefCount(tclstr);
s = (char*)Tcl_GetByteArrayFromObj(tclstr, &len);
str = rb_tainted_str_new(s, len);
s = (char*)NULL;
Tcl_DecrRefCount(tclstr);
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
rb_thread_critical = thr_crit_bup;
return str;
}
/* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */
encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
if (encoding == (Tcl_Encoding)NULL) {
/*
rb_warning("unknown encoding name '%s'",
RSTRING_PTR(encodename));
encodename = Qnil;
*/
rb_raise(rb_eArgError, "unknown encoding name '%s'",
RSTRING_PTR(encodename));
}
}
StringValue(str);
if (RSTRING_LEN(str) == 0) {
rb_thread_critical = thr_crit_bup;
return rb_tainted_str_new2("");
}
buf = ALLOC_N(char, RSTRING_LEN(str)+1);
/* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */
memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
buf[RSTRING_LEN(str)] = 0;
Tcl_DStringInit(&dstr);
Tcl_DStringFree(&dstr);
/* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */
Tcl_UtfToExternalDString(encoding,buf,RSTRING_LENINT(str),&dstr);
/* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
/* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
#ifdef HAVE_RUBY_ENCODING_H
if (interp) {
/* can access encoding_table of TclTkIp */
/* -> try to use encoding_table */
VALUE tbl = ip_get_encoding_table(ip_obj);
VALUE encobj = encoding_table_get_obj(tbl, encodename);
rb_enc_associate_index(str, rb_to_encoding_index(encobj));
} else {
/* cannot access encoding_table of TclTkIp */
/* -> try to find on Ruby Encoding */
rb_enc_associate_index(str, rb_enc_find_index(RSTRING_PTR(encodename)));
}
#endif
if (taint_flag) RbTk_OBJ_UNTRUST(str);
rb_ivar_set(str, ID_at_enc, encodename);
/*
if (encoding != (Tcl_Encoding)NULL) {
Tcl_FreeEncoding(encoding);
}
*/
Tcl_DStringFree(&dstr);
xfree(buf);
/* ckfree(buf); */
rb_thread_critical = thr_crit_bup;
#endif
return str;
}
static VALUE
lib_fromUTF8(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE str, encodename;
if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
encodename = Qnil;
}
return lib_fromUTF8_core(Qnil, str, encodename);
}
static VALUE
ip_fromUTF8(argc, argv, self)
int argc;
VALUE *argv;
VALUE self;
{
VALUE str, encodename;
if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
encodename = Qnil;
}
return lib_fromUTF8_core(self, str, encodename);
}
static VALUE
lib_UTF_backslash_core(self, str, all_bs)
VALUE self;
VALUE str;
int all_bs;
{
#ifdef TCL_UTF_MAX
char *src_buf, *dst_buf, *ptr;
int read_len = 0, dst_len = 0;
int taint_flag = OBJ_TAINTED(str);
int thr_crit_bup;
tcl_stubs_check();
StringValue(str);
if (!RSTRING_LEN(str)) {
return str;
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* src_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */
src_buf = ckalloc(RSTRING_LENINT(str)+1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)src_buf); /* XXXXXXXX */
#endif
memcpy(src_buf, RSTRING_PTR(str), RSTRING_LEN(str));
src_buf[RSTRING_LEN(str)] = 0;
/* dst_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */
dst_buf = ckalloc(RSTRING_LENINT(str)+1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)dst_buf); /* XXXXXXXX */
#endif
ptr = src_buf;
while(RSTRING_LEN(str) > ptr - src_buf) {
if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) {
dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len));
ptr += read_len;
} else {
*(dst_buf + (dst_len++)) = *(ptr++);
}
}
str = rb_str_new(dst_buf, dst_len);
if (taint_flag) RbTk_OBJ_UNTRUST(str);
#ifdef HAVE_RUBY_ENCODING_H
rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
#endif
rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)src_buf, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)src_buf); /* XXXXXXXX */
#else
/* free(src_buf); */
ckfree(src_buf);
#endif
#endif
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)dst_buf); /* XXXXXXXX */
#else
/* free(dst_buf); */
ckfree(dst_buf);
#endif
#endif
rb_thread_critical = thr_crit_bup;
#endif
return str;
}
static VALUE
lib_UTF_backslash(self, str)
VALUE self;
VALUE str;
{
return lib_UTF_backslash_core(self, str, 0);
}
static VALUE
lib_Tcl_backslash(self, str)
VALUE self;
VALUE str;
{
return lib_UTF_backslash_core(self, str, 1);
}
static VALUE
lib_get_system_encoding(self)
VALUE self;
{
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
tcl_stubs_check();
return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
#else
return Qnil;
#endif
}
static VALUE
lib_set_system_encoding(self, enc_name)
VALUE self;
VALUE enc_name;
{
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
tcl_stubs_check();
if (NIL_P(enc_name)) {
Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL);
return lib_get_system_encoding(self);
}
enc_name = rb_funcallv(enc_name, ID_to_s, 0, 0);
if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL,
StringValuePtr(enc_name)) != TCL_OK) {
rb_raise(rb_eArgError, "unknown encoding name '%s'",
RSTRING_PTR(enc_name));
}
return enc_name;
#else
return Qnil;
#endif
}
/* invoke Tcl proc */
struct invoke_info {
struct tcltkip *ptr;
Tcl_CmdInfo cmdinfo;
#if TCL_MAJOR_VERSION >= 8
int objc;
Tcl_Obj **objv;
#else
int argc;
char **argv;
#endif
};
static VALUE
#ifdef HAVE_PROTOTYPES
invoke_tcl_proc(VALUE arg)
#else
invoke_tcl_proc(arg)
VALUE arg;
#endif
{
struct invoke_info *inf = (struct invoke_info *)arg;
#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION < 6
int i, len;
int argc = inf->objc;
char **argv = (char **)NULL;
#endif
DUMP1("call invoke_tcl_proc");
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 6)
/* Tcl/Tk 8.6 or later */
/* eval */
inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, TCL_EVAL_DIRECT);
/* inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, 0); */
#else /* Tcl/Tk 7.x, 8.0 -- 8.5 */
/* memory allocation for arguments of this command */
#if TCL_MAJOR_VERSION == 8
/* Tcl/Tk 8.0 -- 8.5 */
if (!inf->cmdinfo.isNativeObjectProc) {
DUMP1("called proc is not a native-obj-proc");
/* string interface */
/* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */
argv = RbTk_ALLOC_N(char *, (argc+1));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
for (i = 0; i < argc; ++i) {
argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len);
}
argv[argc] = (char *)NULL;
}
#endif
DUMP1("reset result of tcl-interp");
Tcl_ResetResult(inf->ptr->ip);
/* Invoke the C procedure */
#if TCL_MAJOR_VERSION == 8
/* Tcl/Tk 8.0 -- 8.5 */
if (inf->cmdinfo.isNativeObjectProc) {
DUMP1("call tcl_proc as a native-obj-proc");
inf->ptr->return_value
= (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData,
inf->ptr->ip, inf->objc, inf->objv);
}
else
#endif
{
#if TCL_MAJOR_VERSION == 8
/* Tcl/Tk 8.0 -- 8.5 */
DUMP1("call tcl_proc as not a native-obj-proc");
inf->ptr->return_value
= (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
argc, (CONST84 char **)argv);
#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
#else /* TCL_MAJOR_VERSION < 8 */
inf->ptr->return_value
= (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
inf->argc, inf->argv);
#endif
}
#endif /* Tcl/Tk 8.6 or later || Tcl 7.x, 8.0 -- 8.5 */
DUMP1("end of invoke_tcl_proc");
return Qnil;
}
#if TCL_MAJOR_VERSION >= 8
static VALUE
ip_invoke_core(interp, objc, objv)
VALUE interp;
int objc;
Tcl_Obj **objv;
#else
static VALUE
ip_invoke_core(interp, argc, argv)
VALUE interp;
int argc;
char **argv;
#endif
{
struct tcltkip *ptr;
Tcl_CmdInfo info;
char *cmd;
int len;
int thr_crit_bup;
int unknown_flag = 0;
#if 1 /* wrap tcl-proc call */
struct invoke_info inf;
int status;
#else
#if TCL_MAJOR_VERSION >= 8
int argc = objc;
char **argv = (char **)NULL;
/* Tcl_Obj *resultPtr; */
#endif
#endif
/* get the command name string */
#if TCL_MAJOR_VERSION >= 8
cmd = Tcl_GetStringFromObj(objv[0], &len);
#else /* TCL_MAJOR_VERSION < 8 */
cmd = argv[0];
#endif
/* get the data struct */
ptr = get_ip(interp);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_tainted_str_new2("");
}
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
/* map from the command name to a C procedure */
DUMP2("call Tcl_GetCommandInfo, %s", cmd);
if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
DUMP1("error Tcl_GetCommandInfo");
DUMP1("try auto_load (call 'unknown' command)");
if (!Tcl_GetCommandInfo(ptr->ip,
#if TCL_MAJOR_VERSION >= 8
"::unknown",
#else
"unknown",
#endif
&info)) {
DUMP1("fail to get 'unknown' command");
/* if (event_loop_abort_on_exc || cmd[0] != '.') { */
if (event_loop_abort_on_exc > 0) {
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
/*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/
return create_ip_exc(interp, rb_eNameError,
"invalid command name `%s'", cmd);
} else {
if (event_loop_abort_on_exc < 0) {
rb_warning("invalid command name `%s' (ignore)", cmd);
} else {
rb_warn("invalid command name `%s' (ignore)", cmd);
}
Tcl_ResetResult(ptr->ip);
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
return rb_tainted_str_new2("");
}
} else {
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **unknown_objv;
#else
char **unknown_argv;
#endif
DUMP1("find 'unknown' command -> set arguments");
unknown_flag = 1;
#if TCL_MAJOR_VERSION >= 8
/* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */
unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)unknown_objv); /* XXXXXXXX */
#endif
unknown_objv[0] = Tcl_NewStringObj("::unknown", 9);
Tcl_IncrRefCount(unknown_objv[0]);
memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc);
unknown_objv[++objc] = (Tcl_Obj*)NULL;
objv = unknown_objv;
#else
/* unknown_argv = (char **)ALLOC_N(char *, argc+2); */
unknown_argv = RbTk_ALLOC_N(char *, (argc+2));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)unknown_argv); /* XXXXXXXX */
#endif
unknown_argv[0] = strdup("unknown");
memcpy(unknown_argv + 1, argv, sizeof(char *)*argc);
unknown_argv[++argc] = (char *)NULL;
argv = unknown_argv;
#endif
}
}
DUMP1("end Tcl_GetCommandInfo");
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
#if 1 /* wrap tcl-proc call */
/* setup params */
inf.ptr = ptr;
inf.cmdinfo = info;
#if TCL_MAJOR_VERSION >= 8
inf.objc = objc;
inf.objv = objv;
#else
inf.argc = argc;
inf.argv = argv;
#endif
/* invoke tcl-proc */
DUMP1("invoke tcl-proc");
rb_protect(invoke_tcl_proc, (VALUE)&inf, &status);
DUMP2("status of tcl-proc, %d", status);
switch(status) {
case TAG_RAISE:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception = rb_exc_new2(rb_eException,
"unknown exception");
} else {
rbtk_pending_exception = rb_errinfo();
}
break;
case TAG_FATAL:
if (NIL_P(rb_errinfo())) {
rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
} else {
rbtk_pending_exception = rb_errinfo();
}
}
#else /* !wrap tcl-proc call */
/* memory allocation for arguments of this command */
#if TCL_MAJOR_VERSION >= 8
if (!info.isNativeObjectProc) {
int i;
/* string interface */
/* argv = (char **)ALLOC_N(char *, argc+1); */
argv = RbTk_ALLOC_N(char *, (argc+1));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
for (i = 0; i < argc; ++i) {
argv[i] = Tcl_GetStringFromObj(objv[i], &len);
}
argv[argc] = (char *)NULL;
}
#endif
Tcl_ResetResult(ptr->ip);
/* Invoke the C procedure */
#if TCL_MAJOR_VERSION >= 8
if (info.isNativeObjectProc) {
ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip,
objc, objv);
#if 0
/* get the string value from the result object */
resultPtr = Tcl_GetObjResult(ptr->ip);
Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len),
TCL_VOLATILE);
#endif
}
else
#endif
{
#if TCL_MAJOR_VERSION >= 8
ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
argc, (CONST84 char **)argv);
#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
#else /* TCL_MAJOR_VERSION < 8 */
ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
argc, argv);
#endif
}
#endif /* ! wrap tcl-proc call */
/* free allocated memory for calling 'unknown' command */
if (unknown_flag) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(objv[0]);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)objv); /* XXXXXXXX */
#else
/* free(objv); */
ckfree((char*)objv);
#endif
#endif
#else /* TCL_MAJOR_VERSION < 8 */
free(argv[0]);
/* ckfree(argv[0]); */
#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
}
/* exception on mainloop */
if (pending_exception_check1(thr_crit_bup, ptr)) {
return rbtk_pending_exception;
}
rb_thread_critical = thr_crit_bup;
/* if (ptr->return_value == TCL_ERROR) { */
if (ptr->return_value != TCL_OK) {
if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
switch (ptr->return_value) {
case TCL_RETURN:
return create_ip_exc(interp, eTkCallbackReturn,
"ip_invoke_core receives TCL_RETURN");
case TCL_BREAK:
return create_ip_exc(interp, eTkCallbackBreak,
"ip_invoke_core receives TCL_BREAK");
case TCL_CONTINUE:
return create_ip_exc(interp, eTkCallbackContinue,
"ip_invoke_core receives TCL_CONTINUE");
default:
return create_ip_exc(interp, rb_eRuntimeError, "%s",
Tcl_GetStringResult(ptr->ip));
}
} else {
if (event_loop_abort_on_exc < 0) {
rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
} else {
rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
}
Tcl_ResetResult(ptr->ip);
return rb_tainted_str_new2("");
}
}
/* pass back the result (as string) */
return ip_get_result_string_obj(ptr->ip);
}
#if TCL_MAJOR_VERSION >= 8
static Tcl_Obj **
#else /* TCL_MAJOR_VERSION < 8 */
static char **
#endif
alloc_invoke_arguments(argc, argv)
int argc;
VALUE *argv;
{
int i;
int thr_crit_bup;
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **av;
#else /* TCL_MAJOR_VERSION < 8 */
char **av;
#endif
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* memory allocation */
#if TCL_MAJOR_VERSION >= 8
/* av = ALLOC_N(Tcl_Obj *, argc+1);*/ /* XXXXXXXXXX */
av = RbTk_ALLOC_N(Tcl_Obj *, (argc+1));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)av); /* XXXXXXXX */
#endif
for (i = 0; i < argc; ++i) {
av[i] = get_obj_from_str(argv[i]);
Tcl_IncrRefCount(av[i]);
}
av[argc] = NULL;
#else /* TCL_MAJOR_VERSION < 8 */
/* string interface */
/* av = ALLOC_N(char *, argc+1); */
av = RbTk_ALLOC_N(char *, (argc+1));
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)av); /* XXXXXXXX */
#endif
for (i = 0; i < argc; ++i) {
av[i] = strdup(StringValuePtr(argv[i]));
}
av[argc] = NULL;
#endif
rb_thread_critical = thr_crit_bup;
return av;
}
static void
free_invoke_arguments(argc, av)
int argc;
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **av;
#else /* TCL_MAJOR_VERSION < 8 */
char **av;
#endif
{
int i;
for (i = 0; i < argc; ++i) {
#if TCL_MAJOR_VERSION >= 8
Tcl_DecrRefCount(av[i]);
av[i] = (Tcl_Obj*)NULL;
#else /* TCL_MAJOR_VERSION < 8 */
free(av[i]);
av[i] = (char*)NULL;
#endif
}
#if TCL_MAJOR_VERSION >= 8
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)av); /* XXXXXXXX */
#else
ckfree((char*)av);
#endif
#endif
#else /* TCL_MAJOR_VERSION < 8 */
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)av); /* XXXXXXXX */
#else
/* free(av); */
ckfree((char*)av);
#endif
#endif
#endif
}
static VALUE
ip_invoke_real(argc, argv, interp)
int argc;
VALUE *argv;
VALUE interp;
{
VALUE v;
struct tcltkip *ptr; /* tcltkip data struct */
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **av = (Tcl_Obj **)NULL;
#else /* TCL_MAJOR_VERSION < 8 */
char **av = (char **)NULL;
#endif
DUMP2("invoke_real called by thread:%"PRIxVALUE, rb_thread_current());
/* get the data struct */
ptr = get_ip(interp);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_tainted_str_new2("");
}
/* allocate memory for arguments */
av = alloc_invoke_arguments(argc, argv);
/* Invoke the C procedure */
Tcl_ResetResult(ptr->ip);
v = ip_invoke_core(interp, argc, av);
/* free allocated memory */
free_invoke_arguments(argc, av);
return v;
}
VALUE
ivq_safelevel_handler(arg, ivq)
VALUE arg;
VALUE ivq;
{
struct invoke_queue *q;
Data_Get_Struct(ivq, struct invoke_queue, q);
DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
rb_set_safe_level(q->safe_level);
return ip_invoke_core(q->interp, q->argc, q->argv);
}
int invoke_queue_handler _((Tcl_Event *, int));
int
invoke_queue_handler(evPtr, flags)
Tcl_Event *evPtr;
int flags;
{
struct invoke_queue *q = (struct invoke_queue *)evPtr;
volatile VALUE ret;
volatile VALUE q_dat;
volatile VALUE thread = q->thread;
struct tcltkip *ptr;
DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr);
DUMP2("invoke queue_thread : %"PRIxVALUE, rb_thread_current());
DUMP2("added by thread : %"PRIxVALUE, thread);
if (*(q->done)) {
DUMP1("processed by another event-loop");
return 0;
} else {
DUMP1("process it on current event-loop");
}
if (RTEST(rb_thread_alive_p(thread))
&& ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
DUMP1("caller is not yet ready to receive the result -> pending");
return 0;
}
/* process it */
*(q->done) = 1;
/* deleted ipterp ? */
ptr = get_ip(q->interp);
if (deleted_ip(ptr)) {
/* deleted IP --> ignore */
return 1;
}
/* incr internal handler mark */
rbtk_internal_eventloop_handler++;
/* check safe-level */
if (rb_safe_level() != q->safe_level) {
/* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
q_dat = Data_Wrap_Struct(0,invoke_queue_mark,-1,q);
ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat),
ID_call, 0);
rb_gc_force_recycle(q_dat);
q_dat = (VALUE)NULL;
} else {
DUMP2("call invoke_real (for caller thread:%"PRIxVALUE")", thread);
DUMP2("call invoke_real (current thread:%"PRIxVALUE")", rb_thread_current());
ret = ip_invoke_core(q->interp, q->argc, q->argv);
}
/* set result */
RARRAY_ASET(q->result, 0, ret);
ret = (VALUE)NULL;
/* decr internal handler mark */
rbtk_internal_eventloop_handler--;
/* complete */
*(q->done) = -1;
/* unlink ruby objects */
q->interp = (VALUE)NULL;
q->result = (VALUE)NULL;
q->thread = (VALUE)NULL;
/* back to caller */
if (RTEST(rb_thread_alive_p(thread))) {
DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread);
DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current());
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
have_rb_thread_waiting_for_value = 1;
rb_thread_wakeup(thread);
#else
rb_thread_run(thread);
#endif
DUMP1("finish back to caller");
#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
rb_thread_schedule();
#endif
} else {
DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread);
DUMP2(" (current thread:%"PRIxVALUE")", rb_thread_current());
}
/* end of handler : remove it */
return 1;
}
static VALUE
ip_invoke_with_position(argc, argv, obj, position)
int argc;
VALUE *argv;
VALUE obj;
Tcl_QueuePosition position;
{
struct invoke_queue *ivq;
#ifdef RUBY_USE_NATIVE_THREAD
struct tcltkip *ptr;
#endif
int *alloc_done;
int thr_crit_bup;
volatile VALUE current = rb_thread_current();
volatile VALUE ip_obj = obj;
volatile VALUE result;
volatile VALUE ret;
struct timeval t;
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **av = (Tcl_Obj **)NULL;
#else /* TCL_MAJOR_VERSION < 8 */
char **av = (char **)NULL;
#endif
if (argc < 1) {
rb_raise(rb_eArgError, "command name missing");
}
#ifdef RUBY_USE_NATIVE_THREAD
ptr = get_ip(ip_obj);
DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id);
DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#else
DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#endif
DUMP2("status: eventloopt_thread %"PRIxVALUE, eventloop_thread);
if (
#ifdef RUBY_USE_NATIVE_THREAD
(ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
&&
#endif
(NIL_P(eventloop_thread) || current == eventloop_thread)
) {
if (NIL_P(eventloop_thread)) {
DUMP2("invoke from thread:%"PRIxVALUE" but no eventloop", current);
} else {
DUMP2("invoke from current eventloop %"PRIxVALUE, current);
}
result = ip_invoke_real(argc, argv, ip_obj);
if (rb_obj_is_kind_of(result, rb_eException)) {
rb_exc_raise(result);
}
return result;
}
DUMP2("invoke from thread %"PRIxVALUE" (NOT current eventloop)", current);
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* allocate memory (for arguments) */
av = alloc_invoke_arguments(argc, argv);
/* allocate memory (keep result) */
/* alloc_done = (int*)ALLOC(int); */
alloc_done = RbTk_ALLOC_N(int, 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
#endif
*alloc_done = 0;
/* allocate memory (freed by Tcl_ServiceEvent) */
/* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */
ivq = RbTk_ALLOC_N(struct invoke_queue, 1);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */
#endif
/* allocate result obj */
result = rb_ary_new3(1, Qnil);
/* construct event data */
ivq->done = alloc_done;
ivq->argc = argc;
ivq->argv = av;
ivq->interp = ip_obj;
ivq->result = result;
ivq->thread = current;
ivq->safe_level = rb_safe_level();
ivq->ev.proc = invoke_queue_handler;
/* add the handler to Tcl event queue */
DUMP1("add handler");
#ifdef RUBY_USE_NATIVE_THREAD
if (ptr->tk_thread_id) {
/* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */
Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position);
Tcl_ThreadAlert(ptr->tk_thread_id);
} else if (tk_eventloop_thread_id) {
/* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
&(ivq->ev), position); */
Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
(Tcl_Event*)ivq, position);
Tcl_ThreadAlert(tk_eventloop_thread_id);
} else {
/* Tcl_QueueEvent(&(ivq->ev), position); */
Tcl_QueueEvent((Tcl_Event*)ivq, position);
}
#else
/* Tcl_QueueEvent(&(ivq->ev), position); */
Tcl_QueueEvent((Tcl_Event*)ivq, position);
#endif
rb_thread_critical = thr_crit_bup;
/* wait for the handler to be processed */
t.tv_sec = 0;
t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
DUMP2("ivq wait for handler (current thread:%"PRIxVALUE")", current);
while(*alloc_done >= 0) {
/* rb_thread_stop(); */
/* rb_thread_sleep_forever(); */
rb_thread_wait_for(t);
DUMP2("*** ivq wakeup (current thread:%"PRIxVALUE")", current);
DUMP2("*** (eventloop thread:%"PRIxVALUE")", eventloop_thread);
if (NIL_P(eventloop_thread)) {
DUMP1("*** ivq lost eventloop thread");
break;
}
}
DUMP2("back from handler (current thread:%"PRIxVALUE")", current);
/* get result & free allocated memory */
ret = RARRAY_AREF(result, 0);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
#else
/* free(alloc_done); */
ckfree((char*)alloc_done);
#endif
#endif
#if 0 /* ivq is freed by Tcl_ServiceEvent */
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release(ivq);
#else
ckfree((char*)ivq);
#endif
#endif
#endif
/* free allocated memory */
free_invoke_arguments(argc, av);
/* exception? */
if (rb_obj_is_kind_of(ret, rb_eException)) {
DUMP1("raise exception");
/* rb_exc_raise(ret); */
rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
rb_funcallv(ret, ID_to_s, 0, 0)));
}
DUMP1("exit ip_invoke");
return ret;
}
/* get return code from Tcl_Eval() */
static VALUE
ip_retval(self)
VALUE self;
{
struct tcltkip *ptr; /* tcltkip data struct */
/* get the data strcut */
ptr = get_ip(self);
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_tainted_str_new2("");
}
return (INT2FIX(ptr->return_value));
}
static VALUE
ip_invoke(argc, argv, obj)
int argc;
VALUE *argv;
VALUE obj;
{
return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL);
}
static VALUE
ip_invoke_immediate(argc, argv, obj)
int argc;
VALUE *argv;
VALUE obj;
{
/* POTENTIALY INSECURE : can create infinite loop */
return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD);
}
/* access Tcl variables */
static VALUE
ip_get_variable2_core(interp, argc, argv)
VALUE interp;
int argc;
VALUE *argv;
{
struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
volatile VALUE varname, index, flag;
varname = argv[0];
index = argv[1];
flag = argv[2];
/*
StringValue(varname);
if (!NIL_P(index)) StringValue(index);
*/
#if TCL_MAJOR_VERSION >= 8
{
Tcl_Obj *ret;
volatile VALUE strval;
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
/* ip is deleted? */
if (deleted_ip(ptr)) {
rb_thread_critical = thr_crit_bup;
return rb_tainted_str_new2("");
} else {
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
ret = Tcl_GetVar2Ex(ptr->ip, RSTRING_PTR(varname),
NIL_P(index) ? NULL : RSTRING_PTR(index),
FIX2INT(flag));
}
if (ret == (Tcl_Obj*)NULL) {
volatile VALUE exc;
/* exc = rb_exc_new2(rb_eRuntimeError,
Tcl_GetStringResult(ptr->ip)); */
exc = create_ip_exc(interp, rb_eRuntimeError, "%s",
Tcl_GetStringResult(ptr->ip));
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return exc;
}
Tcl_IncrRefCount(ret);
strval = get_str_from_obj(ret);
RbTk_OBJ_UNTRUST(strval);
Tcl_DecrRefCount(ret);
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return(strval);
}
#else /* TCL_MAJOR_VERSION < 8 */
{
char *ret;
volatile VALUE strval;
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_tainted_str_new2("");
} else {
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
ret = Tcl_GetVar2(ptr->ip, RSTRING_PTR(varname),
NIL_P(index) ? NULL : RSTRING_PTR(index),
FIX2INT(flag));
}
if (ret == (char*)NULL) {
volatile VALUE exc;
exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return exc;
}
strval = rb_tainted_str_new2(ret);
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return(strval);
}
#endif
}
static VALUE
ip_get_variable2(self, varname, index, flag)
VALUE self;
VALUE varname;
VALUE index;
VALUE flag;
{
VALUE argv[3];
VALUE retval;
StringValue(varname);
if (!NIL_P(index)) StringValue(index);
argv[0] = varname;
argv[1] = index;
argv[2] = flag;
retval = tk_funcall(ip_get_variable2_core, 3, argv, self);
if (NIL_P(retval)) {
return rb_tainted_str_new2("");
} else {
return retval;
}
}
static VALUE
ip_get_variable(self, varname, flag)
VALUE self;
VALUE varname;
VALUE flag;
{
return ip_get_variable2(self, varname, Qnil, flag);
}
static VALUE
ip_set_variable2_core(interp, argc, argv)
VALUE interp;
int argc;
VALUE *argv;
{
struct tcltkip *ptr = get_ip(interp);
int thr_crit_bup;
volatile VALUE varname, index, value, flag;
varname = argv[0];
index = argv[1];
value = argv[2];
flag = argv[3];
/*
StringValue(varname);
if (!NIL_P(index)) StringValue(index);
StringValue(value);
*/
#if TCL_MAJOR_VERSION >= 8
{
Tcl_Obj *valobj, *ret;
volatile VALUE strval;
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
valobj = get_obj_from_str(value);
Tcl_IncrRefCount(valobj);
/* ip is deleted? */
if (deleted_ip(ptr)) {
Tcl_DecrRefCount(valobj);
rb_thread_critical = thr_crit_bup;
return rb_tainted_str_new2("");
} else {
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
ret = Tcl_SetVar2Ex(ptr->ip, RSTRING_PTR(varname),
NIL_P(index) ? NULL : RSTRING_PTR(index),
valobj, FIX2INT(flag));
}
Tcl_DecrRefCount(valobj);
if (ret == (Tcl_Obj*)NULL) {
volatile VALUE exc;
/* exc = rb_exc_new2(rb_eRuntimeError,
Tcl_GetStringResult(ptr->ip)); */
exc = create_ip_exc(interp, rb_eRuntimeError, "%s",
Tcl_GetStringResult(ptr->ip));
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return exc;
}
Tcl_IncrRefCount(ret);
strval = get_str_from_obj(ret);
RbTk_OBJ_UNTRUST(strval);
Tcl_DecrRefCount(ret);
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return(strval);
}
#else /* TCL_MAJOR_VERSION < 8 */
{
CONST char *ret;
volatile VALUE strval;
/* ip is deleted? */
if (deleted_ip(ptr)) {
return rb_tainted_str_new2("");
} else {
/* Tcl_Preserve(ptr->ip); */
rbtk_preserve_ip(ptr);
ret = Tcl_SetVar2(ptr->ip, RSTRING_PTR(varname),
NIL_P(index) ? NULL : RSTRING_PTR(index),
RSTRING_PTR(value), FIX2INT(flag));
}
if (ret == (char*)NULL) {
return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
}
strval = rb_tainted_str_new2(ret);
/* Tcl_Release(ptr->ip); */
rbtk_release_ip(ptr);
rb_thread_critical = thr_crit_bup;
return(strval);
}
#endif
}
static VALUE
ip_set_variable2(self, varname, index, value, flag)
VALUE self;
VALUE varname;
VALUE index;
VALUE value;
VALUE flag;
{
VALUE argv[4];
VALUE retval;
StringValue(varname);
if (!NIL_P(index)) StringValue(index);
StringValue(value);
argv[0] = varname;
argv[1] = index;
argv[2] = value;
argv[3] = flag;
retval = tk_funcall(ip_set_variable2_core, 4, argv, self);
if (NIL_P(retval)) {
return rb_tainted_str_new2("");
} else {
return retval;
}
}
static VALUE
ip_set_variable(self, varname, value, flag)
VALUE self;
VALUE varname;
VALUE value;
VALUE flag;
{
return ip_set_variable2(self, varname, Qnil, value, flag);
}
static VALUE
ip_unset_variable2_core(interp, argc, argv)
VALUE interp;
int argc;
VALUE *argv;
{
struct tcltkip *ptr = get_ip(interp);
volatile VALUE varname, index, flag;
varname = argv[0];
index = argv[1];
flag = argv[2];
/*
StringValue(varname);
if (!NIL_P(index)) StringValue(index);
*/
/* ip is deleted? */
if (deleted_ip(ptr)) {
return Qtrue;
}
ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING_PTR(varname),
NIL_P(index) ? NULL : RSTRING_PTR(index),
FIX2INT(flag));
if (ptr->return_value == TCL_ERROR) {
if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
/* return rb_exc_new2(rb_eRuntimeError,
Tcl_GetStringResult(ptr->ip)); */
return create_ip_exc(interp, rb_eRuntimeError, "%s",
Tcl_GetStringResult(ptr->ip));
}
return Qfalse;
}
return Qtrue;
}
static VALUE
ip_unset_variable2(self, varname, index, flag)
VALUE self;
VALUE varname;
VALUE index;
VALUE flag;
{
VALUE argv[3];
VALUE retval;
StringValue(varname);
if (!NIL_P(index)) StringValue(index);
argv[0] = varname;
argv[1] = index;
argv[2] = flag;
retval = tk_funcall(ip_unset_variable2_core, 3, argv, self);
if (NIL_P(retval)) {
return rb_tainted_str_new2("");
} else {
return retval;
}
}
static VALUE
ip_unset_variable(self, varname, flag)
VALUE self;
VALUE varname;
VALUE flag;
{
return ip_unset_variable2(self, varname, Qnil, flag);
}
static VALUE
ip_get_global_var(self, varname)
VALUE self;
VALUE varname;
{
return ip_get_variable(self, varname,
INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
}
static VALUE
ip_get_global_var2(self, varname, index)
VALUE self;
VALUE varname;
VALUE index;
{
return ip_get_variable2(self, varname, index,
INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
}
static VALUE
ip_set_global_var(self, varname, value)
VALUE self;
VALUE varname;
VALUE value;
{
return ip_set_variable(self, varname, value,
INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
}
static VALUE
ip_set_global_var2(self, varname, index, value)
VALUE self;
VALUE varname;
VALUE index;
VALUE value;
{
return ip_set_variable2(self, varname, index, value,
INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
}
static VALUE
ip_unset_global_var(self, varname)
VALUE self;
VALUE varname;
{
return ip_unset_variable(self, varname,
INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
}
static VALUE
ip_unset_global_var2(self, varname, index)
VALUE self;
VALUE varname;
VALUE index;
{
return ip_unset_variable2(self, varname, index,
INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
}
/* treat Tcl_List */
static VALUE
lib_split_tklist_core(ip_obj, list_str)
VALUE ip_obj;
VALUE list_str;
{
Tcl_Interp *interp;
volatile VALUE ary, elem;
int idx;
int taint_flag = OBJ_TAINTED(list_str);
#ifdef HAVE_RUBY_ENCODING_H
int list_enc_idx;
volatile VALUE list_ivar_enc;
#endif
int result;
VALUE old_gc;
tcl_stubs_check();
if (NIL_P(ip_obj)) {
interp = (Tcl_Interp *)NULL;
} else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
interp = (Tcl_Interp *)NULL;
} else {
interp = get_ip(ip_obj)->ip;
}
StringValue(list_str);
#ifdef HAVE_RUBY_ENCODING_H
list_enc_idx = rb_enc_get_index(list_str);
list_ivar_enc = rb_ivar_get(list_str, ID_at_enc);
#endif
{
#if TCL_MAJOR_VERSION >= 8
/* object style interface */
Tcl_Obj *listobj;
int objc;
Tcl_Obj **objv;
int thr_crit_bup;
listobj = get_obj_from_str(list_str);
Tcl_IncrRefCount(listobj);
result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv);
if (result == TCL_ERROR) {
Tcl_DecrRefCount(listobj);
if (interp == (Tcl_Interp*)NULL) {
rb_raise(rb_eRuntimeError, "can't get elements from list");
} else {
rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp));
}
}
for(idx = 0; idx < objc; idx++) {
Tcl_IncrRefCount(objv[idx]);
}
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
ary = rb_ary_new2(objc);
if (taint_flag) RbTk_OBJ_UNTRUST(ary);
old_gc = rb_gc_disable();
for(idx = 0; idx < objc; idx++) {
elem = get_str_from_obj(objv[idx]);
if (taint_flag) RbTk_OBJ_UNTRUST(elem);
#ifdef HAVE_RUBY_ENCODING_H
if (rb_enc_get_index(elem) == ENCODING_INDEX_BINARY) {
rb_enc_associate_index(elem, ENCODING_INDEX_BINARY);
rb_ivar_set(elem, ID_at_enc, ENCODING_NAME_BINARY);
} else {
rb_enc_associate_index(elem, list_enc_idx);
rb_ivar_set(elem, ID_at_enc, list_ivar_enc);
}
#endif
/* RARRAY(ary)->ptr[idx] = elem; */
rb_ary_push(ary, elem);
}
/* RARRAY(ary)->len = objc; */
if (old_gc == Qfalse) rb_gc_enable();
rb_thread_critical = thr_crit_bup;
for(idx = 0; idx < objc; idx++) {
Tcl_DecrRefCount(objv[idx]);
}
Tcl_DecrRefCount(listobj);
#else /* TCL_MAJOR_VERSION < 8 */
/* string style interface */
int argc;
char **argv;
if (Tcl_SplitList(interp, RSTRING_PTR(list_str),
&argc, &argv) == TCL_ERROR) {
if (interp == (Tcl_Interp*)NULL) {
rb_raise(rb_eRuntimeError, "can't get elements from list");
} else {
rb_raise(rb_eRuntimeError, "%s", interp->result);
}
}
ary = rb_ary_new2(argc);
if (taint_flag) RbTk_OBJ_UNTRUST(ary);
old_gc = rb_gc_disable();
for(idx = 0; idx < argc; idx++) {
if (taint_flag) {
elem = rb_tainted_str_new2(argv[idx]);
} else {
elem = rb_str_new2(argv[idx]);
}
/* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */
/* RARRAY(ary)->ptr[idx] = elem; */
rb_ary_push(ary, elem)
}
/* RARRAY(ary)->len = argc; */
if (old_gc == Qfalse) rb_gc_enable();
#endif
}
return ary;
}
static VALUE
lib_split_tklist(self, list_str)
VALUE self;
VALUE list_str;
{
return lib_split_tklist_core(Qnil, list_str);
}
static VALUE
ip_split_tklist(self, list_str)
VALUE self;
VALUE list_str;
{
return lib_split_tklist_core(self, list_str);
}
static VALUE
lib_merge_tklist(argc, argv, obj)
int argc;
VALUE *argv;
VALUE obj;
{
int num, len;
int *flagPtr;
char *dst, *result;
volatile VALUE str;
int taint_flag = 0;
int thr_crit_bup;
VALUE old_gc;
if (argc == 0) return rb_str_new2("");
tcl_stubs_check();
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
old_gc = rb_gc_disable();
/* based on Tcl/Tk's Tcl_Merge() */
/* flagPtr = ALLOC_N(int, argc); */
flagPtr = RbTk_ALLOC_N(int, argc);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)flagPtr); /* XXXXXXXXXX */
#endif
/* pass 1 */
len = 1;
for(num = 0; num < argc; num++) {
if (OBJ_TAINTED(argv[num])) taint_flag = 1;
dst = StringValuePtr(argv[num]);
#if TCL_MAJOR_VERSION >= 8
len += Tcl_ScanCountedElement(dst, RSTRING_LENINT(argv[num]),
&flagPtr[num]) + 1;
#else /* TCL_MAJOR_VERSION < 8 */
len += Tcl_ScanElement(dst, &flagPtr[num]) + 1;
#endif
}
/* pass 2 */
/* result = (char *)Tcl_Alloc(len); */
result = (char *)ckalloc(len);
#if 0 /* use Tcl_Preserve/Release */
Tcl_Preserve((ClientData)result);
#endif
dst = result;
for(num = 0; num < argc; num++) {
#if TCL_MAJOR_VERSION >= 8
len = Tcl_ConvertCountedElement(RSTRING_PTR(argv[num]),
RSTRING_LENINT(argv[num]),
dst, flagPtr[num]);
#else /* TCL_MAJOR_VERSION < 8 */
len = Tcl_ConvertElement(RSTRING_PTR(argv[num]), dst, flagPtr[num]);
#endif
dst += len;
*dst = ' ';
dst++;
}
if (dst == result) {
*dst = 0;
} else {
dst[-1] = 0;
}
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)flagPtr);
#else
/* free(flagPtr); */
ckfree((char*)flagPtr);
#endif
#endif
/* create object */
str = rb_str_new(result, dst - result - 1);
if (taint_flag) RbTk_OBJ_UNTRUST(str);
#if 0 /* use Tcl_EventuallyFree */
Tcl_EventuallyFree((ClientData)result, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
Tcl_Release((ClientData)result); /* XXXXXXXXXXX */
#else
/* Tcl_Free(result); */
ckfree(result);
#endif
#endif
if (old_gc == Qfalse) rb_gc_enable();
rb_thread_critical = thr_crit_bup;
return str;
}
static VALUE
lib_conv_listelement(self, src)
VALUE self;
VALUE src;
{
int len, scan_flag;
volatile VALUE dst;
int taint_flag = OBJ_TAINTED(src);
int thr_crit_bup;
tcl_stubs_check();
thr_crit_bup = rb_thread_critical;
rb_thread_critical = Qtrue;
StringValue(src);
#if TCL_MAJOR_VERSION >= 8
len = Tcl_ScanCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
&scan_flag);
dst = rb_str_new(0, len + 1);
len = Tcl_ConvertCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
RSTRING_PTR(dst), scan_flag);
#else /* TCL_MAJOR_VERSION < 8 */
len = Tcl_ScanElement(RSTRING_PTR(src), &scan_flag);
dst = rb_str_new(0, len + 1);
len = Tcl_ConvertElement(RSTRING_PTR(src), RSTRING_PTR(dst), scan_flag);
#endif
rb_str_resize(dst, len);
if (taint_flag) RbTk_OBJ_UNTRUST(dst);
rb_thread_critical = thr_crit_bup;
return dst;
}
static VALUE
lib_getversion(self)
VALUE self;
{
set_tcltk_version();
return rb_ary_new3(4, INT2NUM(tcltk_version.major),
INT2NUM(tcltk_version.minor),
INT2NUM(tcltk_version.type),
INT2NUM(tcltk_version.patchlevel));
}
static VALUE
lib_get_reltype_name(self)
VALUE self;
{
set_tcltk_version();
switch(tcltk_version.type) {
case TCL_ALPHA_RELEASE:
return rb_str_new2("alpha");
case TCL_BETA_RELEASE:
return rb_str_new2("beta");
case TCL_FINAL_RELEASE:
return rb_str_new2("final");
default:
rb_raise(rb_eRuntimeError, "tcltklib has invalid release type number");
}
UNREACHABLE;
}
static VALUE
tcltklib_compile_info(void)
{
volatile VALUE ret;
size_t size;
static CONST char form[]
= "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s";
char *info;
size = strlen(form)
+ strlen(TCLTKLIB_RELEASE_DATE)
+ strlen(RUBY_VERSION)
+ strlen(RUBY_RELEASE_DATE)
+ strlen("without")
+ strlen(TCL_PATCH_LEVEL)
+ strlen("without stub")
+ strlen(TK_PATCH_LEVEL)
+ strlen("without stub")
+ strlen("unknown tcl_threads");
info = ALLOC_N(char, size);
/* info = ckalloc(sizeof(char) * size); */ /* SEGV */
sprintf(info, form,
TCLTKLIB_RELEASE_DATE,
RUBY_VERSION, RUBY_RELEASE_DATE,
#ifdef HAVE_NATIVETHREAD
"with",
#else
"without",
#endif
TCL_PATCH_LEVEL,
#ifdef USE_TCL_STUBS
"with stub",
#else
"without stub",
#endif
TK_PATCH_LEVEL,
#ifdef USE_TK_STUBS
"with stub",
#else
"without stub",
#endif
#ifdef WITH_TCL_ENABLE_THREAD
# if WITH_TCL_ENABLE_THREAD
"with tcl_threads"
# else
"without tcl_threads"
# endif
#else
"unknown tcl_threads"
#endif
);
ret = rb_obj_freeze(rb_str_new2(info));
xfree(info);
/* ckfree(info); */
return ret;
}
/*###############################################*/
static VALUE
create_dummy_encoding_for_tk_core(interp, name, error_mode)
VALUE interp;
VALUE name;
VALUE error_mode;
{
get_ip(interp);
StringValue(name);
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) {
if (RTEST(error_mode)) {
rb_raise(rb_eArgError, "invalid Tk encoding name '%s'",
RSTRING_PTR(name));
} else {
return Qnil;
}
}
#endif
#ifdef HAVE_RUBY_ENCODING_H
if (RTEST(rb_define_dummy_encoding(RSTRING_PTR(name)))) {
int idx = rb_enc_find_index(StringValueCStr(name));
return rb_enc_from_encoding(rb_enc_from_index(idx));
} else {
if (RTEST(error_mode)) {
rb_raise(rb_eRuntimeError, "fail to create dummy encoding for '%s'",
RSTRING_PTR(name));
} else {
return Qnil;
}
}
UNREACHABLE;
#else
return name;
#endif
}
static VALUE
create_dummy_encoding_for_tk(interp, name)
VALUE interp;
VALUE name;
{
return create_dummy_encoding_for_tk_core(interp, name, Qtrue);
}
#ifdef HAVE_RUBY_ENCODING_H
static int
update_encoding_table(table, interp, error_mode)
VALUE table;
VALUE interp;
VALUE error_mode;
{
struct tcltkip *ptr;
int retry = 0;
int i, idx, objc;
Tcl_Obj **objv;
Tcl_Obj *enc_list;
volatile VALUE encname = Qnil;
volatile VALUE encobj = Qnil;
/* interpreter check */
if (NIL_P(interp)) return 0;
ptr = get_ip(interp);
if (ptr == (struct tcltkip *) NULL) return 0;
if (deleted_ip(ptr)) return 0;
/* get Tcl's encoding list */
Tcl_GetEncodingNames(ptr->ip);
enc_list = Tcl_GetObjResult(ptr->ip);
Tcl_IncrRefCount(enc_list);
if (Tcl_ListObjGetElements(ptr->ip, enc_list,
&objc, &objv) != TCL_OK) {
Tcl_DecrRefCount(enc_list);
/* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");*/
return 0;
}
/* check each encoding name */
for(i = 0; i < objc; i++) {
encname = rb_str_new2(Tcl_GetString(objv[i]));
if (NIL_P(rb_hash_lookup(table, encname))) {
/* new Tk encoding -> add to table */
idx = rb_enc_find_index(StringValueCStr(encname));
if (idx < 0) {
encobj = create_dummy_encoding_for_tk_core(interp,encname,error_mode);
} else {
encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
}
encname = rb_obj_freeze(encname);
rb_hash_aset(table, encname, encobj);
if (!NIL_P(encobj) && NIL_P(rb_hash_lookup(table, encobj))) {
rb_hash_aset(table, encobj, encname);
}
retry = 1;
}
}
Tcl_DecrRefCount(enc_list);
return retry;
}
static VALUE
encoding_table_get_name_core(table, enc_arg, error_mode)
VALUE table;
VALUE enc_arg;
VALUE error_mode;
{
volatile VALUE enc = enc_arg;
volatile VALUE name = Qnil;
volatile VALUE tmp = Qnil;
volatile VALUE interp = rb_ivar_get(table, ID_at_interp);
struct tcltkip *ptr = (struct tcltkip *) NULL;
int idx;
/* deleted interp ? */
if (!NIL_P(interp)) {
ptr = get_ip(interp);
if (deleted_ip(ptr)) {
ptr = (struct tcltkip *) NULL;
}
}
/* encoding argument check */
/* 1st: default encoding setting of interp */
if (ptr && NIL_P(enc)) {
if (rb_respond_to(interp, ID_encoding_name)) {
enc = rb_funcallv(interp, ID_encoding_name, 0, 0);
}
}
/* 2nd: Encoding.default_internal */
if (NIL_P(enc)) {
enc = rb_enc_default_internal();
}
/* 3rd: encoding system of Tcl/Tk */
if (NIL_P(enc)) {
enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
}
/* 4th: Encoding.default_external */
if (NIL_P(enc)) {
enc = rb_enc_default_external();
}
/* 5th: Encoding.locale_charmap */
if (NIL_P(enc)) {
enc = rb_locale_charmap(rb_cEncoding);
}
if (RTEST(rb_obj_is_kind_of(enc, cRubyEncoding))) {
/* Ruby's Encoding object */
name = rb_hash_lookup(table, enc);
if (!NIL_P(name)) {
/* find */
return name;
}
/* is it new ? */
/* update check of Tk encoding names */
if (update_encoding_table(table, interp, error_mode)) {
/* add new relations to the table */
/* RETRY: registered Ruby encoding? */
name = rb_hash_lookup(table, enc);
if (!NIL_P(name)) {
/* find */
return name;
}
}
/* fail to find */
} else {
/* String or Symbol? */
name = rb_funcallv(enc, ID_to_s, 0, 0);
if (!NIL_P(rb_hash_lookup(table, name))) {
/* find */
return name;
}
/* is it new ? */
idx = rb_enc_find_index(StringValueCStr(name));
if (idx >= 0) {
enc = rb_enc_from_encoding(rb_enc_from_index(idx));
/* registered Ruby encoding? */
tmp = rb_hash_lookup(table, enc);
if (!NIL_P(tmp)) {
/* find */
return tmp;
}
/* update check of Tk encoding names */
if (update_encoding_table(table, interp, error_mode)) {
/* add new relations to the table */
/* RETRY: registered Ruby encoding? */
tmp = rb_hash_lookup(table, enc);
if (!NIL_P(tmp)) {
/* find */
return tmp;
}
}
}
/* fail to find */
}
if (RTEST(error_mode)) {
enc = rb_funcallv(enc_arg, ID_to_s, 0, 0);
rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
}
return Qnil;
}
static VALUE
encoding_table_get_obj_core(table, enc, error_mode)
VALUE table;
VALUE enc;
VALUE error_mode;
{
volatile VALUE obj = Qnil;
obj = rb_hash_lookup(table,
encoding_table_get_name_core(table, enc, error_mode));
if (RTEST(rb_obj_is_kind_of(obj, cRubyEncoding))) {
return obj;
} else {
return Qnil;
}
}
#else /* ! HAVE_RUBY_ENCODING_H */
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
static int
update_encoding_table(table, interp, error_mode)
VALUE table;
VALUE interp;
VALUE error_mode;
{
struct tcltkip *ptr;
int retry = 0;
int i, objc;
Tcl_Obj **objv;
Tcl_Obj *enc_list;
volatile VALUE encname = Qnil;
/* interpreter check */
if (NIL_P(interp)) return 0;
ptr = get_ip(interp);
if (ptr == (struct tcltkip *) NULL) return 0;
if (deleted_ip(ptr)) return 0;
/* get Tcl's encoding list */
Tcl_GetEncodingNames(ptr->ip);
enc_list = Tcl_GetObjResult(ptr->ip);
Tcl_IncrRefCount(enc_list);
if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
Tcl_DecrRefCount(enc_list);
/* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); */
return 0;
}
/* get encoding name and set it to table */
for(i = 0; i < objc; i++) {
encname = rb_str_new2(Tcl_GetString(objv[i]));
if (NIL_P(rb_hash_lookup(table, encname))) {
/* new Tk encoding -> add to table */
encname = rb_obj_freeze(encname);
rb_hash_aset(table, encname, encname);
retry = 1;
}
}
Tcl_DecrRefCount(enc_list);
return retry;
}
static VALUE
encoding_table_get_name_core(table, enc, error_mode)
VALUE table;
VALUE enc;
VALUE error_mode;
{
volatile VALUE name = Qnil;
enc = rb_funcallv(enc, ID_to_s, 0, 0);
name = rb_hash_lookup(table, enc);
if (!NIL_P(name)) {
/* find */
return name;
}
/* update check */
if (update_encoding_table(table, rb_ivar_get(table, ID_at_interp),
error_mode)) {
/* add new relations to the table */
/* RETRY: registered Ruby encoding? */
name = rb_hash_lookup(table, enc);
if (!NIL_P(name)) {
/* find */
return name;
}
}
if (RTEST(error_mode)) {
rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
}
return Qnil;
}
static VALUE
encoding_table_get_obj_core(table, enc, error_mode)
VALUE table;
VALUE enc;
VALUE error_mode;
{
return encoding_table_get_name_core(table, enc, error_mode);
}
#else /* Tcl/Tk 7.x or 8.0 */
static VALUE
encoding_table_get_name_core(table, enc, error_mode)
VALUE table;
VALUE enc;
VALUE error_mode;
{
return Qnil;
}
static VALUE
encoding_table_get_obj_core(table, enc, error_mode)
VALUE table;
VALUE enc;
VALUE error_mode;
{
return Qnil;
}
#endif /* end of dependency for the version of Tcl/Tk */
#endif
static VALUE
encoding_table_get_name(table, enc)
VALUE table;
VALUE enc;
{
return encoding_table_get_name_core(table, enc, Qtrue);
}
static VALUE
encoding_table_get_obj(table, enc)
VALUE table;
VALUE enc;
{
return encoding_table_get_obj_core(table, enc, Qtrue);
}
#ifdef HAVE_RUBY_ENCODING_H
static VALUE
create_encoding_table_core(arg, interp)
VALUE arg;
VALUE interp;
{
struct tcltkip *ptr = get_ip(interp);
volatile VALUE table = rb_hash_new();
volatile VALUE encname = Qnil;
volatile VALUE encobj = Qnil;
int i, idx, objc;
Tcl_Obj **objv;
Tcl_Obj *enc_list;
#ifdef HAVE_RB_SET_SAFE_LEVEL_FORCE
rb_set_safe_level_force(0);
#else
rb_set_safe_level(0);
#endif
/* set 'binary' encoding */
encobj = rb_enc_from_encoding(rb_enc_from_index(ENCODING_INDEX_BINARY));
rb_hash_aset(table, ENCODING_NAME_BINARY, encobj);
rb_hash_aset(table, encobj, ENCODING_NAME_BINARY);
/* Tcl stub check */
tcl_stubs_check();
/* get Tcl's encoding list */
Tcl_GetEncodingNames(ptr->ip);
enc_list = Tcl_GetObjResult(ptr->ip);
Tcl_IncrRefCount(enc_list);
if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
Tcl_DecrRefCount(enc_list);
rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
}
/* get encoding name and set it to table */
for(i = 0; i < objc; i++) {
int name2obj, obj2name;
name2obj = 1; obj2name = 1;
encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
idx = rb_enc_find_index(StringValueCStr(encname));
if (idx < 0) {
/* fail to find ruby encoding -> check known encoding */
if (strcmp(RSTRING_PTR(encname), "identity") == 0) {
name2obj = 1; obj2name = 0;
idx = ENCODING_INDEX_BINARY;
} else if (strcmp(RSTRING_PTR(encname), "shiftjis") == 0) {
name2obj = 1; obj2name = 0;
idx = rb_enc_find_index("Shift_JIS");
} else if (strcmp(RSTRING_PTR(encname), "unicode") == 0) {
name2obj = 1; obj2name = 0;
idx = ENCODING_INDEX_UTF8;
} else if (strcmp(RSTRING_PTR(encname), "symbol") == 0) {
name2obj = 1; obj2name = 0;
idx = rb_enc_find_index("ASCII-8BIT");
} else {
/* regist dummy encoding */
name2obj = 1; obj2name = 1;
}
}
if (idx < 0) {
/* unknown encoding -> create dummy */
encobj = create_dummy_encoding_for_tk(interp, encname);
} else {
encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
}
if (name2obj) {
DUMP2("create_encoding_table: name2obj: %s", RSTRING_PTR(encname));
rb_hash_aset(table, encname, encobj);
}
if (obj2name) {
DUMP2("create_encoding_table: obj2name: %s", RSTRING_PTR(encname));
rb_hash_aset(table, encobj, encname);
}
}
Tcl_DecrRefCount(enc_list);
rb_ivar_set(table, ID_at_interp, interp);
rb_ivar_set(interp, ID_encoding_table, table);
return table;
}
#else /* ! HAVE_RUBY_ENCODING_H */
#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
static VALUE
create_encoding_table_core(arg, interp)
VALUE arg;
VALUE interp;
{
struct tcltkip *ptr = get_ip(interp);
volatile VALUE table = rb_hash_new();
volatile VALUE encname = Qnil;
int i, objc;
Tcl_Obj **objv;
Tcl_Obj *enc_list;
/* set 'binary' encoding */
rb_hash_aset(table, ENCODING_NAME_BINARY, ENCODING_NAME_BINARY);
/* get Tcl's encoding list */
Tcl_GetEncodingNames(ptr->ip);
enc_list = Tcl_GetObjResult(ptr->ip);
Tcl_IncrRefCount(enc_list);
if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
Tcl_DecrRefCount(enc_list);
rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
}
/* get encoding name and set it to table */
for(i = 0; i < objc; i++) {
encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
rb_hash_aset(table, encname, encname);
}
Tcl_DecrRefCount(enc_list);
rb_ivar_set(table, ID_at_interp, interp);
rb_ivar_set(interp, ID_encoding_table, table);
return table;
}
#else /* Tcl/Tk 7.x or 8.0 */
static VALUE
create_encoding_table_core(arg, interp)
VALUE arg;
VALUE interp;
{
volatile VALUE table = rb_hash_new();
rb_ivar_set(interp, ID_encoding_table, table);
return table;
}
#endif
#endif
static VALUE
create_encoding_table(interp)
VALUE interp;
{
return rb_funcall(rb_proc_new(create_encoding_table_core, interp),
ID_call, 0);
}
static VALUE
ip_get_encoding_table(interp)
VALUE interp;
{
volatile VALUE table = Qnil;
table = rb_ivar_get(interp, ID_encoding_table);
if (NIL_P(table)) {
/* initialize encoding_table */
table = create_encoding_table(interp);
rb_define_singleton_method(table, "get_name", encoding_table_get_name, 1);
rb_define_singleton_method(table, "get_obj", encoding_table_get_obj, 1);
}
return table;
}
/*###############################################*/
/*
* The following is based on tkMenu.[ch]
* of Tcl/Tk (Tk8.0 -- Tk8.5b1) source code.
*/
#if TCL_MAJOR_VERSION >= 8
#define MASTER_MENU 0
#define TEAROFF_MENU 1
#define MENUBAR 2
struct dummy_TkMenuEntry {
int type;
struct dummy_TkMenu *menuPtr;
/* , and etc. */
};
struct dummy_TkMenu {
Tk_Window tkwin;
Display *display;
Tcl_Interp *interp;
Tcl_Command widgetCmd;
struct dummy_TkMenuEntry **entries;
int numEntries;
int active;
int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR */
Tcl_Obj *menuTypePtr;
/* , and etc. */
};
struct dummy_TkMenuRef {
struct dummy_TkMenu *menuPtr;
char *dummy1;
char *dummy2;
char *dummy3;
};
#if 0 /* was available on Tk8.0 -- Tk8.4 */
EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*);
#else /* based on Tk8.0 -- Tk8.5.0 */
#define MENU_HASH_KEY "tkMenus"
#endif
#endif
static VALUE
ip_make_menu_embeddable_core(interp, argc, argv)
VALUE interp;
int argc;
VALUE *argv;
{
#if TCL_MAJOR_VERSION >= 8
volatile VALUE menu_path;
struct tcltkip *ptr = get_ip(interp);
struct dummy_TkMenuRef *menuRefPtr = NULL;
XEvent event;
Tcl_HashTable *menuTablePtr;
Tcl_HashEntry *hashEntryPtr;
menu_path = argv[0];
StringValue(menu_path);
#if 0 /* was available on Tk8.0 -- Tk8.4 */
menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path));
#else /* based on Tk8.0 -- Tk8.5b1 */
if ((menuTablePtr
= (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL))
!= NULL) {
if ((hashEntryPtr
= Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path)))
!= NULL) {
menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr);
}
}
#endif
if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) {
rb_raise(rb_eArgError, "not a menu widget, or invalid widget path");
}
if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) {
rb_raise(rb_eRuntimeError,
"invalid menu widget (maybe already destroyed)");
}
if ((menuRefPtr->menuPtr)->menuType != MENUBAR) {
rb_raise(rb_eRuntimeError,
"target menu widget must be a MENUBAR type");
}
(menuRefPtr->menuPtr)->menuType = TEAROFF_MENU;
#if 0 /* cause SEGV */
{
/* char *s = "tearoff"; */
char *s = "normal";
/* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/
(menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s));
/* Tcl_IncrRefCount((menuRefPtr->menuPtr)->menuTypePtr); */
/* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */
(menuRefPtr->menuPtr)->menuType = MASTER_MENU;
}
#endif
#if 0 /* was available on Tk8.0 -- Tk8.4 */
TkEventuallyRecomputeMenu(menuRefPtr->menuPtr);
TkEventuallyRedrawMenu(menuRefPtr->menuPtr,
(struct dummy_TkMenuEntry *)NULL);
#else /* based on Tk8.0 -- Tk8.5b1 */
memset((void *) &event, 0, sizeof(event));
event.xany.type = ConfigureNotify;
event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin));
event.xany.send_event = 0; /* FALSE */
event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin);
event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin);
event.xconfigure.window = event.xany.window;
Tk_HandleEvent(&event);
#endif
#else /* TCL_MAJOR_VERSION <= 7 */
rb_notimplement();
#endif
return interp;
}
static VALUE
ip_make_menu_embeddable(interp, menu_path)
VALUE interp;
VALUE menu_path;
{
VALUE argv[1];
argv[0] = menu_path;
return tk_funcall(ip_make_menu_embeddable_core, 1, argv, interp);
}
/*###############################################*/
/*---- initialization ----*/
void
Init_tcltklib(void)
{
int ret;
VALUE lib = rb_define_module("TclTkLib");
VALUE ip = rb_define_class("TclTkIp", rb_cObject);
VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag");
VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE");
/* --------------------------------------------------------------- */
tcltkip_class = ip;
/* --------------------------------------------------------------- */
#ifdef HAVE_RUBY_ENCODING_H
rb_global_variable(&cRubyEncoding);
cRubyEncoding = rb_path2class("Encoding");
ENCODING_INDEX_UTF8 = rb_enc_to_index(rb_utf8_encoding());
ENCODING_INDEX_BINARY = rb_enc_find_index("binary");
#endif
rb_global_variable(&ENCODING_NAME_UTF8);
rb_global_variable(&ENCODING_NAME_BINARY);
ENCODING_NAME_UTF8 = rb_obj_freeze(rb_str_new2("utf-8"));
ENCODING_NAME_BINARY = rb_obj_freeze(rb_str_new2("binary"));
/* --------------------------------------------------------------- */
rb_global_variable(&eTkCallbackReturn);
rb_global_variable(&eTkCallbackBreak);
rb_global_variable(&eTkCallbackContinue);
rb_global_variable(&eventloop_thread);
rb_global_variable(&eventloop_stack);
rb_global_variable(&watchdog_thread);
rb_global_variable(&rbtk_pending_exception);
/* --------------------------------------------------------------- */
rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info());
rb_define_const(lib, "RELEASE_DATE",
rb_obj_freeze(rb_str_new2(tcltklib_release_date)));
rb_define_const(lib, "FINALIZE_PROC_NAME",
rb_str_new2(finalize_hook_name));
/* --------------------------------------------------------------- */
#ifdef __WIN32__
# define TK_WINDOWING_SYSTEM "win32"
#else
# ifdef MAC_TCL
# define TK_WINDOWING_SYSTEM "classic"
# else
# ifdef MAC_OSX_TK
# define TK_WINDOWING_SYSTEM "aqua"
# else
# define TK_WINDOWING_SYSTEM "x11"
# endif
# endif
#endif
rb_define_const(lib, "WINDOWING_SYSTEM",
rb_obj_freeze(rb_str_new2(TK_WINDOWING_SYSTEM)));
/* --------------------------------------------------------------- */
rb_define_const(ev_flag, "NONE", INT2FIX(0));
rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS));
rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS));
rb_define_const(ev_flag, "TIMER", INT2FIX(TCL_TIMER_EVENTS));
rb_define_const(ev_flag, "IDLE", INT2FIX(TCL_IDLE_EVENTS));
rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS));
rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT));
/* --------------------------------------------------------------- */
rb_define_const(var_flag, "NONE", INT2FIX(0));
rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY));
#ifdef TCL_NAMESPACE_ONLY
rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY));
#else /* probably Tcl7.6 */
rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0));
#endif
rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG));
rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE));
rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT));
#ifdef TCL_PARSE_PART1
rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1));
#else /* probably Tcl7.6 */
rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0));
#endif
/* --------------------------------------------------------------- */
rb_define_module_function(lib, "get_version", lib_getversion, -1);
rb_define_module_function(lib, "get_release_type_name",
lib_get_reltype_name, -1);
rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE));
rb_define_const(release_type, "BETA", INT2FIX(TCL_BETA_RELEASE));
rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE));
/* --------------------------------------------------------------- */
eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError);
eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
eTkCallbackContinue = rb_define_class("TkCallbackContinue",
rb_eStandardError);
/* --------------------------------------------------------------- */
eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError"));
eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError);
eTkCallbackRetry = rb_define_class("TkCallbackRetry", eTkLocalJumpError);
eTkCallbackRedo = rb_define_class("TkCallbackRedo", eTkLocalJumpError);
eTkCallbackThrow = rb_define_class("TkCallbackThrow", eTkLocalJumpError);
/* --------------------------------------------------------------- */
ID_at_enc = rb_intern("@encoding");
ID_at_interp = rb_intern("@interp");
ID_encoding_name = rb_intern("encoding_name");
ID_encoding_table = rb_intern("encoding_table");
ID_stop_p = rb_intern("stop?");
#ifndef HAVE_RB_THREAD_ALIVE_P
ID_alive_p = rb_intern("alive?");
#endif
ID_kill = rb_intern("kill");
ID_join = rb_intern("join");
ID_value = rb_intern("value");
ID_call = rb_intern("call");
ID_backtrace = rb_intern("backtrace");
ID_message = rb_intern("message");
ID_at_reason = rb_intern("@reason");
ID_return = rb_intern("return");
ID_break = rb_intern("break");
ID_next = rb_intern("next");
ID_to_s = rb_intern("to_s");
ID_inspect = rb_intern("inspect");
/* --------------------------------------------------------------- */
rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
rb_define_module_function(lib, "mainloop_thread?",
lib_evloop_thread_p, 0);
rb_define_module_function(lib, "mainloop_watchdog",
lib_mainloop_watchdog, -1);
rb_define_module_function(lib, "do_thread_callback",
lib_thread_callback, -1);
rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1);
rb_define_module_function(lib, "mainloop_abort_on_exception",
lib_evloop_abort_on_exc, 0);
rb_define_module_function(lib, "mainloop_abort_on_exception=",
lib_evloop_abort_on_exc_set, 1);
rb_define_module_function(lib, "set_eventloop_window_mode",
set_eventloop_window_mode, 1);
rb_define_module_function(lib, "get_eventloop_window_mode",
get_eventloop_window_mode, 0);
rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1);
rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0);
rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1);
rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0);
rb_define_module_function(lib, "set_eventloop_weight",
set_eventloop_weight, 2);
rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1);
rb_define_module_function(lib, "get_eventloop_weight",
get_eventloop_weight, 0);
rb_define_module_function(lib, "num_of_mainwindows",
lib_num_of_mainwindows, 0);
/* --------------------------------------------------------------- */
rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1);
rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1);
rb_define_module_function(lib, "_conv_listelement",
lib_conv_listelement, 1);
rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1);
rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1);
rb_define_module_function(lib, "_subst_UTF_backslash",
lib_UTF_backslash, 1);
rb_define_module_function(lib, "_subst_Tcl_backslash",
lib_Tcl_backslash, 1);
rb_define_module_function(lib, "encoding_system",
lib_get_system_encoding, 0);
rb_define_module_function(lib, "encoding_system=",
lib_set_system_encoding, 1);
rb_define_module_function(lib, "encoding",
lib_get_system_encoding, 0);
rb_define_module_function(lib, "encoding=",
lib_set_system_encoding, 1);
/* --------------------------------------------------------------- */
rb_define_alloc_func(ip, ip_alloc);
rb_define_method(ip, "initialize", ip_init, -1);
rb_define_method(ip, "create_slave", ip_create_slave, -1);
rb_define_method(ip, "slave_of?", ip_is_slave_of_p, 1);
rb_define_method(ip, "make_safe", ip_make_safe, 0);
rb_define_method(ip, "safe?", ip_is_safe_p, 0);
rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0);
rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1);
rb_define_method(ip, "delete", ip_delete, 0);
rb_define_method(ip, "deleted?", ip_is_deleted_p, 0);
rb_define_method(ip, "has_mainwindow?", ip_has_mainwindow_p, 0);
rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0);
rb_define_method(ip, "_eval", ip_eval, 1);
rb_define_method(ip, "_cancel_eval", ip_cancel_eval, -1);
rb_define_method(ip, "_cancel_eval_unwind", ip_cancel_eval_unwind, -1);
rb_define_method(ip, "_toUTF8", ip_toUTF8, -1);
rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1);
rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1);
rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2);
rb_define_method(ip, "_invoke", ip_invoke, -1);
rb_define_method(ip, "_immediate_invoke", ip_invoke_immediate, -1);
rb_define_method(ip, "_return_value", ip_retval, 0);
rb_define_method(ip, "_create_console", ip_create_console, 0);
/* --------------------------------------------------------------- */
rb_define_method(ip, "create_dummy_encoding_for_tk",
create_dummy_encoding_for_tk, 1);
rb_define_method(ip, "encoding_table", ip_get_encoding_table, 0);
/* --------------------------------------------------------------- */
rb_define_method(ip, "_get_variable", ip_get_variable, 2);
rb_define_method(ip, "_get_variable2", ip_get_variable2, 3);
rb_define_method(ip, "_set_variable", ip_set_variable, 3);
rb_define_method(ip, "_set_variable2", ip_set_variable2, 4);
rb_define_method(ip, "_unset_variable", ip_unset_variable, 2);
rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3);
rb_define_method(ip, "_get_global_var", ip_get_global_var, 1);
rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2);
rb_define_method(ip, "_set_global_var", ip_set_global_var, 2);
rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3);
rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1);
rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2);
/* --------------------------------------------------------------- */
rb_define_method(ip, "_make_menu_embeddable", ip_make_menu_embeddable, 1);
/* --------------------------------------------------------------- */
rb_define_method(ip, "_split_tklist", ip_split_tklist, 1);
rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1);
rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1);
/* --------------------------------------------------------------- */
rb_define_method(ip, "mainloop", ip_mainloop, -1);
rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1);
rb_define_method(ip, "do_one_event", ip_do_one_event, -1);
rb_define_method(ip, "mainloop_abort_on_exception",
ip_evloop_abort_on_exc, 0);
rb_define_method(ip, "mainloop_abort_on_exception=",
ip_evloop_abort_on_exc_set, 1);
rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1);
rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0);
rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1);
rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0);
rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2);
rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0);
rb_define_method(ip, "set_max_block_time", set_max_block_time, 1);
rb_define_method(ip, "restart", ip_restart, 0);
/* --------------------------------------------------------------- */
eventloop_thread = Qnil;
eventloop_interp = (Tcl_Interp*)NULL;
#ifndef DEFAULT_EVENTLOOP_DEPTH
#define DEFAULT_EVENTLOOP_DEPTH 7
#endif
eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH);
RbTk_OBJ_UNTRUST(eventloop_stack);
watchdog_thread = Qnil;
rbtk_pending_exception = Qnil;
/* --------------------------------------------------------------- */
#ifdef HAVE_NATIVETHREAD
/* if ruby->nativethread-support and tcltklib->doesn't,
the following will cause link-error. */
ruby_native_thread_p();
#endif
/* --------------------------------------------------------------- */
rb_set_end_proc(lib_mark_at_exit, 0);
/* --------------------------------------------------------------- */
ret = ruby_open_tcl_dll(rb_argv0 ? RSTRING_PTR(rb_argv0) : 0);
switch(ret) {
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");
default:
rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret);
}
/* --------------------------------------------------------------- */
#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
setup_rubytkkit();
#endif
/* --------------------------------------------------------------- */
/* Tcl stub check */
tcl_stubs_check();
Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray);
Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String);
/* --------------------------------------------------------------- */
(void)call_original_exit;
}
/* eof */
![[top]](../icons/top.png){kind=icon}
![[bottom]](../icons/n_bottom.png){kind=icon}