00001
00002
00003
00004
00005
00006
00007 #define TCLTKLIB_RELEASE_DATE "2010-08-25"
00008
00009
00010 #include "ruby.h"
00011
00012 #ifdef HAVE_RUBY_ENCODING_H
00013 #include "ruby/encoding.h"
00014 #endif
00015 #ifndef RUBY_VERSION
00016 #define RUBY_VERSION "(unknown version)"
00017 #endif
00018 #ifndef RUBY_RELEASE_DATE
00019 #define RUBY_RELEASE_DATE "unknown release-date"
00020 #endif
00021
00022 #ifdef HAVE_RB_THREAD_CHECK_TRAP_PENDING
00023 static int rb_thread_critical;
00024 int rb_thread_check_trap_pending();
00025 #else
00026
00027 #include "rubysig.h"
00028 #define rb_thread_check_trap_pending() (0+rb_trap_pending)
00029 #endif
00030
00031 #if !defined(RSTRING_PTR)
00032 #define RSTRING_PTR(s) (RSTRING(s)->ptr)
00033 #define RSTRING_LEN(s) (RSTRING(s)->len)
00034 #endif
00035 #if !defined(RSTRING_LENINT)
00036 #define RSTRING_LENINT(s) ((int)RSTRING_LEN(s))
00037 #endif
00038 #if !defined(RARRAY_PTR)
00039 #define RARRAY_PTR(s) (RARRAY(s)->ptr)
00040 #define RARRAY_LEN(s) (RARRAY(s)->len)
00041 #endif
00042
00043 #ifdef OBJ_UNTRUST
00044 #define RbTk_OBJ_UNTRUST(x) do {OBJ_TAINT(x); OBJ_UNTRUST(x);} while (0)
00045 #else
00046 #define RbTk_OBJ_UNTRUST(x) OBJ_TAINT(x)
00047 #endif
00048 #define RbTk_ALLOC_N(type, n) (type *)ckalloc((int)(sizeof(type) * (n)))
00049
00050 #if defined(HAVE_RB_PROC_NEW) && !defined(RUBY_VM)
00051
00052 extern VALUE rb_proc_new _((VALUE (*)(ANYARGS), VALUE));
00053 #endif
00054
00055 #undef EXTERN
00056 #include <stdio.h>
00057 #ifdef HAVE_STDARG_PROTOTYPES
00058 #include <stdarg.h>
00059 #define va_init_list(a,b) va_start(a,b)
00060 #else
00061 #include <varargs.h>
00062 #define va_init_list(a,b) va_start(a)
00063 #endif
00064 #include <string.h>
00065
00066 #if !defined HAVE_VSNPRINTF && !defined vsnprintf
00067 # ifdef WIN32
00068
00069 # define vsnprintf _vsnprintf
00070 # else
00071 # ifdef HAVE_RUBY_RUBY_H
00072 # include "ruby/missing.h"
00073 # else
00074 # include "missing.h"
00075 # endif
00076 # endif
00077 #endif
00078
00079 #include <tcl.h>
00080 #include <tk.h>
00081
00082 #ifndef HAVE_RUBY_NATIVE_THREAD_P
00083 #define ruby_native_thread_p() is_ruby_native_thread()
00084 #undef RUBY_USE_NATIVE_THREAD
00085 #else
00086 #define RUBY_USE_NATIVE_THREAD 1
00087 #endif
00088
00089 #ifndef HAVE_RB_ERRINFO
00090 #define rb_errinfo() (ruby_errinfo+0)
00091 #else
00092 VALUE rb_errinfo(void);
00093 #endif
00094 #ifndef HAVE_RB_SAFE_LEVEL
00095 #define rb_safe_level() (ruby_safe_level+0)
00096 #endif
00097 #ifndef HAVE_RB_SOURCEFILE
00098 #define rb_sourcefile() (ruby_sourcefile+0)
00099 #endif
00100
00101 #include "stubs.h"
00102
00103 #ifndef TCL_ALPHA_RELEASE
00104 #define TCL_ALPHA_RELEASE 0
00105 #define TCL_BETA_RELEASE 1
00106 #define TCL_FINAL_RELEASE 2
00107 #endif
00108
00109 static struct {
00110 int major;
00111 int minor;
00112 int type;
00113 int patchlevel;
00114 } tcltk_version = {0, 0, 0, 0};
00115
00116 static void
00117 set_tcltk_version()
00118 {
00119 if (tcltk_version.major) return;
00120
00121 Tcl_GetVersion(&(tcltk_version.major),
00122 &(tcltk_version.minor),
00123 &(tcltk_version.patchlevel),
00124 &(tcltk_version.type));
00125 }
00126
00127 #if TCL_MAJOR_VERSION >= 8
00128 # ifndef CONST84
00129 # if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4
00130 # define CONST84
00131 # else
00132 # ifdef CONST
00133 # define CONST84 CONST
00134 # else
00135 # define CONST84
00136 # endif
00137 # endif
00138 # endif
00139 #else
00140 # ifdef CONST
00141 # define CONST84 CONST
00142 # else
00143 # define CONST
00144 # define CONST84
00145 # endif
00146 #endif
00147
00148 #ifndef CONST86
00149 # if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 5
00150 # define CONST86
00151 # else
00152 # define CONST86 CONST84
00153 # endif
00154 #endif
00155
00156
00157 #define TAG_RETURN 0x1
00158 #define TAG_BREAK 0x2
00159 #define TAG_NEXT 0x3
00160 #define TAG_RETRY 0x4
00161 #define TAG_REDO 0x5
00162 #define TAG_RAISE 0x6
00163 #define TAG_THROW 0x7
00164 #define TAG_FATAL 0x8
00165
00166
00167 #define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); }
00168 #define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
00169 fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); }
00170 #define DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
00171 fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); }
00172
00173
00174
00175
00176
00177
00178
00179 static const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE;
00180
00181
00182 static const char finalize_hook_name[] = "INTERP_FINALIZE_HOOK";
00183
00184 static void ip_finalize _((Tcl_Interp*));
00185
00186 static int at_exit = 0;
00187
00188 #ifdef HAVE_RUBY_ENCODING_H
00189 static VALUE cRubyEncoding;
00190
00191
00192 static int ENCODING_INDEX_UTF8;
00193 static int ENCODING_INDEX_BINARY;
00194 #endif
00195 static VALUE ENCODING_NAME_UTF8;
00196 static VALUE ENCODING_NAME_BINARY;
00197
00198 static VALUE create_dummy_encoding_for_tk_core _((VALUE, VALUE, VALUE));
00199 static VALUE create_dummy_encoding_for_tk _((VALUE, VALUE));
00200 static int update_encoding_table _((VALUE, VALUE, VALUE));
00201 static VALUE encoding_table_get_name_core _((VALUE, VALUE, VALUE));
00202 static VALUE encoding_table_get_obj_core _((VALUE, VALUE, VALUE));
00203 static VALUE encoding_table_get_name _((VALUE, VALUE));
00204 static VALUE encoding_table_get_obj _((VALUE, VALUE));
00205 static VALUE create_encoding_table _((VALUE));
00206 static VALUE ip_get_encoding_table _((VALUE));
00207
00208
00209
00210 static VALUE eTkCallbackReturn;
00211 static VALUE eTkCallbackBreak;
00212 static VALUE eTkCallbackContinue;
00213
00214 static VALUE eLocalJumpError;
00215
00216 static VALUE eTkLocalJumpError;
00217 static VALUE eTkCallbackRetry;
00218 static VALUE eTkCallbackRedo;
00219 static VALUE eTkCallbackThrow;
00220
00221 static VALUE tcltkip_class;
00222
00223 static ID ID_at_enc;
00224 static ID ID_at_interp;
00225
00226 static ID ID_encoding_name;
00227 static ID ID_encoding_table;
00228
00229 static ID ID_stop_p;
00230 static ID ID_alive_p;
00231 static ID ID_kill;
00232 static ID ID_join;
00233 static ID ID_value;
00234
00235 static ID ID_call;
00236 static ID ID_backtrace;
00237 static ID ID_message;
00238
00239 static ID ID_at_reason;
00240 static ID ID_return;
00241 static ID ID_break;
00242 static ID ID_next;
00243
00244 static ID ID_to_s;
00245 static ID ID_inspect;
00246
00247 static VALUE ip_invoke_real _((int, VALUE*, VALUE));
00248 static VALUE ip_invoke _((int, VALUE*, VALUE));
00249 static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition));
00250 static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE));
00251 static VALUE callq_safelevel_handler _((VALUE, VALUE));
00252
00253
00254 #if TCL_MAJOR_VERSION >= 8
00255 static const char Tcl_ObjTypeName_ByteArray[] = "bytearray";
00256 static CONST86 Tcl_ObjType *Tcl_ObjType_ByteArray;
00257
00258 static const char Tcl_ObjTypeName_String[] = "string";
00259 static CONST86 Tcl_ObjType *Tcl_ObjType_String;
00260
00261 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
00262 #define IS_TCL_BYTEARRAY(obj) ((obj)->typePtr == Tcl_ObjType_ByteArray)
00263 #define IS_TCL_STRING(obj) ((obj)->typePtr == Tcl_ObjType_String)
00264 #define IS_TCL_VALID_STRING(obj) ((obj)->bytes != (char*)NULL)
00265 #endif
00266 #endif
00267
00268 #ifndef HAVE_RB_HASH_LOOKUP
00269 #define rb_hash_lookup rb_hash_aref
00270 #endif
00271
00272 #ifndef HAVE_RB_THREAD_ALIVE_P
00273 #define rb_thread_alive_p(thread) rb_funcall2((thread), ID_alive_p, 0, NULL)
00274 #endif
00275
00276
00277 static int
00278 #ifdef HAVE_PROTOTYPES
00279 tcl_eval(Tcl_Interp *interp, const char *cmd)
00280 #else
00281 tcl_eval(interp, cmd)
00282 Tcl_Interp *interp;
00283 const char *cmd;
00284 #endif
00285 {
00286 char *buf = strdup(cmd);
00287 int ret;
00288
00289 Tcl_AllowExceptions(interp);
00290 ret = Tcl_Eval(interp, buf);
00291 free(buf);
00292 return ret;
00293 }
00294
00295 #undef Tcl_Eval
00296 #define Tcl_Eval tcl_eval
00297
00298 static int
00299 #ifdef HAVE_PROTOTYPES
00300 tcl_global_eval(Tcl_Interp *interp, const char *cmd)
00301 #else
00302 tcl_global_eval(interp, cmd)
00303 Tcl_Interp *interp;
00304 const char *cmd;
00305 #endif
00306 {
00307 char *buf = strdup(cmd);
00308 int ret;
00309
00310 Tcl_AllowExceptions(interp);
00311 ret = Tcl_GlobalEval(interp, buf);
00312 free(buf);
00313 return ret;
00314 }
00315
00316 #undef Tcl_GlobalEval
00317 #define Tcl_GlobalEval tcl_global_eval
00318
00319
00320 #if TCL_MAJOR_VERSION < 8
00321 #define Tcl_IncrRefCount(obj) (1)
00322 #define Tcl_DecrRefCount(obj) (1)
00323 #endif
00324
00325
00326 #if TCL_MAJOR_VERSION < 8
00327 #define Tcl_GetStringResult(interp) ((interp)->result)
00328 #endif
00329
00330
00331 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
00332 static Tcl_Obj *
00333 Tcl_GetVar2Ex(interp, name1, name2, flags)
00334 Tcl_Interp *interp;
00335 CONST char *name1;
00336 CONST char *name2;
00337 int flags;
00338 {
00339 Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
00340
00341 nameObj1 = Tcl_NewStringObj((char*)name1, -1);
00342 Tcl_IncrRefCount(nameObj1);
00343
00344 if (name2) {
00345 nameObj2 = Tcl_NewStringObj((char*)name2, -1);
00346 Tcl_IncrRefCount(nameObj2);
00347 }
00348
00349 retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags);
00350
00351 if (name2) {
00352 Tcl_DecrRefCount(nameObj2);
00353 }
00354
00355 Tcl_DecrRefCount(nameObj1);
00356
00357 return retObj;
00358 }
00359
00360 static Tcl_Obj *
00361 Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags)
00362 Tcl_Interp *interp;
00363 CONST char *name1;
00364 CONST char *name2;
00365 Tcl_Obj *newValObj;
00366 int flags;
00367 {
00368 Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj;
00369
00370 nameObj1 = Tcl_NewStringObj((char*)name1, -1);
00371 Tcl_IncrRefCount(nameObj1);
00372
00373 if (name2) {
00374 nameObj2 = Tcl_NewStringObj((char*)name2, -1);
00375 Tcl_IncrRefCount(nameObj2);
00376 }
00377
00378 retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags);
00379
00380 if (name2) {
00381 Tcl_DecrRefCount(nameObj2);
00382 }
00383
00384 Tcl_DecrRefCount(nameObj1);
00385
00386 return retObj;
00387 }
00388 #endif
00389
00390
00391
00392 #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4)
00393 # if !defined __MINGW32__ && !defined __BORLANDC__
00394
00395
00396
00397
00398
00399 extern int matherr();
00400 int *tclDummyMathPtr = (int *) matherr;
00401 # endif
00402 #endif
00403
00404
00405
00406 struct invoke_queue {
00407 Tcl_Event ev;
00408 int argc;
00409 #if TCL_MAJOR_VERSION >= 8
00410 Tcl_Obj **argv;
00411 #else
00412 char **argv;
00413 #endif
00414 VALUE interp;
00415 int *done;
00416 int safe_level;
00417 VALUE result;
00418 VALUE thread;
00419 };
00420
00421 struct eval_queue {
00422 Tcl_Event ev;
00423 char *str;
00424 int len;
00425 VALUE interp;
00426 int *done;
00427 int safe_level;
00428 VALUE result;
00429 VALUE thread;
00430 };
00431
00432 struct call_queue {
00433 Tcl_Event ev;
00434 VALUE (*func)();
00435 int argc;
00436 VALUE *argv;
00437 VALUE interp;
00438 int *done;
00439 int safe_level;
00440 VALUE result;
00441 VALUE thread;
00442 };
00443
00444 void
00445 invoke_queue_mark(struct invoke_queue *q)
00446 {
00447 rb_gc_mark(q->interp);
00448 rb_gc_mark(q->result);
00449 rb_gc_mark(q->thread);
00450 }
00451
00452 void
00453 eval_queue_mark(struct eval_queue *q)
00454 {
00455 rb_gc_mark(q->interp);
00456 rb_gc_mark(q->result);
00457 rb_gc_mark(q->thread);
00458 }
00459
00460 void
00461 call_queue_mark(struct call_queue *q)
00462 {
00463 int i;
00464
00465 for(i = 0; i < q->argc; i++) {
00466 rb_gc_mark(q->argv[i]);
00467 }
00468
00469 rb_gc_mark(q->interp);
00470 rb_gc_mark(q->result);
00471 rb_gc_mark(q->thread);
00472 }
00473
00474
00475 static VALUE eventloop_thread;
00476 static Tcl_Interp *eventloop_interp;
00477 #ifdef RUBY_USE_NATIVE_THREAD
00478 Tcl_ThreadId tk_eventloop_thread_id;
00479 #endif
00480 static VALUE eventloop_stack;
00481 static int window_event_mode = ~0;
00482
00483 static VALUE watchdog_thread;
00484
00485 Tcl_Interp *current_interp;
00486
00487
00488
00489
00490
00491
00492
00493 #ifdef RUBY_USE_NATIVE_THREAD
00494 #define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
00495 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
00496 #define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1
00497 #else
00498 #define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1
00499 #define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0
00500 #define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0
00501 #endif
00502
00503 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
00504 static int have_rb_thread_waiting_for_value = 0;
00505 #endif
00506
00507
00508
00509
00510
00511
00512
00513
00514 #ifdef RUBY_USE_NATIVE_THREAD
00515 #define DEFAULT_EVENT_LOOP_MAX 800
00516 #define DEFAULT_NO_EVENT_TICK 10
00517 #define DEFAULT_NO_EVENT_WAIT 5
00518 #define WATCHDOG_INTERVAL 10
00519 #define DEFAULT_TIMER_TICK 0
00520 #define NO_THREAD_INTERRUPT_TIME 100
00521 #else
00522 #define DEFAULT_EVENT_LOOP_MAX 800
00523 #define DEFAULT_NO_EVENT_TICK 10
00524 #define DEFAULT_NO_EVENT_WAIT 20
00525 #define WATCHDOG_INTERVAL 10
00526 #define DEFAULT_TIMER_TICK 0
00527 #define NO_THREAD_INTERRUPT_TIME 100
00528 #endif
00529
00530 #define EVENT_HANDLER_TIMEOUT 100
00531
00532 static int event_loop_max = DEFAULT_EVENT_LOOP_MAX;
00533 static int no_event_tick = DEFAULT_NO_EVENT_TICK;
00534 static int no_event_wait = DEFAULT_NO_EVENT_WAIT;
00535 static int timer_tick = DEFAULT_TIMER_TICK;
00536 static int req_timer_tick = DEFAULT_TIMER_TICK;
00537 static int run_timer_flag = 0;
00538
00539 static int event_loop_wait_event = 0;
00540 static int event_loop_abort_on_exc = 1;
00541 static int loop_counter = 0;
00542
00543 static int check_rootwidget_flag = 0;
00544
00545
00546
00547 #if TCL_MAJOR_VERSION >= 8
00548 static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
00549 static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
00550 #else
00551 static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **));
00552 static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **));
00553 #endif
00554
00555 struct cmd_body_arg {
00556 VALUE receiver;
00557 ID method;
00558 VALUE args;
00559 };
00560
00561
00562
00563
00564 #ifndef TCL_NAMESPACE_DEBUG
00565 #define TCL_NAMESPACE_DEBUG 0
00566 #endif
00567
00568 #if TCL_NAMESPACE_DEBUG
00569
00570 #if TCL_MAJOR_VERSION >= 8
00571 EXTERN struct TclIntStubs *tclIntStubsPtr;
00572 #endif
00573
00574
00575 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5
00576
00577
00578 # ifndef Tcl_GetCurrentNamespace
00579 EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *));
00580 # endif
00581 # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
00582 # ifndef Tcl_GetCurrentNamespace
00583 # ifndef FunctionNum_of_GetCurrentNamespace
00584 #define FunctionNum_of_GetCurrentNamespace 124
00585 # endif
00586 struct DummyTclIntStubs_for_GetCurrentNamespace {
00587 int magic;
00588 struct TclIntStubHooks *hooks;
00589 void (*func[FunctionNum_of_GetCurrentNamespace])();
00590 Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *));
00591 };
00592
00593 #define Tcl_GetCurrentNamespace \
00594 (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace)
00595 # endif
00596 # endif
00597 #endif
00598
00599
00600
00601 #if TCL_MAJOR_VERSION < 8
00602 #define ip_null_namespace(interp) (0)
00603 #else
00604 #define ip_null_namespace(interp) \
00605 (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL)
00606 #endif
00607
00608
00609 #if TCL_MAJOR_VERSION < 8
00610 #define rbtk_invalid_namespace(ptr) (0)
00611 #else
00612 #define rbtk_invalid_namespace(ptr) \
00613 ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns)
00614 #endif
00615
00616
00617 #if TCL_MAJOR_VERSION >= 8
00618 # ifndef CallFrame
00619 typedef struct CallFrame {
00620 Tcl_Namespace *nsPtr;
00621 int dummy1;
00622 int dummy2;
00623 char *dummy3;
00624 struct CallFrame *callerPtr;
00625 struct CallFrame *callerVarPtr;
00626 int level;
00627 char *dummy7;
00628 char *dummy8;
00629 int dummy9;
00630 char* dummy10;
00631 } CallFrame;
00632 # endif
00633
00634 # if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
00635 EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
00636 # endif
00637 # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
00638 # ifndef TclGetFrame
00639 # ifndef FunctionNum_of_GetFrame
00640 #define FunctionNum_of_GetFrame 32
00641 # endif
00642 struct DummyTclIntStubs_for_GetFrame {
00643 int magic;
00644 struct TclIntStubHooks *hooks;
00645 void (*func[FunctionNum_of_GetFrame])();
00646 int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **));
00647 };
00648 #define TclGetFrame \
00649 (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame)
00650 # endif
00651 # endif
00652
00653 # if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
00654 EXTERN void Tcl_PopCallFrame _((Tcl_Interp *));
00655 EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
00656 # endif
00657 # if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
00658 # ifndef Tcl_PopCallFrame
00659 # ifndef FunctionNum_of_PopCallFrame
00660 #define FunctionNum_of_PopCallFrame 128
00661 # endif
00662 struct DummyTclIntStubs_for_PopCallFrame {
00663 int magic;
00664 struct TclIntStubHooks *hooks;
00665 void (*func[FunctionNum_of_PopCallFrame])();
00666 void (*tcl_PopCallFrame) _((Tcl_Interp *));
00667 int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int));
00668 };
00669
00670 #define Tcl_PopCallFrame \
00671 (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame)
00672 #define Tcl_PushCallFrame \
00673 (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame)
00674 # endif
00675 # endif
00676
00677 #else
00678 # ifndef CallFrame
00679 typedef struct CallFrame {
00680 Tcl_HashTable varTable;
00681 int level;
00682 int argc;
00683 char **argv;
00684 struct CallFrame *callerPtr;
00685 struct CallFrame *callerVarPtr;
00686 } CallFrame;
00687 # endif
00688 # ifndef Tcl_CallFrame
00689 #define Tcl_CallFrame CallFrame
00690 # endif
00691
00692 # if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED)
00693 EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **));
00694 # endif
00695
00696 # if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED)
00697 typedef struct DummyInterp {
00698 char *dummy1;
00699 char *dummy2;
00700 int dummy3;
00701 Tcl_HashTable dummy4;
00702 Tcl_HashTable dummy5;
00703 Tcl_HashTable dummy6;
00704 int numLevels;
00705 int maxNestingDepth;
00706 CallFrame *framePtr;
00707 CallFrame *varFramePtr;
00708 } DummyInterp;
00709
00710 static void
00711 Tcl_PopCallFrame(interp)
00712 Tcl_Interp *interp;
00713 {
00714 DummyInterp *iPtr = (DummyInterp*)interp;
00715 CallFrame *frame = iPtr->varFramePtr;
00716
00717
00718 iPtr->framePtr = frame.callerPtr;
00719 iPtr->varFramePtr = frame.callerVarPtr;
00720
00721 return TCL_OK;
00722 }
00723
00724
00725 #define Tcl_Namespace char
00726
00727 static int
00728 Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame)
00729 Tcl_Interp *interp;
00730 Tcl_CallFrame *framePtr;
00731 Tcl_Namespace *nsPtr;
00732 int isProcCallFrame;
00733 {
00734 DummyInterp *iPtr = (DummyInterp*)interp;
00735 CallFrame *frame = (CallFrame *)framePtr;
00736
00737
00738 Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
00739 if (iPtr->varFramePtr != NULL) {
00740 frame.level = iPtr->varFramePtr->level + 1;
00741 } else {
00742 frame.level = 1;
00743 }
00744 frame.callerPtr = iPtr->framePtr;
00745 frame.callerVarPtr = iPtr->varFramePtr;
00746 iPtr->framePtr = &frame;
00747 iPtr->varFramePtr = &frame;
00748
00749 return TCL_OK;
00750 }
00751 # endif
00752
00753 #endif
00754
00755 #endif
00756
00757
00758
00759 struct tcltkip {
00760 Tcl_Interp *ip;
00761 #if TCL_NAMESPACE_DEBUG
00762 Tcl_Namespace *default_ns;
00763 #endif
00764 #ifdef RUBY_USE_NATIVE_THREAD
00765 Tcl_ThreadId tk_thread_id;
00766 #endif
00767 int has_orig_exit;
00768 Tcl_CmdInfo orig_exit_info;
00769 int ref_count;
00770 int allow_ruby_exit;
00771 int return_value;
00772 };
00773
00774 static struct tcltkip *
00775 get_ip(self)
00776 VALUE self;
00777 {
00778 struct tcltkip *ptr;
00779
00780 Data_Get_Struct(self, struct tcltkip, ptr);
00781 if (ptr == 0) {
00782
00783 return((struct tcltkip *)NULL);
00784 }
00785 if (ptr->ip == (Tcl_Interp*)NULL) {
00786
00787 return((struct tcltkip *)NULL);
00788 }
00789 return ptr;
00790 }
00791
00792 static int
00793 deleted_ip(ptr)
00794 struct tcltkip *ptr;
00795 {
00796 if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip)
00797 #if TCL_NAMESPACE_DEBUG
00798 || rbtk_invalid_namespace(ptr)
00799 #endif
00800 ) {
00801 DUMP1("ip is deleted");
00802 return 1;
00803 }
00804 return 0;
00805 }
00806
00807
00808 static int
00809 rbtk_preserve_ip(ptr)
00810 struct tcltkip *ptr;
00811 {
00812 ptr->ref_count++;
00813 if (ptr->ip == (Tcl_Interp*)NULL) {
00814
00815 ptr->ref_count = 0;
00816 } else {
00817 Tcl_Preserve((ClientData)ptr->ip);
00818 }
00819 return(ptr->ref_count);
00820 }
00821
00822 static int
00823 rbtk_release_ip(ptr)
00824 struct tcltkip *ptr;
00825 {
00826 ptr->ref_count--;
00827 if (ptr->ref_count < 0) {
00828 ptr->ref_count = 0;
00829 } else if (ptr->ip == (Tcl_Interp*)NULL) {
00830
00831 ptr->ref_count = 0;
00832 } else {
00833 Tcl_Release((ClientData)ptr->ip);
00834 }
00835 return(ptr->ref_count);
00836 }
00837
00838
00839 static VALUE
00840 #ifdef HAVE_STDARG_PROTOTYPES
00841 create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
00842 #else
00843 create_ip_exc(interp, exc, fmt, va_alist)
00844 VALUE interp:
00845 VALUE exc;
00846 const char *fmt;
00847 va_dcl
00848 #endif
00849 {
00850 va_list args;
00851 VALUE msg;
00852 VALUE einfo;
00853 struct tcltkip *ptr = get_ip(interp);
00854
00855 va_init_list(args,fmt);
00856 msg = rb_vsprintf(fmt, args);
00857 va_end(args);
00858 einfo = rb_exc_new_str(exc, msg);
00859 rb_ivar_set(einfo, ID_at_interp, interp);
00860 if (ptr) {
00861 Tcl_ResetResult(ptr->ip);
00862 }
00863
00864 return einfo;
00865 }
00866
00867
00868
00869 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
00870
00871
00872
00873 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 84
00874 #error Ruby/Tk-Kit requires Tcl/Tk8.4 or later.
00875 #endif
00876
00877
00878
00879
00880
00881
00882
00883
00884
00885
00886
00887
00888
00889
00890
00891
00892
00893
00894 #if defined USE_TCL_STUBS || defined USE_TK_STUBS
00895 # error Not support Tcl/Tk stubs with Ruby/Tk-Kit or Rubykit.
00896 #endif
00897
00898 #ifndef KIT_INCLUDES_ZLIB
00899 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
00900 #define KIT_INCLUDES_ZLIB 1
00901 #else
00902 #define KIT_INCLUDES_ZLIB 0
00903 #endif
00904 #endif
00905
00906 #ifdef _WIN32
00907 #define WIN32_LEAN_AND_MEAN
00908 #include <windows.h>
00909 #undef WIN32_LEAN_AND_MEAN
00910 #endif
00911
00912 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
00913 EXTERN Tcl_Obj* TclGetStartupScriptPath();
00914 EXTERN void TclSetStartupScriptPath _((Tcl_Obj*));
00915 #define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath()
00916 #define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path)
00917 #endif
00918 #if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED)
00919 EXTERN char* TclSetPreInitScript _((char *));
00920 #endif
00921
00922 #ifndef KIT_INCLUDES_TK
00923 # define KIT_INCLUDES_TK 1
00924 #endif
00925
00926
00927
00928 Tcl_AppInitProc Vfs_Init, Rechan_Init;
00929 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
00930 Tcl_AppInitProc Pwb_Init;
00931 #endif
00932
00933 #ifdef KIT_LITE
00934 Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit;
00935 #else
00936 Tcl_AppInitProc Mk4tcl_Init;
00937 #endif
00938
00939 #if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
00940 Tcl_AppInitProc Thread_Init;
00941 #endif
00942
00943 #if KIT_INCLUDES_ZLIB
00944 Tcl_AppInitProc Zlib_Init;
00945 #endif
00946
00947 #ifdef KIT_INCLUDES_ITCL
00948 Tcl_AppInitProc Itcl_Init;
00949 #endif
00950
00951 #ifdef _WIN32
00952 Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init;
00953 #endif
00954
00955
00956
00957 #define RUBYTK_KITPATH_CONST_NAME "RUBYTK_KITPATH"
00958
00959 static char *rubytk_kitpath = NULL;
00960
00961 static char rubytkkit_preInitCmd[] =
00962 "proc tclKitPreInit {} {\n"
00963 "rename tclKitPreInit {}\n"
00964 "load {} rubytk_kitpath\n"
00965 #if KIT_INCLUDES_ZLIB
00966 "catch {load {} zlib}\n"
00967 #endif
00968 #ifdef KIT_LITE
00969 "load {} vlerq\n"
00970 "namespace eval ::vlerq {}\n"
00971 "if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n"
00972 "set n -1\n"
00973 "} else {\n"
00974 "set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n"
00975 "set n [lsearch [vlerq get $files * name] boot.tcl]\n"
00976 "}\n"
00977 "if {$n >= 0} {\n"
00978 "array set a [vlerq get $files $n]\n"
00979 #else
00980 "load {} Mk4tcl\n"
00981 #if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT
00982
00983 "mk::file open exe $::tcl::kitpath\n"
00984 #else
00985 "mk::file open exe $::tcl::kitpath -readonly\n"
00986 #endif
00987 "set n [mk::select exe.dirs!0.files name boot.tcl]\n"
00988 "if {[llength $n] == 1} {\n"
00989 "array set a [mk::get exe.dirs!0.files!$n]\n"
00990 #endif
00991 "if {![info exists a(contents)]} { error {no boot.tcl file} }\n"
00992 "if {$a(size) != [string length $a(contents)]} {\n"
00993 "set a(contents) [zlib decompress $a(contents)]\n"
00994 "}\n"
00995 "if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n"
00996 "uplevel #0 $a(contents)\n"
00997 #if 0
00998 "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n"
00999 "uplevel #0 { source [lindex $::argv 1] }\n"
01000 "exit\n"
01001 #endif
01002 "} else {\n"
01003
01004 "set vfsdir \"[file rootname $::tcl::kitpath].vfs\"\n"
01005 "if {[file isdirectory $vfsdir]} {\n"
01006 "set ::tcl_library [file join $vfsdir lib tcl$::tcl_version]\n"
01007 "set ::tcl_libPath [list $::tcl_library [file join $vfsdir lib]]\n"
01008 "catch {uplevel #0 [list source [file join $vfsdir config.tcl]]}\n"
01009 "uplevel #0 [list source [file join $::tcl_library init.tcl]]\n"
01010 "set ::auto_path $::tcl_libPath\n"
01011 "} else {\n"
01012 "error \"\n $::tcl::kitpath has no VFS data to start up\"\n"
01013 "}\n"
01014 "}\n"
01015 "}\n"
01016 "tclKitPreInit"
01017 ;
01018
01019 #if 0
01020
01021
01022 static const char initScript[] =
01023 "if {[file isfile [file join $::tcl::kitpath main.tcl]]} {\n"
01024 "if {[info commands console] != {}} { console hide }\n"
01025 "set tcl_interactive 0\n"
01026 "incr argc\n"
01027 "set argv [linsert $argv 0 $argv0]\n"
01028 "set argv0 [file join $::tcl::kitpath main.tcl]\n"
01029 "} else continue\n"
01030 ;
01031 #endif
01032
01033
01034
01035 static char*
01036 set_rubytk_kitpath(const char *kitpath)
01037 {
01038 if (kitpath) {
01039 int len = (int)strlen(kitpath);
01040 if (rubytk_kitpath) {
01041 ckfree(rubytk_kitpath);
01042 }
01043
01044 rubytk_kitpath = (char *)ckalloc(len + 1);
01045 memcpy(rubytk_kitpath, kitpath, len);
01046 rubytk_kitpath[len] = '\0';
01047 }
01048 return rubytk_kitpath;
01049 }
01050
01051
01052
01053 #ifdef WIN32
01054 #define DEV_NULL "NUL"
01055 #else
01056 #define DEV_NULL "/dev/null"
01057 #endif
01058
01059 static void
01060 check_tclkit_std_channels()
01061 {
01062 Tcl_Channel chan;
01063
01064
01065
01066
01067
01068
01069 chan = Tcl_GetStdChannel(TCL_STDIN);
01070 if (chan == NULL) {
01071 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0);
01072 if (chan != NULL) {
01073 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
01074 }
01075 Tcl_SetStdChannel(chan, TCL_STDIN);
01076 }
01077 chan = Tcl_GetStdChannel(TCL_STDOUT);
01078 if (chan == NULL) {
01079 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
01080 if (chan != NULL) {
01081 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
01082 }
01083 Tcl_SetStdChannel(chan, TCL_STDOUT);
01084 }
01085 chan = Tcl_GetStdChannel(TCL_STDERR);
01086 if (chan == NULL) {
01087 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
01088 if (chan != NULL) {
01089 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
01090 }
01091 Tcl_SetStdChannel(chan, TCL_STDERR);
01092 }
01093 }
01094
01095
01096
01097 static int
01098 rubytk_kitpathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
01099 {
01100 const char* str;
01101 if (objc == 2) {
01102 set_rubytk_kitpath(Tcl_GetString(objv[1]));
01103 } else if (objc > 2) {
01104 Tcl_WrongNumArgs(interp, 1, objv, "?path?");
01105 }
01106 str = rubytk_kitpath ? rubytk_kitpath : Tcl_GetNameOfExecutable();
01107 Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1));
01108 return TCL_OK;
01109 }
01110
01111
01112
01113
01114
01115 static int
01116 rubytk_kitpath_init(Tcl_Interp *interp)
01117 {
01118 Tcl_CreateObjCommand(interp, "::tcl::kitpath", rubytk_kitpathObjCmd, 0, 0);
01119 if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &rubytk_kitpath,
01120 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
01121 Tcl_ResetResult(interp);
01122 }
01123
01124 Tcl_CreateObjCommand(interp, "::tcl::rubytk_kitpath", rubytk_kitpathObjCmd, 0, 0);
01125 if (Tcl_LinkVar(interp, "::tcl::rubytk_kitpath", (char *) &rubytk_kitpath,
01126 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) {
01127 Tcl_ResetResult(interp);
01128 }
01129
01130 if (rubytk_kitpath == NULL) {
01131
01132
01133
01134
01135 set_rubytk_kitpath(Tcl_GetNameOfExecutable());
01136 }
01137
01138 return Tcl_PkgProvide(interp, "rubytk_kitpath", "1.0");
01139 }
01140
01141
01142
01143 static void
01144 init_static_tcltk_packages()
01145 {
01146
01147
01148
01149 check_tclkit_std_channels();
01150
01151 #ifdef KIT_INCLUDES_ITCL
01152 Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
01153 #endif
01154 #ifdef KIT_LITE
01155 Tcl_StaticPackage(0, "Vlerq", Vlerq_Init, Vlerq_SafeInit);
01156 #else
01157 Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
01158 #endif
01159 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
01160 Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
01161 #endif
01162 Tcl_StaticPackage(0, "rubytk_kitpath", rubytk_kitpath_init, NULL);
01163 Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
01164 Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
01165 #if KIT_INCLUDES_ZLIB
01166 Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
01167 #endif
01168 #if defined TCL_THREADS && defined KIT_INCLUDES_THREAD
01169 Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit);
01170 #endif
01171 #ifdef _WIN32
01172 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
01173 Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit);
01174 #else
01175 Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
01176 #endif
01177 Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
01178 #endif
01179 #ifdef KIT_INCLUDES_TK
01180 Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
01181 #endif
01182 }
01183
01184
01185
01186 static int
01187 call_tclkit_init_script(Tcl_Interp *interp)
01188 {
01189 #if 0
01190
01191
01192
01193 if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) {
01194 const char *encoding = NULL;
01195 Tcl_Obj* path = Tcl_GetStartupScript(&encoding);
01196 Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding);
01197 if (path == NULL) {
01198 Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
01199 }
01200 }
01201 #endif
01202
01203 return 1;
01204 }
01205
01206
01207
01208 #ifdef __WIN32__
01209
01210
01211
01212 EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance);
01213 void rbtk_win32_SetHINSTANCE(const char *module_name)
01214 {
01215
01216 HINSTANCE hInst;
01217
01218
01219
01220 hInst = GetModuleHandle(module_name);
01221 TkWinSetHINSTANCE(hInst);
01222
01223
01224
01225 }
01226 #endif
01227
01228
01229
01230 static void
01231 setup_rubytkkit()
01232 {
01233 init_static_tcltk_packages();
01234
01235 {
01236 ID const_id;
01237 const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME);
01238
01239 if (rb_const_defined(rb_cObject, const_id)) {
01240 volatile VALUE pathobj;
01241 pathobj = rb_const_get(rb_cObject, const_id);
01242
01243 if (rb_obj_is_kind_of(pathobj, rb_cString)) {
01244 #ifdef HAVE_RUBY_ENCODING_H
01245 pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding());
01246 #endif
01247 set_rubytk_kitpath(RSTRING_PTR(pathobj));
01248 }
01249 }
01250 }
01251
01252 #ifdef CREATE_RUBYTK_KIT
01253 if (rubytk_kitpath == NULL) {
01254 #ifdef __WIN32__
01255
01256 {
01257 volatile VALUE basename;
01258 basename = rb_funcall(rb_cFile, rb_intern("basename"), 1,
01259 rb_str_new2(rb_sourcefile()));
01260 rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename));
01261 }
01262 #endif
01263 set_rubytk_kitpath(rb_sourcefile());
01264 }
01265 #endif
01266
01267 if (rubytk_kitpath == NULL) {
01268 set_rubytk_kitpath(Tcl_GetNameOfExecutable());
01269 }
01270
01271 TclSetPreInitScript(rubytkkit_preInitCmd);
01272 }
01273
01274
01275
01276 #endif
01277
01278
01279
01280
01281
01282
01283 static void
01284 tcl_stubs_check()
01285 {
01286 if (!tcl_stubs_init_p()) {
01287 int st = ruby_tcl_stubs_init();
01288 switch(st) {
01289 case TCLTK_STUBS_OK:
01290 break;
01291 case NO_TCL_DLL:
01292 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
01293 case NO_FindExecutable:
01294 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
01295 case NO_CreateInterp:
01296 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
01297 case NO_DeleteInterp:
01298 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
01299 case FAIL_CreateInterp:
01300 rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()");
01301 case FAIL_Tcl_InitStubs:
01302 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
01303 default:
01304 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st);
01305 }
01306 }
01307 }
01308
01309
01310 static VALUE
01311 tcltkip_init_tk(interp)
01312 VALUE interp;
01313 {
01314 struct tcltkip *ptr = get_ip(interp);
01315
01316 #if TCL_MAJOR_VERSION >= 8
01317 int st;
01318
01319 if (Tcl_IsSafe(ptr->ip)) {
01320 DUMP1("Tk_SafeInit");
01321 st = ruby_tk_stubs_safeinit(ptr->ip);
01322 switch(st) {
01323 case TCLTK_STUBS_OK:
01324 break;
01325 case NO_Tk_Init:
01326 return rb_exc_new2(rb_eLoadError,
01327 "tcltklib: can't find Tk_SafeInit()");
01328 case FAIL_Tk_Init:
01329 return create_ip_exc(interp, rb_eRuntimeError,
01330 "tcltklib: fail to Tk_SafeInit(). %s",
01331 Tcl_GetStringResult(ptr->ip));
01332 case FAIL_Tk_InitStubs:
01333 return create_ip_exc(interp, rb_eRuntimeError,
01334 "tcltklib: fail to Tk_InitStubs(). %s",
01335 Tcl_GetStringResult(ptr->ip));
01336 default:
01337 return create_ip_exc(interp, rb_eRuntimeError,
01338 "tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st);
01339 }
01340 } else {
01341 DUMP1("Tk_Init");
01342 st = ruby_tk_stubs_init(ptr->ip);
01343 switch(st) {
01344 case TCLTK_STUBS_OK:
01345 break;
01346 case NO_Tk_Init:
01347 return rb_exc_new2(rb_eLoadError,
01348 "tcltklib: can't find Tk_Init()");
01349 case FAIL_Tk_Init:
01350 return create_ip_exc(interp, rb_eRuntimeError,
01351 "tcltklib: fail to Tk_Init(). %s",
01352 Tcl_GetStringResult(ptr->ip));
01353 case FAIL_Tk_InitStubs:
01354 return create_ip_exc(interp, rb_eRuntimeError,
01355 "tcltklib: fail to Tk_InitStubs(). %s",
01356 Tcl_GetStringResult(ptr->ip));
01357 default:
01358 return create_ip_exc(interp, rb_eRuntimeError,
01359 "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
01360 }
01361 }
01362
01363 #else
01364 DUMP1("Tk_Init");
01365 if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) {
01366 return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
01367 }
01368 #endif
01369
01370 #ifdef RUBY_USE_NATIVE_THREAD
01371 ptr->tk_thread_id = Tcl_GetCurrentThread();
01372 #endif
01373
01374 return Qnil;
01375 }
01376
01377
01378
01379 static VALUE rbtk_pending_exception;
01380 static int rbtk_eventloop_depth = 0;
01381 static int rbtk_internal_eventloop_handler = 0;
01382
01383
01384 static int
01385 pending_exception_check0()
01386 {
01387 volatile VALUE exc = rbtk_pending_exception;
01388
01389 if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
01390 DUMP1("find a pending exception");
01391 if (rbtk_eventloop_depth > 0
01392 || rbtk_internal_eventloop_handler > 0
01393 ) {
01394 return 1;
01395 } else {
01396 rbtk_pending_exception = Qnil;
01397
01398 if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
01399 DUMP1("pending_exception_check0: call rb_jump_tag(retry)");
01400 rb_jump_tag(TAG_RETRY);
01401 } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
01402 DUMP1("pending_exception_check0: call rb_jump_tag(redo)");
01403 rb_jump_tag(TAG_REDO);
01404 } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
01405 DUMP1("pending_exception_check0: call rb_jump_tag(throw)");
01406 rb_jump_tag(TAG_THROW);
01407 }
01408
01409 rb_exc_raise(exc);
01410 }
01411 } else {
01412 return 0;
01413 }
01414
01415 UNREACHABLE;
01416 }
01417
01418 static int
01419 pending_exception_check1(thr_crit_bup, ptr)
01420 int thr_crit_bup;
01421 struct tcltkip *ptr;
01422 {
01423 volatile VALUE exc = rbtk_pending_exception;
01424
01425 if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) {
01426 DUMP1("find a pending exception");
01427
01428 if (rbtk_eventloop_depth > 0
01429 || rbtk_internal_eventloop_handler > 0
01430 ) {
01431 return 1;
01432 } else {
01433 rbtk_pending_exception = Qnil;
01434
01435 if (ptr != (struct tcltkip *)NULL) {
01436
01437 rbtk_release_ip(ptr);
01438 }
01439
01440 rb_thread_critical = thr_crit_bup;
01441
01442 if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) {
01443 DUMP1("pending_exception_check1: call rb_jump_tag(retry)");
01444 rb_jump_tag(TAG_RETRY);
01445 } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) {
01446 DUMP1("pending_exception_check1: call rb_jump_tag(redo)");
01447 rb_jump_tag(TAG_REDO);
01448 } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) {
01449 DUMP1("pending_exception_check1: call rb_jump_tag(throw)");
01450 rb_jump_tag(TAG_THROW);
01451 }
01452 rb_exc_raise(exc);
01453 }
01454 } else {
01455 return 0;
01456 }
01457
01458 UNREACHABLE;
01459 }
01460
01461
01462
01463 static void
01464 call_original_exit(ptr, state)
01465 struct tcltkip *ptr;
01466 int state;
01467 {
01468 int thr_crit_bup;
01469 Tcl_CmdInfo *info;
01470 #if TCL_MAJOR_VERSION >= 8
01471 Tcl_Obj *cmd_obj;
01472 Tcl_Obj *state_obj;
01473 #endif
01474 DUMP1("original_exit is called");
01475
01476 if (!(ptr->has_orig_exit)) return;
01477
01478 thr_crit_bup = rb_thread_critical;
01479 rb_thread_critical = Qtrue;
01480
01481 Tcl_ResetResult(ptr->ip);
01482
01483 info = &(ptr->orig_exit_info);
01484
01485
01486 #if TCL_MAJOR_VERSION >= 8
01487 state_obj = Tcl_NewIntObj(state);
01488 Tcl_IncrRefCount(state_obj);
01489
01490 if (info->isNativeObjectProc) {
01491 Tcl_Obj **argv;
01492 #define USE_RUBY_ALLOC 0
01493 #if USE_RUBY_ALLOC
01494 argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3);
01495 #else
01496 argv = RbTk_ALLOC_N(Tcl_Obj *, 3);
01497 #if 0
01498 Tcl_Preserve((ClientData)argv);
01499 #endif
01500 #endif
01501 cmd_obj = Tcl_NewStringObj("exit", 4);
01502 Tcl_IncrRefCount(cmd_obj);
01503
01504 argv[0] = cmd_obj;
01505 argv[1] = state_obj;
01506 argv[2] = (Tcl_Obj *)NULL;
01507
01508 ptr->return_value
01509 = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv);
01510
01511 Tcl_DecrRefCount(cmd_obj);
01512
01513 #if USE_RUBY_ALLOC
01514 xfree(argv);
01515 #else
01516 #if 0
01517 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
01518 #else
01519 #if 0
01520 Tcl_Release((ClientData)argv);
01521 #else
01522
01523 ckfree((char*)argv);
01524 #endif
01525 #endif
01526 #endif
01527 #undef USE_RUBY_ALLOC
01528
01529 } else {
01530
01531 CONST84 char **argv;
01532 #define USE_RUBY_ALLOC 0
01533 #if USE_RUBY_ALLOC
01534 argv = ALLOC_N(char *, 3);
01535 #else
01536 argv = RbTk_ALLOC_N(CONST84 char *, 3);
01537 #if 0
01538 Tcl_Preserve((ClientData)argv);
01539 #endif
01540 #endif
01541 argv[0] = (char *)"exit";
01542
01543 argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL);
01544 argv[2] = (char *)NULL;
01545
01546 ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv);
01547
01548 #if USE_RUBY_ALLOC
01549 xfree(argv);
01550 #else
01551 #if 0
01552 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
01553 #else
01554 #if 0
01555 Tcl_Release((ClientData)argv);
01556 #else
01557
01558 ckfree((char*)argv);
01559 #endif
01560 #endif
01561 #endif
01562 #undef USE_RUBY_ALLOC
01563 }
01564
01565 Tcl_DecrRefCount(state_obj);
01566
01567 #else
01568 {
01569
01570 char **argv;
01571 #define USE_RUBY_ALLOC 0
01572 #if USE_RUBY_ALLOC
01573 argv = (char **)ALLOC_N(char *, 3);
01574 #else
01575 argv = RbTk_ALLOC_N(char *, 3);
01576 #if 0
01577 Tcl_Preserve((ClientData)argv);
01578 #endif
01579 #endif
01580 argv[0] = "exit";
01581 argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10));
01582 argv[2] = (char *)NULL;
01583
01584 ptr->return_value = (*(info->proc))(info->clientData, ptr->ip,
01585 2, argv);
01586
01587 #if USE_RUBY_ALLOC
01588 xfree(argv);
01589 #else
01590 #if 0
01591 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
01592 #else
01593 #if 0
01594 Tcl_Release((ClientData)argv);
01595 #else
01596
01597 ckfree(argv);
01598 #endif
01599 #endif
01600 #endif
01601 #undef USE_RUBY_ALLOC
01602 }
01603 #endif
01604 DUMP1("complete original_exit");
01605
01606 rb_thread_critical = thr_crit_bup;
01607 }
01608
01609
01610 static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL;
01611
01612
01613 static void _timer_for_tcl _((ClientData));
01614 static void
01615 _timer_for_tcl(clientData)
01616 ClientData clientData;
01617 {
01618 int thr_crit_bup;
01619
01620
01621
01622
01623 DUMP1("call _timer_for_tcl");
01624
01625 thr_crit_bup = rb_thread_critical;
01626 rb_thread_critical = Qtrue;
01627
01628 Tcl_DeleteTimerHandler(timer_token);
01629
01630 run_timer_flag = 1;
01631
01632 if (timer_tick > 0) {
01633 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
01634 (ClientData)0);
01635 } else {
01636 timer_token = (Tcl_TimerToken)NULL;
01637 }
01638
01639 rb_thread_critical = thr_crit_bup;
01640
01641
01642
01643 }
01644
01645 #ifdef RUBY_USE_NATIVE_THREAD
01646 #if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
01647 static int
01648 toggle_eventloop_window_mode_for_idle()
01649 {
01650 if (window_event_mode & TCL_IDLE_EVENTS) {
01651
01652 window_event_mode |= TCL_WINDOW_EVENTS;
01653 window_event_mode &= ~TCL_IDLE_EVENTS;
01654 return 1;
01655 } else {
01656
01657 window_event_mode |= TCL_IDLE_EVENTS;
01658 window_event_mode &= ~TCL_WINDOW_EVENTS;
01659 return 0;
01660 }
01661 }
01662 #endif
01663 #endif
01664
01665 static VALUE
01666 set_eventloop_window_mode(self, mode)
01667 VALUE self;
01668 VALUE mode;
01669 {
01670
01671 if (RTEST(mode)) {
01672 window_event_mode = ~0;
01673 } else {
01674 window_event_mode = ~TCL_WINDOW_EVENTS;
01675 }
01676
01677 return mode;
01678 }
01679
01680 static VALUE
01681 get_eventloop_window_mode(self)
01682 VALUE self;
01683 {
01684 if ( ~window_event_mode ) {
01685 return Qfalse;
01686 } else {
01687 return Qtrue;
01688 }
01689 }
01690
01691 static VALUE
01692 set_eventloop_tick(self, tick)
01693 VALUE self;
01694 VALUE tick;
01695 {
01696 int ttick = NUM2INT(tick);
01697 int thr_crit_bup;
01698
01699
01700 if (ttick < 0) {
01701 rb_raise(rb_eArgError,
01702 "timer-tick parameter must be 0 or positive number");
01703 }
01704
01705 thr_crit_bup = rb_thread_critical;
01706 rb_thread_critical = Qtrue;
01707
01708
01709 Tcl_DeleteTimerHandler(timer_token);
01710
01711 timer_tick = req_timer_tick = ttick;
01712 if (timer_tick > 0) {
01713
01714 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
01715 (ClientData)0);
01716 } else {
01717 timer_token = (Tcl_TimerToken)NULL;
01718 }
01719
01720 rb_thread_critical = thr_crit_bup;
01721
01722 return tick;
01723 }
01724
01725 static VALUE
01726 get_eventloop_tick(self)
01727 VALUE self;
01728 {
01729 return INT2NUM(timer_tick);
01730 }
01731
01732 static VALUE
01733 ip_set_eventloop_tick(self, tick)
01734 VALUE self;
01735 VALUE tick;
01736 {
01737 struct tcltkip *ptr = get_ip(self);
01738
01739
01740 if (deleted_ip(ptr)) {
01741 return get_eventloop_tick(self);
01742 }
01743
01744 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01745
01746 return get_eventloop_tick(self);
01747 }
01748 return set_eventloop_tick(self, tick);
01749 }
01750
01751 static VALUE
01752 ip_get_eventloop_tick(self)
01753 VALUE self;
01754 {
01755 return get_eventloop_tick(self);
01756 }
01757
01758 static VALUE
01759 set_no_event_wait(self, wait)
01760 VALUE self;
01761 VALUE wait;
01762 {
01763 int t_wait = NUM2INT(wait);
01764
01765
01766 if (t_wait <= 0) {
01767 rb_raise(rb_eArgError,
01768 "no_event_wait parameter must be positive number");
01769 }
01770
01771 no_event_wait = t_wait;
01772
01773 return wait;
01774 }
01775
01776 static VALUE
01777 get_no_event_wait(self)
01778 VALUE self;
01779 {
01780 return INT2NUM(no_event_wait);
01781 }
01782
01783 static VALUE
01784 ip_set_no_event_wait(self, wait)
01785 VALUE self;
01786 VALUE wait;
01787 {
01788 struct tcltkip *ptr = get_ip(self);
01789
01790
01791 if (deleted_ip(ptr)) {
01792 return get_no_event_wait(self);
01793 }
01794
01795 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01796
01797 return get_no_event_wait(self);
01798 }
01799 return set_no_event_wait(self, wait);
01800 }
01801
01802 static VALUE
01803 ip_get_no_event_wait(self)
01804 VALUE self;
01805 {
01806 return get_no_event_wait(self);
01807 }
01808
01809 static VALUE
01810 set_eventloop_weight(self, loop_max, no_event)
01811 VALUE self;
01812 VALUE loop_max;
01813 VALUE no_event;
01814 {
01815 int lpmax = NUM2INT(loop_max);
01816 int no_ev = NUM2INT(no_event);
01817
01818
01819 if (lpmax <= 0 || no_ev <= 0) {
01820 rb_raise(rb_eArgError, "weight parameters must be positive numbers");
01821 }
01822
01823 event_loop_max = lpmax;
01824 no_event_tick = no_ev;
01825
01826 return rb_ary_new3(2, loop_max, no_event);
01827 }
01828
01829 static VALUE
01830 get_eventloop_weight(self)
01831 VALUE self;
01832 {
01833 return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick));
01834 }
01835
01836 static VALUE
01837 ip_set_eventloop_weight(self, loop_max, no_event)
01838 VALUE self;
01839 VALUE loop_max;
01840 VALUE no_event;
01841 {
01842 struct tcltkip *ptr = get_ip(self);
01843
01844
01845 if (deleted_ip(ptr)) {
01846 return get_eventloop_weight(self);
01847 }
01848
01849 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01850
01851 return get_eventloop_weight(self);
01852 }
01853 return set_eventloop_weight(self, loop_max, no_event);
01854 }
01855
01856 static VALUE
01857 ip_get_eventloop_weight(self)
01858 VALUE self;
01859 {
01860 return get_eventloop_weight(self);
01861 }
01862
01863 static VALUE
01864 set_max_block_time(self, time)
01865 VALUE self;
01866 VALUE time;
01867 {
01868 struct Tcl_Time tcl_time;
01869 VALUE divmod;
01870
01871 switch(TYPE(time)) {
01872 case T_FIXNUM:
01873 case T_BIGNUM:
01874
01875 divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000));
01876 tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]);
01877 tcl_time.usec = NUM2LONG(RARRAY_PTR(divmod)[1]);
01878 break;
01879
01880 case T_FLOAT:
01881
01882 divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1));
01883 tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]);
01884 tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000);
01885
01886 default:
01887 {
01888 VALUE tmp = rb_funcall(time, ID_inspect, 0, 0);
01889 rb_raise(rb_eArgError, "invalid value for time: '%s'",
01890 StringValuePtr(tmp));
01891 }
01892 }
01893
01894 Tcl_SetMaxBlockTime(&tcl_time);
01895
01896 return Qnil;
01897 }
01898
01899 static VALUE
01900 lib_evloop_thread_p(self)
01901 VALUE self;
01902 {
01903 if (NIL_P(eventloop_thread)) {
01904 return Qnil;
01905 } else if (rb_thread_current() == eventloop_thread) {
01906 return Qtrue;
01907 } else {
01908 return Qfalse;
01909 }
01910 }
01911
01912 static VALUE
01913 lib_evloop_abort_on_exc(self)
01914 VALUE self;
01915 {
01916 if (event_loop_abort_on_exc > 0) {
01917 return Qtrue;
01918 } else if (event_loop_abort_on_exc == 0) {
01919 return Qfalse;
01920 } else {
01921 return Qnil;
01922 }
01923 }
01924
01925 static VALUE
01926 ip_evloop_abort_on_exc(self)
01927 VALUE self;
01928 {
01929 return lib_evloop_abort_on_exc(self);
01930 }
01931
01932 static VALUE
01933 lib_evloop_abort_on_exc_set(self, val)
01934 VALUE self, val;
01935 {
01936 if (RTEST(val)) {
01937 event_loop_abort_on_exc = 1;
01938 } else if (NIL_P(val)) {
01939 event_loop_abort_on_exc = -1;
01940 } else {
01941 event_loop_abort_on_exc = 0;
01942 }
01943 return lib_evloop_abort_on_exc(self);
01944 }
01945
01946 static VALUE
01947 ip_evloop_abort_on_exc_set(self, val)
01948 VALUE self, val;
01949 {
01950 struct tcltkip *ptr = get_ip(self);
01951
01952
01953
01954 if (deleted_ip(ptr)) {
01955 return lib_evloop_abort_on_exc(self);
01956 }
01957
01958 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
01959
01960 return lib_evloop_abort_on_exc(self);
01961 }
01962 return lib_evloop_abort_on_exc_set(self, val);
01963 }
01964
01965 static VALUE
01966 lib_num_of_mainwindows_core(self, argc, argv)
01967 VALUE self;
01968 int argc;
01969 VALUE *argv;
01970 {
01971 if (tk_stubs_init_p()) {
01972 return INT2FIX(Tk_GetNumMainWindows());
01973 } else {
01974 return INT2FIX(0);
01975 }
01976 }
01977
01978 static VALUE
01979 lib_num_of_mainwindows(self)
01980 VALUE self;
01981 {
01982 #ifdef RUBY_USE_NATIVE_THREAD
01983 return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self);
01984 #else
01985 return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL);
01986 #endif
01987 }
01988
01989 void
01990 rbtk_EventSetupProc(ClientData clientData, int flag)
01991 {
01992 Tcl_Time tcl_time;
01993 tcl_time.sec = 0;
01994 tcl_time.usec = 1000L * (long)no_event_tick;
01995 Tcl_SetMaxBlockTime(&tcl_time);
01996 }
01997
01998 void
01999 rbtk_EventCheckProc(ClientData clientData, int flag)
02000 {
02001 rb_thread_schedule();
02002 }
02003
02004
02005 #ifdef RUBY_USE_NATIVE_THREAD
02006 static VALUE
02007 #ifdef HAVE_PROTOTYPES
02008 call_DoOneEvent_core(VALUE flag_val)
02009 #else
02010 call_DoOneEvent_core(flag_val)
02011 VALUE flag_val;
02012 #endif
02013 {
02014 int flag;
02015
02016 flag = FIX2INT(flag_val);
02017 if (Tcl_DoOneEvent(flag)) {
02018 return Qtrue;
02019 } else {
02020 return Qfalse;
02021 }
02022 }
02023
02024 static VALUE
02025 #ifdef HAVE_PROTOTYPES
02026 call_DoOneEvent(VALUE flag_val)
02027 #else
02028 call_DoOneEvent(flag_val)
02029 VALUE flag_val;
02030 #endif
02031 {
02032 return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val);
02033 }
02034
02035 #else
02036 static VALUE
02037 #ifdef HAVE_PROTOTYPES
02038 call_DoOneEvent(VALUE flag_val)
02039 #else
02040 call_DoOneEvent(flag_val)
02041 VALUE flag_val;
02042 #endif
02043 {
02044 int flag;
02045
02046 flag = FIX2INT(flag_val);
02047 if (Tcl_DoOneEvent(flag)) {
02048 return Qtrue;
02049 } else {
02050 return Qfalse;
02051 }
02052 }
02053 #endif
02054
02055
02056 #if 0
02057 static VALUE
02058 #ifdef HAVE_PROTOTYPES
02059 eventloop_sleep(VALUE dummy)
02060 #else
02061 eventloop_sleep(dummy)
02062 VALUE dummy;
02063 #endif
02064 {
02065 struct timeval t;
02066
02067 if (no_event_wait <= 0) {
02068 return Qnil;
02069 }
02070
02071 t.tv_sec = 0;
02072 t.tv_usec = (int)(no_event_wait*1000.0);
02073
02074 #ifdef HAVE_NATIVETHREAD
02075 #ifndef RUBY_USE_NATIVE_THREAD
02076 if (!ruby_native_thread_p()) {
02077 rb_bug("cross-thread violation on eventloop_sleep()");
02078 }
02079 #endif
02080 #endif
02081
02082 DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %lx", rb_thread_current());
02083 rb_thread_wait_for(t);
02084 DUMP2("eventloop_sleep: finish at thread : %lx", rb_thread_current());
02085
02086 #ifdef HAVE_NATIVETHREAD
02087 #ifndef RUBY_USE_NATIVE_THREAD
02088 if (!ruby_native_thread_p()) {
02089 rb_bug("cross-thread violation on eventloop_sleep()");
02090 }
02091 #endif
02092 #endif
02093
02094 return Qnil;
02095 }
02096 #endif
02097
02098 #define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0
02099
02100 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02101 static int
02102 get_thread_alone_check_flag()
02103 {
02104 #ifdef RUBY_USE_NATIVE_THREAD
02105 return 0;
02106 #else
02107 set_tcltk_version();
02108
02109 if (tcltk_version.major < 8) {
02110
02111 return 1;
02112 } else if (tcltk_version.major == 8) {
02113 if (tcltk_version.minor < 5) {
02114
02115 return 1;
02116 } else if (tcltk_version.minor == 5) {
02117 if (tcltk_version.type < TCL_FINAL_RELEASE) {
02118
02119 return 1;
02120 } else {
02121
02122 return 0;
02123 }
02124 } else {
02125
02126 return 0;
02127 }
02128 } else {
02129
02130 return 0;
02131 }
02132 #endif
02133 }
02134 #endif
02135
02136 #define TRAP_CHECK() do { \
02137 if (trap_check(check_var) == 0) return 0; \
02138 } while (0)
02139
02140 static int
02141 trap_check(int *check_var)
02142 {
02143 DUMP1("trap check");
02144
02145 #ifdef RUBY_VM
02146 if (rb_thread_check_trap_pending()) {
02147 if (check_var != (int*)NULL) {
02148
02149 return 0;
02150 }
02151 else {
02152 rb_thread_check_ints();
02153 }
02154 }
02155 #else
02156 if (rb_trap_pending) {
02157 run_timer_flag = 0;
02158 if (rb_prohibit_interrupt || check_var != (int*)NULL) {
02159
02160 return 0;
02161 } else {
02162 rb_trap_exec();
02163 }
02164 }
02165 #endif
02166
02167 return 1;
02168 }
02169
02170 static int
02171 check_eventloop_interp()
02172 {
02173 DUMP1("check eventloop_interp");
02174 if (eventloop_interp != (Tcl_Interp*)NULL
02175 && Tcl_InterpDeleted(eventloop_interp)) {
02176 DUMP2("eventloop_interp(%p) was deleted", eventloop_interp);
02177 return 1;
02178 }
02179
02180 return 0;
02181 }
02182
02183 static int
02184 lib_eventloop_core(check_root, update_flag, check_var, interp)
02185 int check_root;
02186 int update_flag;
02187 int *check_var;
02188 Tcl_Interp *interp;
02189 {
02190 volatile VALUE current = eventloop_thread;
02191 int found_event = 1;
02192 int event_flag;
02193 #if 0
02194 struct timeval t;
02195 #endif
02196 int thr_crit_bup;
02197 int status;
02198 int depth = rbtk_eventloop_depth;
02199 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02200 int thread_alone_check_flag = 1;
02201 #else
02202 enum {thread_alone_check_flag = 1};
02203 #endif
02204
02205 if (update_flag) DUMP1("update loop start!!");
02206
02207 #if 0
02208 t.tv_sec = 0;
02209 t.tv_usec = 1000 * no_event_wait;
02210 #endif
02211
02212 Tcl_DeleteTimerHandler(timer_token);
02213 run_timer_flag = 0;
02214 if (timer_tick > 0) {
02215 thr_crit_bup = rb_thread_critical;
02216 rb_thread_critical = Qtrue;
02217 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl,
02218 (ClientData)0);
02219 rb_thread_critical = thr_crit_bup;
02220 } else {
02221 timer_token = (Tcl_TimerToken)NULL;
02222 }
02223
02224 #if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG
02225
02226 thread_alone_check_flag = get_thread_alone_check_flag();
02227 #endif
02228
02229 for(;;) {
02230 if (check_eventloop_interp()) return 0;
02231
02232 if (thread_alone_check_flag && rb_thread_alone()) {
02233 DUMP1("no other thread");
02234 event_loop_wait_event = 0;
02235
02236 if (update_flag) {
02237 event_flag = update_flag;
02238
02239 } else {
02240 event_flag = TCL_ALL_EVENTS;
02241
02242 }
02243
02244 if (timer_tick == 0 && update_flag == 0) {
02245 timer_tick = NO_THREAD_INTERRUPT_TIME;
02246 timer_token = Tcl_CreateTimerHandler(timer_tick,
02247 _timer_for_tcl,
02248 (ClientData)0);
02249 }
02250
02251 if (check_var != (int *)NULL) {
02252 if (*check_var || !found_event) {
02253 return found_event;
02254 }
02255 if (interp != (Tcl_Interp*)NULL
02256 && Tcl_InterpDeleted(interp)) {
02257
02258 return 0;
02259 }
02260 }
02261
02262
02263 found_event = RTEST(rb_protect(call_DoOneEvent,
02264 INT2FIX(event_flag), &status));
02265 if (status) {
02266 switch (status) {
02267 case TAG_RAISE:
02268 if (NIL_P(rb_errinfo())) {
02269 rbtk_pending_exception
02270 = rb_exc_new2(rb_eException, "unknown exception");
02271 } else {
02272 rbtk_pending_exception = rb_errinfo();
02273
02274 if (!NIL_P(rbtk_pending_exception)) {
02275 if (rbtk_eventloop_depth == 0) {
02276 VALUE exc = rbtk_pending_exception;
02277 rbtk_pending_exception = Qnil;
02278 rb_exc_raise(exc);
02279 } else {
02280 return 0;
02281 }
02282 }
02283 }
02284 break;
02285
02286 case TAG_FATAL:
02287 if (NIL_P(rb_errinfo())) {
02288 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
02289 } else {
02290 rb_exc_raise(rb_errinfo());
02291 }
02292 }
02293 }
02294
02295 if (depth != rbtk_eventloop_depth) {
02296 DUMP2("DoOneEvent(1) abnormal exit!! %d",
02297 rbtk_eventloop_depth);
02298 }
02299
02300 if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) {
02301 DUMP1("exception on wait");
02302 return 0;
02303 }
02304
02305 if (pending_exception_check0()) {
02306
02307 return 0;
02308 }
02309
02310 if (update_flag != 0) {
02311 if (found_event) {
02312 DUMP1("next update loop");
02313 continue;
02314 } else {
02315 DUMP1("update complete");
02316 return 0;
02317 }
02318 }
02319
02320 TRAP_CHECK();
02321 if (check_eventloop_interp()) return 0;
02322
02323 DUMP1("check Root Widget");
02324 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
02325 run_timer_flag = 0;
02326 TRAP_CHECK();
02327 return 1;
02328 }
02329
02330 if (loop_counter++ > 30000) {
02331
02332 loop_counter = 0;
02333 }
02334
02335 } else {
02336 int tick_counter;
02337
02338 DUMP1("there are other threads");
02339 event_loop_wait_event = 1;
02340
02341 found_event = 1;
02342
02343 if (update_flag) {
02344 event_flag = update_flag;
02345
02346 } else {
02347 event_flag = TCL_ALL_EVENTS;
02348
02349 }
02350
02351 timer_tick = req_timer_tick;
02352 tick_counter = 0;
02353 while(tick_counter < event_loop_max) {
02354 if (check_var != (int *)NULL) {
02355 if (*check_var || !found_event) {
02356 return found_event;
02357 }
02358 if (interp != (Tcl_Interp*)NULL
02359 && Tcl_InterpDeleted(interp)) {
02360
02361 return 0;
02362 }
02363 }
02364
02365 if (NIL_P(eventloop_thread) || current == eventloop_thread) {
02366 int st;
02367 int status;
02368
02369 #ifdef RUBY_USE_NATIVE_THREAD
02370 if (update_flag) {
02371 st = RTEST(rb_protect(call_DoOneEvent,
02372 INT2FIX(event_flag), &status));
02373 } else {
02374 st = RTEST(rb_protect(call_DoOneEvent,
02375 INT2FIX(event_flag & window_event_mode),
02376 &status));
02377 #if USE_TOGGLE_WINDOW_MODE_FOR_IDLE
02378 if (!st) {
02379 if (toggle_eventloop_window_mode_for_idle()) {
02380
02381 tick_counter = event_loop_max;
02382 } else {
02383
02384 tick_counter = 0;
02385 }
02386 }
02387 #endif
02388 }
02389 #else
02390
02391 st = RTEST(rb_protect(call_DoOneEvent,
02392 INT2FIX(event_flag), &status));
02393 #endif
02394
02395 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
02396 if (have_rb_thread_waiting_for_value) {
02397 have_rb_thread_waiting_for_value = 0;
02398 rb_thread_schedule();
02399 }
02400 #endif
02401
02402 if (status) {
02403 switch (status) {
02404 case TAG_RAISE:
02405 if (NIL_P(rb_errinfo())) {
02406 rbtk_pending_exception
02407 = rb_exc_new2(rb_eException,
02408 "unknown exception");
02409 } else {
02410 rbtk_pending_exception = rb_errinfo();
02411
02412 if (!NIL_P(rbtk_pending_exception)) {
02413 if (rbtk_eventloop_depth == 0) {
02414 VALUE exc = rbtk_pending_exception;
02415 rbtk_pending_exception = Qnil;
02416 rb_exc_raise(exc);
02417 } else {
02418 return 0;
02419 }
02420 }
02421 }
02422 break;
02423
02424 case TAG_FATAL:
02425 if (NIL_P(rb_errinfo())) {
02426 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL"));
02427 } else {
02428 rb_exc_raise(rb_errinfo());
02429 }
02430 }
02431 }
02432
02433 if (depth != rbtk_eventloop_depth) {
02434 DUMP2("DoOneEvent(2) abnormal exit!! %d",
02435 rbtk_eventloop_depth);
02436 return 0;
02437 }
02438
02439 TRAP_CHECK();
02440
02441 if (check_var != (int*)NULL
02442 && !NIL_P(rbtk_pending_exception)) {
02443 DUMP1("exception on wait");
02444 return 0;
02445 }
02446
02447 if (pending_exception_check0()) {
02448
02449 return 0;
02450 }
02451
02452 if (st) {
02453 tick_counter++;
02454 } else {
02455 if (update_flag != 0) {
02456 DUMP1("update complete");
02457 return 0;
02458 }
02459
02460 tick_counter += no_event_tick;
02461
02462 #if 0
02463
02464 rb_protect(eventloop_sleep, Qnil, &status);
02465
02466 if (status) {
02467 switch (status) {
02468 case TAG_RAISE:
02469 if (NIL_P(rb_errinfo())) {
02470 rbtk_pending_exception
02471 = rb_exc_new2(rb_eException,
02472 "unknown exception");
02473 } else {
02474 rbtk_pending_exception = rb_errinfo();
02475
02476 if (!NIL_P(rbtk_pending_exception)) {
02477 if (rbtk_eventloop_depth == 0) {
02478 VALUE exc = rbtk_pending_exception;
02479 rbtk_pending_exception = Qnil;
02480 rb_exc_raise(exc);
02481 } else {
02482 return 0;
02483 }
02484 }
02485 }
02486 break;
02487
02488 case TAG_FATAL:
02489 if (NIL_P(rb_errinfo())) {
02490 rb_exc_raise(rb_exc_new2(rb_eFatal,
02491 "FATAL"));
02492 } else {
02493 rb_exc_raise(rb_errinfo());
02494 }
02495 }
02496 }
02497 #endif
02498 }
02499
02500 } else {
02501 DUMP2("sleep eventloop %lx", current);
02502 DUMP2("eventloop thread is %lx", eventloop_thread);
02503
02504 rb_thread_sleep_forever();
02505 }
02506
02507 if (!NIL_P(watchdog_thread) && eventloop_thread != current) {
02508 return 1;
02509 }
02510
02511 TRAP_CHECK();
02512 if (check_eventloop_interp()) return 0;
02513
02514 DUMP1("check Root Widget");
02515 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) {
02516 run_timer_flag = 0;
02517 TRAP_CHECK();
02518 return 1;
02519 }
02520
02521 if (loop_counter++ > 30000) {
02522
02523 loop_counter = 0;
02524 }
02525
02526 if (run_timer_flag) {
02527
02528
02529
02530
02531 break;
02532 }
02533 }
02534
02535 DUMP1("thread scheduling");
02536 rb_thread_schedule();
02537 }
02538
02539 DUMP1("check interrupts");
02540 #if defined(RUBY_USE_NATIVE_THREAD) || defined(RUBY_VM)
02541 if (update_flag == 0) rb_thread_check_ints();
02542 #else
02543 if (update_flag == 0) CHECK_INTS;
02544 #endif
02545
02546 }
02547 return 1;
02548 }
02549
02550
02551 struct evloop_params {
02552 int check_root;
02553 int update_flag;
02554 int *check_var;
02555 Tcl_Interp *interp;
02556 int thr_crit_bup;
02557 };
02558
02559 VALUE
02560 lib_eventloop_main_core(args)
02561 VALUE args;
02562 {
02563 struct evloop_params *params = (struct evloop_params *)args;
02564
02565 check_rootwidget_flag = params->check_root;
02566
02567 Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
02568
02569 if (lib_eventloop_core(params->check_root,
02570 params->update_flag,
02571 params->check_var,
02572 params->interp)) {
02573 return Qtrue;
02574 } else {
02575 return Qfalse;
02576 }
02577 }
02578
02579 VALUE
02580 lib_eventloop_main(args)
02581 VALUE args;
02582 {
02583 return lib_eventloop_main_core(args);
02584
02585 #if 0
02586 volatile VALUE ret;
02587 int status = 0;
02588
02589 ret = rb_protect(lib_eventloop_main_core, args, &status);
02590
02591 switch (status) {
02592 case TAG_RAISE:
02593 if (NIL_P(rb_errinfo())) {
02594 rbtk_pending_exception
02595 = rb_exc_new2(rb_eException, "unknown exception");
02596 } else {
02597 rbtk_pending_exception = rb_errinfo();
02598 }
02599 return Qnil;
02600
02601 case TAG_FATAL:
02602 if (NIL_P(rb_errinfo())) {
02603 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
02604 } else {
02605 rbtk_pending_exception = rb_errinfo();
02606 }
02607 return Qnil;
02608 }
02609
02610 return ret;
02611 #endif
02612 }
02613
02614 VALUE
02615 lib_eventloop_ensure(args)
02616 VALUE args;
02617 {
02618 struct evloop_params *ptr = (struct evloop_params *)args;
02619 volatile VALUE current_evloop = rb_thread_current();
02620
02621 Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args);
02622
02623 DUMP2("eventloop_ensure: current-thread : %lx", current_evloop);
02624 DUMP2("eventloop_ensure: eventloop-thread : %lx", eventloop_thread);
02625 if (eventloop_thread != current_evloop) {
02626 DUMP2("finish eventloop %lx (NOT current eventloop)", current_evloop);
02627
02628 rb_thread_critical = ptr->thr_crit_bup;
02629
02630 xfree(ptr);
02631
02632
02633 return Qnil;
02634 }
02635
02636 while((eventloop_thread = rb_ary_pop(eventloop_stack))) {
02637 DUMP2("eventloop-ensure: new eventloop-thread -> %lx",
02638 eventloop_thread);
02639
02640 if (eventloop_thread == current_evloop) {
02641 rbtk_eventloop_depth--;
02642 DUMP2("eventloop %lx : back from recursive call", current_evloop);
02643 break;
02644 }
02645
02646 if (NIL_P(eventloop_thread)) {
02647 Tcl_DeleteTimerHandler(timer_token);
02648 timer_token = (Tcl_TimerToken)NULL;
02649
02650 break;
02651 }
02652
02653 if (RTEST(rb_thread_alive_p(eventloop_thread))) {
02654 DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread);
02655 rb_thread_wakeup(eventloop_thread);
02656
02657 break;
02658 }
02659 }
02660
02661 #ifdef RUBY_USE_NATIVE_THREAD
02662 if (NIL_P(eventloop_thread)) {
02663 tk_eventloop_thread_id = (Tcl_ThreadId) 0;
02664 }
02665 #endif
02666
02667 rb_thread_critical = ptr->thr_crit_bup;
02668
02669 xfree(ptr);
02670
02671
02672 DUMP2("finish current eventloop %lx", current_evloop);
02673 return Qnil;
02674 }
02675
02676 static VALUE
02677 lib_eventloop_launcher(check_root, update_flag, check_var, interp)
02678 int check_root;
02679 int update_flag;
02680 int *check_var;
02681 Tcl_Interp *interp;
02682 {
02683 volatile VALUE parent_evloop = eventloop_thread;
02684 struct evloop_params *args = ALLOC(struct evloop_params);
02685
02686
02687 tcl_stubs_check();
02688
02689 eventloop_thread = rb_thread_current();
02690 #ifdef RUBY_USE_NATIVE_THREAD
02691 tk_eventloop_thread_id = Tcl_GetCurrentThread();
02692 #endif
02693
02694 if (parent_evloop == eventloop_thread) {
02695 DUMP2("eventloop: recursive call on %lx", parent_evloop);
02696 rbtk_eventloop_depth++;
02697 }
02698
02699 if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) {
02700 DUMP2("wait for stop of parent_evloop %lx", parent_evloop);
02701 while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) {
02702 DUMP2("parent_evloop %lx doesn't stop", parent_evloop);
02703 rb_thread_run(parent_evloop);
02704 }
02705 DUMP1("succeed to stop parent");
02706 }
02707
02708 rb_ary_push(eventloop_stack, parent_evloop);
02709
02710 DUMP3("tcltklib: eventloop-thread : %lx -> %lx\n",
02711 parent_evloop, eventloop_thread);
02712
02713 args->check_root = check_root;
02714 args->update_flag = update_flag;
02715 args->check_var = check_var;
02716 args->interp = interp;
02717 args->thr_crit_bup = rb_thread_critical;
02718
02719 rb_thread_critical = Qfalse;
02720
02721 #if 0
02722 return rb_ensure(lib_eventloop_main, (VALUE)args,
02723 lib_eventloop_ensure, (VALUE)args);
02724 #endif
02725 return rb_ensure(lib_eventloop_main_core, (VALUE)args,
02726 lib_eventloop_ensure, (VALUE)args);
02727 }
02728
02729
02730 static VALUE
02731 lib_mainloop(argc, argv, self)
02732 int argc;
02733 VALUE *argv;
02734 VALUE self;
02735 {
02736 VALUE check_rootwidget;
02737
02738 if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
02739 check_rootwidget = Qtrue;
02740 } else if (RTEST(check_rootwidget)) {
02741 check_rootwidget = Qtrue;
02742 } else {
02743 check_rootwidget = Qfalse;
02744 }
02745
02746 return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
02747 (int*)NULL, (Tcl_Interp*)NULL);
02748 }
02749
02750 static VALUE
02751 ip_mainloop(argc, argv, self)
02752 int argc;
02753 VALUE *argv;
02754 VALUE self;
02755 {
02756 volatile VALUE ret;
02757 struct tcltkip *ptr = get_ip(self);
02758
02759
02760 if (deleted_ip(ptr)) {
02761 return Qnil;
02762 }
02763
02764 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
02765
02766 return Qnil;
02767 }
02768
02769 eventloop_interp = ptr->ip;
02770 ret = lib_mainloop(argc, argv, self);
02771 eventloop_interp = (Tcl_Interp*)NULL;
02772 return ret;
02773 }
02774
02775
02776 static VALUE
02777 watchdog_evloop_launcher(check_rootwidget)
02778 VALUE check_rootwidget;
02779 {
02780 return lib_eventloop_launcher(RTEST(check_rootwidget), 0,
02781 (int*)NULL, (Tcl_Interp*)NULL);
02782 }
02783
02784 #define EVLOOP_WAKEUP_CHANCE 3
02785
02786 static VALUE
02787 lib_watchdog_core(check_rootwidget)
02788 VALUE check_rootwidget;
02789 {
02790 VALUE evloop;
02791 int prev_val = -1;
02792 int chance = 0;
02793 int check = RTEST(check_rootwidget);
02794 struct timeval t0, t1;
02795
02796 t0.tv_sec = 0;
02797 t0.tv_usec = (long)((NO_THREAD_INTERRUPT_TIME)*1000.0);
02798 t1.tv_sec = 0;
02799 t1.tv_usec = (long)((WATCHDOG_INTERVAL)*1000.0);
02800
02801
02802 if (!NIL_P(watchdog_thread)) {
02803 if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) {
02804 rb_funcall(watchdog_thread, ID_kill, 0);
02805 } else {
02806 return Qnil;
02807 }
02808 }
02809 watchdog_thread = rb_thread_current();
02810
02811
02812 do {
02813 if (NIL_P(eventloop_thread)
02814 || (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) {
02815
02816 DUMP2("eventloop thread %lx is sleeping or dead",
02817 eventloop_thread);
02818 evloop = rb_thread_create(watchdog_evloop_launcher,
02819 (void*)&check_rootwidget);
02820 DUMP2("create new eventloop thread %lx", evloop);
02821 loop_counter = -1;
02822 chance = 0;
02823 rb_thread_run(evloop);
02824 } else {
02825 prev_val = loop_counter;
02826 if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) {
02827 ++chance;
02828 } else {
02829 chance = 0;
02830 }
02831 if (event_loop_wait_event) {
02832 rb_thread_wait_for(t0);
02833 } else {
02834 rb_thread_wait_for(t1);
02835 }
02836
02837 }
02838 } while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0);
02839
02840 return Qnil;
02841 }
02842
02843 VALUE
02844 lib_watchdog_ensure(arg)
02845 VALUE arg;
02846 {
02847 eventloop_thread = Qnil;
02848 #ifdef RUBY_USE_NATIVE_THREAD
02849 tk_eventloop_thread_id = (Tcl_ThreadId) 0;
02850 #endif
02851 return Qnil;
02852 }
02853
02854 static VALUE
02855 lib_mainloop_watchdog(argc, argv, self)
02856 int argc;
02857 VALUE *argv;
02858 VALUE self;
02859 {
02860 VALUE check_rootwidget;
02861
02862 #ifdef RUBY_VM
02863 rb_raise(rb_eNotImpError,
02864 "eventloop_watchdog is not implemented on Ruby VM.");
02865 #endif
02866
02867 if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
02868 check_rootwidget = Qtrue;
02869 } else if (RTEST(check_rootwidget)) {
02870 check_rootwidget = Qtrue;
02871 } else {
02872 check_rootwidget = Qfalse;
02873 }
02874
02875 return rb_ensure(lib_watchdog_core, check_rootwidget,
02876 lib_watchdog_ensure, Qnil);
02877 }
02878
02879 static VALUE
02880 ip_mainloop_watchdog(argc, argv, self)
02881 int argc;
02882 VALUE *argv;
02883 VALUE self;
02884 {
02885 struct tcltkip *ptr = get_ip(self);
02886
02887
02888 if (deleted_ip(ptr)) {
02889 return Qnil;
02890 }
02891
02892 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
02893
02894 return Qnil;
02895 }
02896 return lib_mainloop_watchdog(argc, argv, self);
02897 }
02898
02899
02900
02901 struct thread_call_proc_arg {
02902 VALUE proc;
02903 int *done;
02904 };
02905
02906 void
02907 _thread_call_proc_arg_mark(struct thread_call_proc_arg *q)
02908 {
02909 rb_gc_mark(q->proc);
02910 }
02911
02912 static VALUE
02913 _thread_call_proc_core(arg)
02914 VALUE arg;
02915 {
02916 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
02917 return rb_funcall(q->proc, ID_call, 0);
02918 }
02919
02920 static VALUE
02921 _thread_call_proc_ensure(arg)
02922 VALUE arg;
02923 {
02924 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
02925 *(q->done) = 1;
02926 return Qnil;
02927 }
02928
02929 static VALUE
02930 _thread_call_proc(arg)
02931 VALUE arg;
02932 {
02933 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg;
02934
02935 return rb_ensure(_thread_call_proc_core, (VALUE)q,
02936 _thread_call_proc_ensure, (VALUE)q);
02937 }
02938
02939 static VALUE
02940 #ifdef HAVE_PROTOTYPES
02941 _thread_call_proc_value(VALUE th)
02942 #else
02943 _thread_call_proc_value(th)
02944 VALUE th;
02945 #endif
02946 {
02947 return rb_funcall(th, ID_value, 0);
02948 }
02949
02950 static VALUE
02951 lib_thread_callback(argc, argv, self)
02952 int argc;
02953 VALUE *argv;
02954 VALUE self;
02955 {
02956 struct thread_call_proc_arg *q;
02957 VALUE proc, th, ret;
02958 int status;
02959
02960 if (rb_scan_args(argc, argv, "01", &proc) == 0) {
02961 proc = rb_block_proc();
02962 }
02963
02964 q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg);
02965
02966 q->proc = proc;
02967 q->done = (int*)ALLOC(int);
02968
02969 *(q->done) = 0;
02970
02971
02972 th = rb_thread_create(_thread_call_proc, (void*)q);
02973
02974 rb_thread_schedule();
02975
02976
02977 lib_eventloop_launcher(0, 0,
02978 q->done, (Tcl_Interp*)NULL);
02979
02980 if (RTEST(rb_thread_alive_p(th))) {
02981 rb_funcall(th, ID_kill, 0);
02982 ret = Qnil;
02983 } else {
02984 ret = rb_protect(_thread_call_proc_value, th, &status);
02985 }
02986
02987 xfree(q->done);
02988 xfree(q);
02989
02990
02991
02992 if (NIL_P(rbtk_pending_exception)) {
02993
02994 if (status) {
02995 rb_exc_raise(rb_errinfo());
02996 }
02997 } else {
02998 VALUE exc = rbtk_pending_exception;
02999 rbtk_pending_exception = Qnil;
03000
03001 rb_exc_raise(exc);
03002 }
03003
03004 return ret;
03005 }
03006
03007
03008
03009 static VALUE
03010 lib_do_one_event_core(argc, argv, self, is_ip)
03011 int argc;
03012 VALUE *argv;
03013 VALUE self;
03014 int is_ip;
03015 {
03016 volatile VALUE vflags;
03017 int flags;
03018 int found_event;
03019
03020 if (!NIL_P(eventloop_thread)) {
03021 rb_raise(rb_eRuntimeError, "eventloop is already running");
03022 }
03023
03024 tcl_stubs_check();
03025
03026 if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
03027 flags = TCL_ALL_EVENTS | TCL_DONT_WAIT;
03028 } else {
03029 Check_Type(vflags, T_FIXNUM);
03030 flags = FIX2INT(vflags);
03031 }
03032
03033 if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) {
03034 flags |= TCL_DONT_WAIT;
03035 }
03036
03037 if (is_ip) {
03038
03039 struct tcltkip *ptr = get_ip(self);
03040
03041
03042 if (deleted_ip(ptr)) {
03043 return Qfalse;
03044 }
03045
03046 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
03047
03048 flags |= TCL_DONT_WAIT;
03049 }
03050 }
03051
03052
03053 found_event = Tcl_DoOneEvent(flags);
03054
03055 if (pending_exception_check0()) {
03056 return Qfalse;
03057 }
03058
03059 if (found_event) {
03060 return Qtrue;
03061 } else {
03062 return Qfalse;
03063 }
03064 }
03065
03066 static VALUE
03067 lib_do_one_event(argc, argv, self)
03068 int argc;
03069 VALUE *argv;
03070 VALUE self;
03071 {
03072 return lib_do_one_event_core(argc, argv, self, 0);
03073 }
03074
03075 static VALUE
03076 ip_do_one_event(argc, argv, self)
03077 int argc;
03078 VALUE *argv;
03079 VALUE self;
03080 {
03081 return lib_do_one_event_core(argc, argv, self, 0);
03082 }
03083
03084
03085 static void
03086 ip_set_exc_message(interp, exc)
03087 Tcl_Interp *interp;
03088 VALUE exc;
03089 {
03090 char *buf;
03091 Tcl_DString dstr;
03092 volatile VALUE msg;
03093 int thr_crit_bup;
03094
03095 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
03096 volatile VALUE enc;
03097 Tcl_Encoding encoding;
03098 #endif
03099
03100 thr_crit_bup = rb_thread_critical;
03101 rb_thread_critical = Qtrue;
03102
03103 msg = rb_funcall(exc, ID_message, 0, 0);
03104 StringValue(msg);
03105
03106 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
03107 enc = rb_attr_get(exc, ID_at_enc);
03108 if (NIL_P(enc)) {
03109 enc = rb_attr_get(msg, ID_at_enc);
03110 }
03111 if (NIL_P(enc)) {
03112 encoding = (Tcl_Encoding)NULL;
03113 } else if (TYPE(enc) == T_STRING) {
03114
03115 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
03116 } else {
03117 enc = rb_funcall(enc, ID_to_s, 0, 0);
03118
03119 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc));
03120 }
03121
03122
03123
03124
03125
03126 buf = ALLOC_N(char, RSTRING_LENINT(msg)+1);
03127
03128 memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg));
03129 buf[RSTRING_LEN(msg)] = 0;
03130
03131 Tcl_DStringInit(&dstr);
03132 Tcl_DStringFree(&dstr);
03133 Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(msg), &dstr);
03134
03135 Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
03136 DUMP2("error message:%s", Tcl_DStringValue(&dstr));
03137 Tcl_DStringFree(&dstr);
03138 xfree(buf);
03139
03140
03141 #else
03142 Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL);
03143 #endif
03144
03145 rb_thread_critical = thr_crit_bup;
03146 }
03147
03148 static VALUE
03149 TkStringValue(obj)
03150 VALUE obj;
03151 {
03152 switch(TYPE(obj)) {
03153 case T_STRING:
03154 return obj;
03155
03156 case T_NIL:
03157 return rb_str_new2("");
03158
03159 case T_TRUE:
03160 return rb_str_new2("1");
03161
03162 case T_FALSE:
03163 return rb_str_new2("0");
03164
03165 case T_ARRAY:
03166 return rb_funcall(obj, ID_join, 1, rb_str_new2(" "));
03167
03168 default:
03169 if (rb_respond_to(obj, ID_to_s)) {
03170 return rb_funcall(obj, ID_to_s, 0, 0);
03171 }
03172 }
03173
03174 return rb_funcall(obj, ID_inspect, 0, 0);
03175 }
03176
03177 static int
03178 #ifdef HAVE_PROTOTYPES
03179 tcl_protect_core(Tcl_Interp *interp, VALUE (*proc)(VALUE), VALUE data)
03180 #else
03181 tcl_protect_core(interp, proc, data)
03182 Tcl_Interp *interp;
03183 VALUE (*proc)();
03184 VALUE data;
03185 #endif
03186 {
03187 volatile VALUE ret, exc = Qnil;
03188 int status = 0;
03189 int thr_crit_bup = rb_thread_critical;
03190
03191 Tcl_ResetResult(interp);
03192
03193 rb_thread_critical = Qfalse;
03194 ret = rb_protect(proc, data, &status);
03195 rb_thread_critical = Qtrue;
03196 if (status) {
03197 char *buf;
03198 VALUE old_gc;
03199 volatile VALUE type, str;
03200
03201 old_gc = rb_gc_disable();
03202
03203 switch(status) {
03204 case TAG_RETURN:
03205 type = eTkCallbackReturn;
03206 goto error;
03207 case TAG_BREAK:
03208 type = eTkCallbackBreak;
03209 goto error;
03210 case TAG_NEXT:
03211 type = eTkCallbackContinue;
03212 goto error;
03213 error:
03214 str = rb_str_new2("LocalJumpError: ");
03215 rb_str_append(str, rb_obj_as_string(rb_errinfo()));
03216 exc = rb_exc_new3(type, str);
03217 break;
03218
03219 case TAG_RETRY:
03220 if (NIL_P(rb_errinfo())) {
03221 DUMP1("rb_protect: retry");
03222 exc = rb_exc_new2(eTkCallbackRetry, "retry jump error");
03223 } else {
03224 exc = rb_errinfo();
03225 }
03226 break;
03227
03228 case TAG_REDO:
03229 if (NIL_P(rb_errinfo())) {
03230 DUMP1("rb_protect: redo");
03231 exc = rb_exc_new2(eTkCallbackRedo, "redo jump error");
03232 } else {
03233 exc = rb_errinfo();
03234 }
03235 break;
03236
03237 case TAG_RAISE:
03238 if (NIL_P(rb_errinfo())) {
03239 exc = rb_exc_new2(rb_eException, "unknown exception");
03240 } else {
03241 exc = rb_errinfo();
03242 }
03243 break;
03244
03245 case TAG_FATAL:
03246 if (NIL_P(rb_errinfo())) {
03247 exc = rb_exc_new2(rb_eFatal, "FATAL");
03248 } else {
03249 exc = rb_errinfo();
03250 }
03251 break;
03252
03253 case TAG_THROW:
03254 if (NIL_P(rb_errinfo())) {
03255 DUMP1("rb_protect: throw");
03256 exc = rb_exc_new2(eTkCallbackThrow, "throw jump error");
03257 } else {
03258 exc = rb_errinfo();
03259 }
03260 break;
03261
03262 default:
03263 buf = ALLOC_N(char, 256);
03264
03265 sprintf(buf, "unknown loncaljmp status %d", status);
03266 exc = rb_exc_new2(rb_eException, buf);
03267 xfree(buf);
03268
03269 break;
03270 }
03271
03272 if (old_gc == Qfalse) rb_gc_enable();
03273
03274 ret = Qnil;
03275 }
03276
03277 rb_thread_critical = thr_crit_bup;
03278
03279 Tcl_ResetResult(interp);
03280
03281
03282 if (!NIL_P(exc)) {
03283 volatile VALUE eclass = rb_obj_class(exc);
03284 volatile VALUE backtrace;
03285
03286 DUMP1("(failed)");
03287
03288 thr_crit_bup = rb_thread_critical;
03289 rb_thread_critical = Qtrue;
03290
03291 DUMP1("set backtrace");
03292 if (!NIL_P(backtrace = rb_funcall(exc, ID_backtrace, 0, 0))) {
03293 backtrace = rb_ary_join(backtrace, rb_str_new2("\n"));
03294 Tcl_AddErrorInfo(interp, StringValuePtr(backtrace));
03295 }
03296
03297 rb_thread_critical = thr_crit_bup;
03298
03299 ip_set_exc_message(interp, exc);
03300
03301 if (eclass == eTkCallbackReturn)
03302 return TCL_RETURN;
03303
03304 if (eclass == eTkCallbackBreak)
03305 return TCL_BREAK;
03306
03307 if (eclass == eTkCallbackContinue)
03308 return TCL_CONTINUE;
03309
03310 if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) {
03311 rbtk_pending_exception = exc;
03312 return TCL_RETURN;
03313 }
03314
03315 if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) {
03316 rbtk_pending_exception = exc;
03317 return TCL_ERROR;
03318 }
03319
03320 if (rb_obj_is_kind_of(exc, eLocalJumpError)) {
03321 VALUE reason = rb_ivar_get(exc, ID_at_reason);
03322
03323 if (TYPE(reason) == T_SYMBOL) {
03324 if (SYM2ID(reason) == ID_return)
03325 return TCL_RETURN;
03326
03327 if (SYM2ID(reason) == ID_break)
03328 return TCL_BREAK;
03329
03330 if (SYM2ID(reason) == ID_next)
03331 return TCL_CONTINUE;
03332 }
03333 }
03334
03335 return TCL_ERROR;
03336 }
03337
03338
03339 if (!NIL_P(ret)) {
03340
03341 thr_crit_bup = rb_thread_critical;
03342 rb_thread_critical = Qtrue;
03343
03344 ret = TkStringValue(ret);
03345 DUMP1("Tcl_AppendResult");
03346 Tcl_AppendResult(interp, RSTRING_PTR(ret), (char *)NULL);
03347
03348 rb_thread_critical = thr_crit_bup;
03349 }
03350
03351 DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING_PTR(ret));
03352
03353 return TCL_OK;
03354 }
03355
03356 static int
03357 tcl_protect(interp, proc, data)
03358 Tcl_Interp *interp;
03359 VALUE (*proc)();
03360 VALUE data;
03361 {
03362 int code;
03363
03364 #ifdef HAVE_NATIVETHREAD
03365 #ifndef RUBY_USE_NATIVE_THREAD
03366 if (!ruby_native_thread_p()) {
03367 rb_bug("cross-thread violation on tcl_protect()");
03368 }
03369 #endif
03370 #endif
03371
03372 #ifdef RUBY_VM
03373 code = tcl_protect_core(interp, proc, data);
03374 #else
03375 do {
03376 int old_trapflag = rb_trap_immediate;
03377 rb_trap_immediate = 0;
03378 code = tcl_protect_core(interp, proc, data);
03379 rb_trap_immediate = old_trapflag;
03380 } while (0);
03381 #endif
03382
03383 return code;
03384 }
03385
03386 static int
03387 #if TCL_MAJOR_VERSION >= 8
03388 ip_ruby_eval(clientData, interp, argc, argv)
03389 ClientData clientData;
03390 Tcl_Interp *interp;
03391 int argc;
03392 Tcl_Obj *CONST argv[];
03393 #else
03394 ip_ruby_eval(clientData, interp, argc, argv)
03395 ClientData clientData;
03396 Tcl_Interp *interp;
03397 int argc;
03398 char *argv[];
03399 #endif
03400 {
03401 char *arg;
03402 int thr_crit_bup;
03403 int code;
03404
03405 if (interp == (Tcl_Interp*)NULL) {
03406 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
03407 "IP is deleted");
03408 return TCL_ERROR;
03409 }
03410
03411
03412 if (argc != 2) {
03413 #if 0
03414 rb_raise(rb_eArgError,
03415 "wrong number of arguments (%d for 1)", argc - 1);
03416 #else
03417 char buf[sizeof(int)*8 + 1];
03418 Tcl_ResetResult(interp);
03419 sprintf(buf, "%d", argc-1);
03420 Tcl_AppendResult(interp, "wrong number of arguments (",
03421 buf, " for 1)", (char *)NULL);
03422 rbtk_pending_exception = rb_exc_new2(rb_eArgError,
03423 Tcl_GetStringResult(interp));
03424 return TCL_ERROR;
03425 #endif
03426 }
03427
03428
03429 #if TCL_MAJOR_VERSION >= 8
03430 {
03431 char *str;
03432 int len;
03433
03434 thr_crit_bup = rb_thread_critical;
03435 rb_thread_critical = Qtrue;
03436
03437 str = Tcl_GetStringFromObj(argv[1], &len);
03438 arg = ALLOC_N(char, len + 1);
03439
03440 memcpy(arg, str, len);
03441 arg[len] = 0;
03442
03443 rb_thread_critical = thr_crit_bup;
03444
03445 }
03446 #else
03447 arg = argv[1];
03448 #endif
03449
03450
03451 DUMP2("rb_eval_string(%s)", arg);
03452
03453 code = tcl_protect(interp, rb_eval_string, (VALUE)arg);
03454
03455 #if TCL_MAJOR_VERSION >= 8
03456 xfree(arg);
03457
03458 #endif
03459
03460 return code;
03461 }
03462
03463
03464
03465 static VALUE
03466 ip_ruby_cmd_core(arg)
03467 struct cmd_body_arg *arg;
03468 {
03469 volatile VALUE ret;
03470 int thr_crit_bup;
03471
03472 DUMP1("call ip_ruby_cmd_core");
03473 thr_crit_bup = rb_thread_critical;
03474 rb_thread_critical = Qfalse;
03475 ret = rb_apply(arg->receiver, arg->method, arg->args);
03476 DUMP2("rb_apply return:%lx", ret);
03477 rb_thread_critical = thr_crit_bup;
03478 DUMP1("finish ip_ruby_cmd_core");
03479
03480 return ret;
03481 }
03482
03483 #define SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 1
03484
03485 static VALUE
03486 ip_ruby_cmd_receiver_const_get(name)
03487 char *name;
03488 {
03489 volatile VALUE klass = rb_cObject;
03490 #if 0
03491 char *head, *tail;
03492 #endif
03493 int state;
03494
03495 #if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
03496 klass = rb_eval_string_protect(name, &state);
03497 if (state) {
03498 return Qnil;
03499 } else {
03500 return klass;
03501 }
03502 #else
03503 return rb_const_get(klass, rb_intern(name));
03504 #endif
03505
03506
03507
03508
03509
03510
03511
03512 #if 0
03513
03514 head = name = strdup(name);
03515
03516
03517 if (*head == ':') head += 2;
03518 tail = head;
03519
03520
03521 while(*tail) {
03522 if (*tail == ':') {
03523 *tail = '\0';
03524 klass = rb_const_get(klass, rb_intern(head));
03525 tail += 2;
03526 head = tail;
03527 } else {
03528 tail++;
03529 }
03530 }
03531
03532 free(name);
03533 return rb_const_get(klass, rb_intern(head));
03534 #endif
03535 }
03536
03537 static VALUE
03538 ip_ruby_cmd_receiver_get(str)
03539 char *str;
03540 {
03541 volatile VALUE receiver;
03542 #if !SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
03543 int state;
03544 #endif
03545
03546 if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
03547
03548 #if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER
03549 receiver = ip_ruby_cmd_receiver_const_get(str);
03550 #else
03551 receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state);
03552 if (state) return Qnil;
03553 #endif
03554 } else if (str[0] == '$') {
03555
03556 receiver = rb_gv_get(str);
03557 } else {
03558
03559 char *buf;
03560 size_t len;
03561
03562 len = strlen(str);
03563 buf = ALLOC_N(char, len + 2);
03564
03565 buf[0] = '$';
03566 memcpy(buf + 1, str, len);
03567 buf[len + 1] = 0;
03568 receiver = rb_gv_get(buf);
03569 xfree(buf);
03570
03571 }
03572
03573 return receiver;
03574 }
03575
03576
03577 static int
03578 #if TCL_MAJOR_VERSION >= 8
03579 ip_ruby_cmd(clientData, interp, argc, argv)
03580 ClientData clientData;
03581 Tcl_Interp *interp;
03582 int argc;
03583 Tcl_Obj *CONST argv[];
03584 #else
03585 ip_ruby_cmd(clientData, interp, argc, argv)
03586 ClientData clientData;
03587 Tcl_Interp *interp;
03588 int argc;
03589 char *argv[];
03590 #endif
03591 {
03592 volatile VALUE receiver;
03593 volatile ID method;
03594 volatile VALUE args;
03595 char *str;
03596 int i;
03597 int len;
03598 struct cmd_body_arg *arg;
03599 int thr_crit_bup;
03600 VALUE old_gc;
03601 int code;
03602
03603 if (interp == (Tcl_Interp*)NULL) {
03604 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
03605 "IP is deleted");
03606 return TCL_ERROR;
03607 }
03608
03609 if (argc < 3) {
03610 #if 0
03611 rb_raise(rb_eArgError, "too few arguments");
03612 #else
03613 Tcl_ResetResult(interp);
03614 Tcl_AppendResult(interp, "too few arguments", (char *)NULL);
03615 rbtk_pending_exception = rb_exc_new2(rb_eArgError,
03616 Tcl_GetStringResult(interp));
03617 return TCL_ERROR;
03618 #endif
03619 }
03620
03621
03622 thr_crit_bup = rb_thread_critical;
03623 rb_thread_critical = Qtrue;
03624 old_gc = rb_gc_disable();
03625
03626
03627 #if TCL_MAJOR_VERSION >= 8
03628 str = Tcl_GetStringFromObj(argv[1], &len);
03629 #else
03630 str = argv[1];
03631 #endif
03632 DUMP2("receiver:%s",str);
03633
03634 receiver = ip_ruby_cmd_receiver_get(str);
03635 if (NIL_P(receiver)) {
03636 #if 0
03637 rb_raise(rb_eArgError,
03638 "unknown class/module/global-variable '%s'", str);
03639 #else
03640 Tcl_ResetResult(interp);
03641 Tcl_AppendResult(interp, "unknown class/module/global-variable '",
03642 str, "'", (char *)NULL);
03643 rbtk_pending_exception = rb_exc_new2(rb_eArgError,
03644 Tcl_GetStringResult(interp));
03645 if (old_gc == Qfalse) rb_gc_enable();
03646 return TCL_ERROR;
03647 #endif
03648 }
03649
03650
03651 #if TCL_MAJOR_VERSION >= 8
03652 str = Tcl_GetStringFromObj(argv[2], &len);
03653 #else
03654 str = argv[2];
03655 #endif
03656 method = rb_intern(str);
03657
03658
03659 args = rb_ary_new2(argc - 2);
03660 for(i = 3; i < argc; i++) {
03661 VALUE s;
03662 #if TCL_MAJOR_VERSION >= 8
03663 str = Tcl_GetStringFromObj(argv[i], &len);
03664 s = rb_tainted_str_new(str, len);
03665 #else
03666 str = argv[i];
03667 s = rb_tainted_str_new2(str);
03668 #endif
03669 DUMP2("arg:%s",str);
03670 #ifndef HAVE_STRUCT_RARRAY_LEN
03671 rb_ary_push(args, s);
03672 #else
03673 RARRAY(args)->ptr[RARRAY(args)->len++] = s;
03674 #endif
03675 }
03676
03677 if (old_gc == Qfalse) rb_gc_enable();
03678 rb_thread_critical = thr_crit_bup;
03679
03680
03681 arg = ALLOC(struct cmd_body_arg);
03682
03683
03684 arg->receiver = receiver;
03685 arg->method = method;
03686 arg->args = args;
03687
03688
03689 code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg);
03690
03691 xfree(arg);
03692
03693
03694 return code;
03695 }
03696
03697
03698
03699
03700
03701 static int
03702 #if TCL_MAJOR_VERSION >= 8
03703 #ifdef HAVE_PROTOTYPES
03704 ip_InterpExitObjCmd(ClientData clientData, Tcl_Interp *interp,
03705 int argc, Tcl_Obj *CONST argv[])
03706 #else
03707 ip_InterpExitObjCmd(clientData, interp, argc, argv)
03708 ClientData clientData;
03709 Tcl_Interp *interp;
03710 int argc;
03711 Tcl_Obj *CONST argv[];
03712 #endif
03713 #else
03714 #ifdef HAVE_PROTOTYPES
03715 ip_InterpExitCommand(ClientData clientData, Tcl_Interp *interp,
03716 int argc, char *argv[])
03717 #else
03718 ip_InterpExitCommand(clientData, interp, argc, argv)
03719 ClientData clientData;
03720 Tcl_Interp *interp;
03721 int argc;
03722 char *argv[];
03723 #endif
03724 #endif
03725 {
03726 DUMP1("start ip_InterpExitCommand");
03727 if (interp != (Tcl_Interp*)NULL
03728 && !Tcl_InterpDeleted(interp)
03729 #if TCL_NAMESPACE_DEBUG
03730 && !ip_null_namespace(interp)
03731 #endif
03732 ) {
03733 Tcl_ResetResult(interp);
03734
03735
03736 if (!Tcl_InterpDeleted(interp)) {
03737 ip_finalize(interp);
03738
03739 Tcl_DeleteInterp(interp);
03740 Tcl_Release(interp);
03741 }
03742 }
03743 return TCL_OK;
03744 }
03745
03746 static int
03747 #if TCL_MAJOR_VERSION >= 8
03748 #ifdef HAVE_PROTOTYPES
03749 ip_RubyExitObjCmd(ClientData clientData, Tcl_Interp *interp,
03750 int argc, Tcl_Obj *CONST argv[])
03751 #else
03752 ip_RubyExitObjCmd(clientData, interp, argc, argv)
03753 ClientData clientData;
03754 Tcl_Interp *interp;
03755 int argc;
03756 Tcl_Obj *CONST argv[];
03757 #endif
03758 #else
03759 #ifdef HAVE_PROTOTYPES
03760 ip_RubyExitCommand(ClientData clientData, Tcl_Interp *interp,
03761 int argc, char *argv[])
03762 #else
03763 ip_RubyExitCommand(clientData, interp, argc, argv)
03764 ClientData clientData;
03765 Tcl_Interp *interp;
03766 int argc;
03767 char *argv[];
03768 #endif
03769 #endif
03770 {
03771 int state;
03772 char *cmd, *param;
03773 #if TCL_MAJOR_VERSION < 8
03774 char *endptr;
03775 cmd = argv[0];
03776 #endif
03777
03778 DUMP1("start ip_RubyExitCommand");
03779
03780 #if TCL_MAJOR_VERSION >= 8
03781
03782 cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL);
03783 #endif
03784
03785 if (argc < 1 || argc > 2) {
03786
03787 Tcl_AppendResult(interp,
03788 "wrong number of arguments: should be \"",
03789 cmd, " ?returnCode?\"", (char *)NULL);
03790 return TCL_ERROR;
03791 }
03792
03793 if (interp == (Tcl_Interp*)NULL) return TCL_OK;
03794
03795 Tcl_ResetResult(interp);
03796
03797 if (rb_safe_level() >= 4 || Tcl_IsSafe(interp)) {
03798 if (!Tcl_InterpDeleted(interp)) {
03799 ip_finalize(interp);
03800
03801 Tcl_DeleteInterp(interp);
03802 Tcl_Release(interp);
03803 }
03804 return TCL_OK;
03805 }
03806
03807 switch(argc) {
03808 case 1:
03809
03810 Tcl_AppendResult(interp,
03811 "fail to call \"", cmd, "\"", (char *)NULL);
03812
03813 rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
03814 Tcl_GetStringResult(interp));
03815 rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0));
03816
03817 return TCL_RETURN;
03818
03819 case 2:
03820 #if TCL_MAJOR_VERSION >= 8
03821 if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) {
03822 return TCL_ERROR;
03823 }
03824
03825 param = Tcl_GetStringFromObj(argv[1], (int*)NULL);
03826 #else
03827 state = (int)strtol(argv[1], &endptr, 0);
03828 if (*endptr) {
03829 Tcl_AppendResult(interp,
03830 "expected integer but got \"",
03831 argv[1], "\"", (char *)NULL);
03832 return TCL_ERROR;
03833 }
03834 param = argv[1];
03835 #endif
03836
03837
03838 Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
03839 param, "\"", (char *)NULL);
03840
03841 rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
03842 Tcl_GetStringResult(interp));
03843 rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state));
03844
03845 return TCL_RETURN;
03846
03847 default:
03848
03849 Tcl_AppendResult(interp,
03850 "wrong number of arguments: should be \"",
03851 cmd, " ?returnCode?\"", (char *)NULL);
03852 return TCL_ERROR;
03853 }
03854 }
03855
03856
03857
03858
03859
03860
03861
03862
03863
03864 #if TCL_MAJOR_VERSION >= 8
03865 static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int,
03866 Tcl_Obj *CONST []));
03867 static int
03868 ip_rbUpdateObjCmd(clientData, interp, objc, objv)
03869 ClientData clientData;
03870 Tcl_Interp *interp;
03871 int objc;
03872 Tcl_Obj *CONST objv[];
03873 #else
03874 static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[]));
03875 static int
03876 ip_rbUpdateCommand(clientData, interp, objc, objv)
03877 ClientData clientData;
03878 Tcl_Interp *interp;
03879 int objc;
03880 char *objv[];
03881 #endif
03882 {
03883 int flags = 0;
03884 static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
03885 enum updateOptions {REGEXP_IDLETASKS};
03886
03887 DUMP1("Ruby's 'update' is called");
03888 if (interp == (Tcl_Interp*)NULL) {
03889 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
03890 "IP is deleted");
03891 return TCL_ERROR;
03892 }
03893 #ifdef HAVE_NATIVETHREAD
03894 #ifndef RUBY_USE_NATIVE_THREAD
03895 if (!ruby_native_thread_p()) {
03896 rb_bug("cross-thread violation on ip_ruby_eval()");
03897 }
03898 #endif
03899 #endif
03900
03901 Tcl_ResetResult(interp);
03902
03903 if (objc == 1) {
03904 flags = TCL_DONT_WAIT;
03905
03906 } else if (objc == 2) {
03907 #if TCL_MAJOR_VERSION >= 8
03908 int optionIndex;
03909 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
03910 "option", 0, &optionIndex) != TCL_OK) {
03911 return TCL_ERROR;
03912 }
03913 switch ((enum updateOptions) optionIndex) {
03914 case REGEXP_IDLETASKS: {
03915 flags = TCL_IDLE_EVENTS;
03916 break;
03917 }
03918 default: {
03919 rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions");
03920 }
03921 }
03922 #else
03923 if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
03924 Tcl_AppendResult(interp, "bad option \"", objv[1],
03925 "\": must be idletasks", (char *) NULL);
03926 return TCL_ERROR;
03927 }
03928 flags = TCL_IDLE_EVENTS;
03929 #endif
03930 } else {
03931 #ifdef Tcl_WrongNumArgs
03932 Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
03933 #else
03934 # if TCL_MAJOR_VERSION >= 8
03935 int dummy;
03936 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
03937 Tcl_GetStringFromObj(objv[0], &dummy),
03938 " [ idletasks ]\"",
03939 (char *) NULL);
03940 # else
03941 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
03942 objv[0], " [ idletasks ]\"", (char *) NULL);
03943 # endif
03944 #endif
03945 return TCL_ERROR;
03946 }
03947
03948 Tcl_Preserve(interp);
03949
03950
03951
03952 lib_eventloop_launcher(0, flags, (int *)NULL, interp);
03953
03954
03955 if (!NIL_P(rbtk_pending_exception)) {
03956 Tcl_Release(interp);
03957
03958
03959
03960
03961 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
03962 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
03963 return TCL_RETURN;
03964 } else{
03965 return TCL_ERROR;
03966 }
03967 }
03968
03969
03970 if (rb_thread_check_trap_pending()) {
03971 Tcl_Release(interp);
03972
03973 return TCL_RETURN;
03974 }
03975
03976
03977
03978
03979
03980
03981 DUMP2("last result '%s'", Tcl_GetStringResult(interp));
03982 Tcl_ResetResult(interp);
03983 Tcl_Release(interp);
03984
03985 DUMP1("finish Ruby's 'update'");
03986 return TCL_OK;
03987 }
03988
03989
03990
03991
03992
03993 struct th_update_param {
03994 VALUE thread;
03995 int done;
03996 };
03997
03998 static void rb_threadUpdateProc _((ClientData));
03999 static void
04000 rb_threadUpdateProc(clientData)
04001 ClientData clientData;
04002 {
04003 struct th_update_param *param = (struct th_update_param *) clientData;
04004
04005 DUMP1("threadUpdateProc is called");
04006 param->done = 1;
04007 rb_thread_wakeup(param->thread);
04008
04009 return;
04010 }
04011
04012 #if TCL_MAJOR_VERSION >= 8
04013 static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int,
04014 Tcl_Obj *CONST []));
04015 static int
04016 ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv)
04017 ClientData clientData;
04018 Tcl_Interp *interp;
04019 int objc;
04020 Tcl_Obj *CONST objv[];
04021 #else
04022 static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int,
04023 char *[]));
04024 static int
04025 ip_rb_threadUpdateCommand(clientData, interp, objc, objv)
04026 ClientData clientData;
04027 Tcl_Interp *interp;
04028 int objc;
04029 char *objv[];
04030 #endif
04031 {
04032 # if 0
04033 int flags = 0;
04034 # endif
04035 struct th_update_param *param;
04036 static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
04037 enum updateOptions {REGEXP_IDLETASKS};
04038 volatile VALUE current_thread = rb_thread_current();
04039 struct timeval t;
04040
04041 DUMP1("Ruby's 'thread_update' is called");
04042 if (interp == (Tcl_Interp*)NULL) {
04043 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04044 "IP is deleted");
04045 return TCL_ERROR;
04046 }
04047 #ifdef HAVE_NATIVETHREAD
04048 #ifndef RUBY_USE_NATIVE_THREAD
04049 if (!ruby_native_thread_p()) {
04050 rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()");
04051 }
04052 #endif
04053 #endif
04054
04055 if (rb_thread_alone()
04056 || NIL_P(eventloop_thread) || eventloop_thread == current_thread) {
04057 #if TCL_MAJOR_VERSION >= 8
04058 DUMP1("call ip_rbUpdateObjCmd");
04059 return ip_rbUpdateObjCmd(clientData, interp, objc, objv);
04060 #else
04061 DUMP1("call ip_rbUpdateCommand");
04062 return ip_rbUpdateCommand(clientData, interp, objc, objv);
04063 #endif
04064 }
04065
04066 DUMP1("start Ruby's 'thread_update' body");
04067
04068 Tcl_ResetResult(interp);
04069
04070 if (objc == 1) {
04071 # if 0
04072 flags = TCL_DONT_WAIT;
04073 # endif
04074 } else if (objc == 2) {
04075 #if TCL_MAJOR_VERSION >= 8
04076 int optionIndex;
04077 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions,
04078 "option", 0, &optionIndex) != TCL_OK) {
04079 return TCL_ERROR;
04080 }
04081 switch ((enum updateOptions) optionIndex) {
04082 case REGEXP_IDLETASKS: {
04083 # if 0
04084 flags = TCL_IDLE_EVENTS;
04085 # endif
04086 break;
04087 }
04088 default: {
04089 rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions");
04090 }
04091 }
04092 #else
04093 if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) {
04094 Tcl_AppendResult(interp, "bad option \"", objv[1],
04095 "\": must be idletasks", (char *) NULL);
04096 return TCL_ERROR;
04097 }
04098 # if 0
04099 flags = TCL_IDLE_EVENTS;
04100 # endif
04101 #endif
04102 } else {
04103 #ifdef Tcl_WrongNumArgs
04104 Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
04105 #else
04106 # if TCL_MAJOR_VERSION >= 8
04107 int dummy;
04108 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04109 Tcl_GetStringFromObj(objv[0], &dummy),
04110 " [ idletasks ]\"",
04111 (char *) NULL);
04112 # else
04113 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04114 objv[0], " [ idletasks ]\"", (char *) NULL);
04115 # endif
04116 #endif
04117 return TCL_ERROR;
04118 }
04119
04120 DUMP1("pass argument check");
04121
04122
04123 param = RbTk_ALLOC_N(struct th_update_param, 1);
04124 #if 0
04125 Tcl_Preserve((ClientData)param);
04126 #endif
04127 param->thread = current_thread;
04128 param->done = 0;
04129
04130 DUMP1("set idle proc");
04131 Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param);
04132
04133 t.tv_sec = 0;
04134 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
04135
04136 while(!param->done) {
04137 DUMP1("wait for complete idle proc");
04138
04139
04140 rb_thread_wait_for(t);
04141 if (NIL_P(eventloop_thread)) {
04142 break;
04143 }
04144 }
04145
04146 #if 0
04147 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
04148 #else
04149 #if 0
04150 Tcl_Release((ClientData)param);
04151 #else
04152
04153 ckfree((char *)param);
04154 #endif
04155 #endif
04156
04157 DUMP1("finish Ruby's 'thread_update'");
04158 return TCL_OK;
04159 }
04160
04161
04162
04163
04164
04165 #if TCL_MAJOR_VERSION >= 8
04166 static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int,
04167 Tcl_Obj *CONST []));
04168 static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int,
04169 Tcl_Obj *CONST []));
04170 static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
04171 Tcl_Obj *CONST []));
04172 static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int,
04173 Tcl_Obj *CONST []));
04174 #else
04175 static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
04176 static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int,
04177 char *[]));
04178 static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
04179 static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int,
04180 char *[]));
04181 #endif
04182
04183 #if TCL_MAJOR_VERSION >= 8
04184 static char *VwaitVarProc _((ClientData, Tcl_Interp *,
04185 CONST84 char *,CONST84 char *, int));
04186 static char *
04187 VwaitVarProc(clientData, interp, name1, name2, flags)
04188 ClientData clientData;
04189 Tcl_Interp *interp;
04190 CONST84 char *name1;
04191 CONST84 char *name2;
04192 int flags;
04193 #else
04194 static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int));
04195 static char *
04196 VwaitVarProc(clientData, interp, name1, name2, flags)
04197 ClientData clientData;
04198 Tcl_Interp *interp;
04199 char *name1;
04200 char *name2;
04201 int flags;
04202 #endif
04203 {
04204 int *donePtr = (int *) clientData;
04205
04206 *donePtr = 1;
04207 return (char *) NULL;
04208 }
04209
04210 #if TCL_MAJOR_VERSION >= 8
04211 static int
04212 ip_rbVwaitObjCmd(clientData, interp, objc, objv)
04213 ClientData clientData;
04214 Tcl_Interp *interp;
04215 int objc;
04216 Tcl_Obj *CONST objv[];
04217 #else
04218 static int
04219 ip_rbVwaitCommand(clientData, interp, objc, objv)
04220 ClientData clientData;
04221 Tcl_Interp *interp;
04222 int objc;
04223 char *objv[];
04224 #endif
04225 {
04226 int ret, done, foundEvent;
04227 char *nameString;
04228 int dummy;
04229 int thr_crit_bup;
04230
04231 DUMP1("Ruby's 'vwait' is called");
04232 if (interp == (Tcl_Interp*)NULL) {
04233 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04234 "IP is deleted");
04235 return TCL_ERROR;
04236 }
04237
04238 #if 0
04239 if (!rb_thread_alone()
04240 && eventloop_thread != Qnil
04241 && eventloop_thread != rb_thread_current()) {
04242 #if TCL_MAJOR_VERSION >= 8
04243 DUMP1("call ip_rb_threadVwaitObjCmd");
04244 return ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv);
04245 #else
04246 DUMP1("call ip_rb_threadVwaitCommand");
04247 return ip_rb_threadVwaitCommand(clientData, interp, objc, objv);
04248 #endif
04249 }
04250 #endif
04251
04252 Tcl_Preserve(interp);
04253 #ifdef HAVE_NATIVETHREAD
04254 #ifndef RUBY_USE_NATIVE_THREAD
04255 if (!ruby_native_thread_p()) {
04256 rb_bug("cross-thread violation on ip_rbVwaitCommand()");
04257 }
04258 #endif
04259 #endif
04260
04261 Tcl_ResetResult(interp);
04262
04263 if (objc != 2) {
04264 #ifdef Tcl_WrongNumArgs
04265 Tcl_WrongNumArgs(interp, 1, objv, "name");
04266 #else
04267 thr_crit_bup = rb_thread_critical;
04268 rb_thread_critical = Qtrue;
04269
04270 #if TCL_MAJOR_VERSION >= 8
04271
04272 nameString = Tcl_GetStringFromObj(objv[0], &dummy);
04273 #else
04274 nameString = objv[0];
04275 #endif
04276 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04277 nameString, " name\"", (char *) NULL);
04278
04279 rb_thread_critical = thr_crit_bup;
04280 #endif
04281
04282 Tcl_Release(interp);
04283 return TCL_ERROR;
04284 }
04285
04286 thr_crit_bup = rb_thread_critical;
04287 rb_thread_critical = Qtrue;
04288
04289 #if TCL_MAJOR_VERSION >= 8
04290 Tcl_IncrRefCount(objv[1]);
04291
04292 nameString = Tcl_GetStringFromObj(objv[1], &dummy);
04293 #else
04294 nameString = objv[1];
04295 #endif
04296
04297
04298
04299
04300
04301
04302
04303
04304 ret = Tcl_TraceVar(interp, nameString,
04305 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04306 VwaitVarProc, (ClientData) &done);
04307
04308 rb_thread_critical = thr_crit_bup;
04309
04310 if (ret != TCL_OK) {
04311 #if TCL_MAJOR_VERSION >= 8
04312 Tcl_DecrRefCount(objv[1]);
04313 #endif
04314 Tcl_Release(interp);
04315 return TCL_ERROR;
04316 }
04317
04318 done = 0;
04319
04320 foundEvent = RTEST(lib_eventloop_launcher(0,
04321 0, &done, interp));
04322
04323 thr_crit_bup = rb_thread_critical;
04324 rb_thread_critical = Qtrue;
04325
04326 Tcl_UntraceVar(interp, nameString,
04327 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04328 VwaitVarProc, (ClientData) &done);
04329
04330 rb_thread_critical = thr_crit_bup;
04331
04332
04333 if (!NIL_P(rbtk_pending_exception)) {
04334 #if TCL_MAJOR_VERSION >= 8
04335 Tcl_DecrRefCount(objv[1]);
04336 #endif
04337 Tcl_Release(interp);
04338
04339
04340
04341
04342 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04343 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04344 return TCL_RETURN;
04345 } else{
04346 return TCL_ERROR;
04347 }
04348 }
04349
04350
04351 if (rb_thread_check_trap_pending()) {
04352 #if TCL_MAJOR_VERSION >= 8
04353 Tcl_DecrRefCount(objv[1]);
04354 #endif
04355 Tcl_Release(interp);
04356
04357 return TCL_RETURN;
04358 }
04359
04360
04361
04362
04363
04364
04365 Tcl_ResetResult(interp);
04366 if (!foundEvent) {
04367 thr_crit_bup = rb_thread_critical;
04368 rb_thread_critical = Qtrue;
04369
04370 Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
04371 "\": would wait forever", (char *) NULL);
04372
04373 rb_thread_critical = thr_crit_bup;
04374
04375 #if TCL_MAJOR_VERSION >= 8
04376 Tcl_DecrRefCount(objv[1]);
04377 #endif
04378 Tcl_Release(interp);
04379 return TCL_ERROR;
04380 }
04381
04382 #if TCL_MAJOR_VERSION >= 8
04383 Tcl_DecrRefCount(objv[1]);
04384 #endif
04385 Tcl_Release(interp);
04386 return TCL_OK;
04387 }
04388
04389
04390
04391
04392
04393 #if TCL_MAJOR_VERSION >= 8
04394 static char *WaitVariableProc _((ClientData, Tcl_Interp *,
04395 CONST84 char *,CONST84 char *, int));
04396 static char *
04397 WaitVariableProc(clientData, interp, name1, name2, flags)
04398 ClientData clientData;
04399 Tcl_Interp *interp;
04400 CONST84 char *name1;
04401 CONST84 char *name2;
04402 int flags;
04403 #else
04404 static char *WaitVariableProc _((ClientData, Tcl_Interp *,
04405 char *, char *, int));
04406 static char *
04407 WaitVariableProc(clientData, interp, name1, name2, flags)
04408 ClientData clientData;
04409 Tcl_Interp *interp;
04410 char *name1;
04411 char *name2;
04412 int flags;
04413 #endif
04414 {
04415 int *donePtr = (int *) clientData;
04416
04417 *donePtr = 1;
04418 return (char *) NULL;
04419 }
04420
04421 static void WaitVisibilityProc _((ClientData, XEvent *));
04422 static void
04423 WaitVisibilityProc(clientData, eventPtr)
04424 ClientData clientData;
04425 XEvent *eventPtr;
04426 {
04427 int *donePtr = (int *) clientData;
04428
04429 if (eventPtr->type == VisibilityNotify) {
04430 *donePtr = 1;
04431 }
04432 if (eventPtr->type == DestroyNotify) {
04433 *donePtr = 2;
04434 }
04435 }
04436
04437 static void WaitWindowProc _((ClientData, XEvent *));
04438 static void
04439 WaitWindowProc(clientData, eventPtr)
04440 ClientData clientData;
04441 XEvent *eventPtr;
04442 {
04443 int *donePtr = (int *) clientData;
04444
04445 if (eventPtr->type == DestroyNotify) {
04446 *donePtr = 1;
04447 }
04448 }
04449
04450 #if TCL_MAJOR_VERSION >= 8
04451 static int
04452 ip_rbTkWaitObjCmd(clientData, interp, objc, objv)
04453 ClientData clientData;
04454 Tcl_Interp *interp;
04455 int objc;
04456 Tcl_Obj *CONST objv[];
04457 #else
04458 static int
04459 ip_rbTkWaitCommand(clientData, interp, objc, objv)
04460 ClientData clientData;
04461 Tcl_Interp *interp;
04462 int objc;
04463 char *objv[];
04464 #endif
04465 {
04466 Tk_Window tkwin = (Tk_Window) clientData;
04467 Tk_Window window;
04468 int done, index;
04469 static CONST char *optionStrings[] = { "variable", "visibility", "window",
04470 (char *) NULL };
04471 enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
04472 char *nameString;
04473 int ret, dummy;
04474 int thr_crit_bup;
04475
04476 DUMP1("Ruby's 'tkwait' is called");
04477 if (interp == (Tcl_Interp*)NULL) {
04478 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04479 "IP is deleted");
04480 return TCL_ERROR;
04481 }
04482
04483 #if 0
04484 if (!rb_thread_alone()
04485 && eventloop_thread != Qnil
04486 && eventloop_thread != rb_thread_current()) {
04487 #if TCL_MAJOR_VERSION >= 8
04488 DUMP1("call ip_rb_threadTkWaitObjCmd");
04489 return ip_rb_threadTkWaitObjCmd((ClientData)tkwin, interp, objc, objv);
04490 #else
04491 DUMP1("call ip_rb_threadTkWaitCommand");
04492 return ip_rb_threadTkWwaitCommand((ClientData)tkwin, interp, objc, objv);
04493 #endif
04494 }
04495 #endif
04496
04497 Tcl_Preserve(interp);
04498 Tcl_ResetResult(interp);
04499
04500 if (objc != 3) {
04501 #ifdef Tcl_WrongNumArgs
04502 Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
04503 #else
04504 thr_crit_bup = rb_thread_critical;
04505 rb_thread_critical = Qtrue;
04506
04507 #if TCL_MAJOR_VERSION >= 8
04508 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04509 Tcl_GetStringFromObj(objv[0], &dummy),
04510 " variable|visibility|window name\"",
04511 (char *) NULL);
04512 #else
04513 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04514 objv[0], " variable|visibility|window name\"",
04515 (char *) NULL);
04516 #endif
04517
04518 rb_thread_critical = thr_crit_bup;
04519 #endif
04520
04521 Tcl_Release(interp);
04522 return TCL_ERROR;
04523 }
04524
04525 #if TCL_MAJOR_VERSION >= 8
04526 thr_crit_bup = rb_thread_critical;
04527 rb_thread_critical = Qtrue;
04528
04529
04530
04531
04532
04533
04534
04535
04536 ret = Tcl_GetIndexFromObj(interp, objv[1],
04537 (CONST84 char **)optionStrings,
04538 "option", 0, &index);
04539
04540 rb_thread_critical = thr_crit_bup;
04541
04542 if (ret != TCL_OK) {
04543 Tcl_Release(interp);
04544 return TCL_ERROR;
04545 }
04546 #else
04547 {
04548 int c = objv[1][0];
04549 size_t length = strlen(objv[1]);
04550
04551 if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
04552 && (length >= 2)) {
04553 index = TKWAIT_VARIABLE;
04554 } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
04555 && (length >= 2)) {
04556 index = TKWAIT_VISIBILITY;
04557 } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
04558 index = TKWAIT_WINDOW;
04559 } else {
04560 Tcl_AppendResult(interp, "bad option \"", objv[1],
04561 "\": must be variable, visibility, or window",
04562 (char *) NULL);
04563 Tcl_Release(interp);
04564 return TCL_ERROR;
04565 }
04566 }
04567 #endif
04568
04569 thr_crit_bup = rb_thread_critical;
04570 rb_thread_critical = Qtrue;
04571
04572 #if TCL_MAJOR_VERSION >= 8
04573 Tcl_IncrRefCount(objv[2]);
04574
04575 nameString = Tcl_GetStringFromObj(objv[2], &dummy);
04576 #else
04577 nameString = objv[2];
04578 #endif
04579
04580 rb_thread_critical = thr_crit_bup;
04581
04582 switch ((enum options) index) {
04583 case TKWAIT_VARIABLE:
04584 thr_crit_bup = rb_thread_critical;
04585 rb_thread_critical = Qtrue;
04586
04587
04588
04589
04590
04591
04592
04593 ret = Tcl_TraceVar(interp, nameString,
04594 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04595 WaitVariableProc, (ClientData) &done);
04596
04597 rb_thread_critical = thr_crit_bup;
04598
04599 if (ret != TCL_OK) {
04600 #if TCL_MAJOR_VERSION >= 8
04601 Tcl_DecrRefCount(objv[2]);
04602 #endif
04603 Tcl_Release(interp);
04604 return TCL_ERROR;
04605 }
04606
04607 done = 0;
04608
04609 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
04610
04611 thr_crit_bup = rb_thread_critical;
04612 rb_thread_critical = Qtrue;
04613
04614 Tcl_UntraceVar(interp, nameString,
04615 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04616 WaitVariableProc, (ClientData) &done);
04617
04618 #if TCL_MAJOR_VERSION >= 8
04619 Tcl_DecrRefCount(objv[2]);
04620 #endif
04621
04622 rb_thread_critical = thr_crit_bup;
04623
04624
04625 if (!NIL_P(rbtk_pending_exception)) {
04626 Tcl_Release(interp);
04627
04628
04629
04630
04631 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04632 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04633 return TCL_RETURN;
04634 } else{
04635 return TCL_ERROR;
04636 }
04637 }
04638
04639
04640 if (rb_thread_check_trap_pending()) {
04641 Tcl_Release(interp);
04642
04643 return TCL_RETURN;
04644 }
04645
04646 break;
04647
04648 case TKWAIT_VISIBILITY:
04649 thr_crit_bup = rb_thread_critical;
04650 rb_thread_critical = Qtrue;
04651
04652
04653 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
04654 window = NULL;
04655 } else {
04656 window = Tk_NameToWindow(interp, nameString, tkwin);
04657 }
04658
04659 if (window == NULL) {
04660 Tcl_AppendResult(interp, ": tkwait: ",
04661 "no main-window (not Tk application?)",
04662 (char*)NULL);
04663 rb_thread_critical = thr_crit_bup;
04664 #if TCL_MAJOR_VERSION >= 8
04665 Tcl_DecrRefCount(objv[2]);
04666 #endif
04667 Tcl_Release(interp);
04668 return TCL_ERROR;
04669 }
04670
04671 Tk_CreateEventHandler(window,
04672 VisibilityChangeMask|StructureNotifyMask,
04673 WaitVisibilityProc, (ClientData) &done);
04674
04675 rb_thread_critical = thr_crit_bup;
04676
04677 done = 0;
04678
04679 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
04680
04681
04682 if (!NIL_P(rbtk_pending_exception)) {
04683 #if TCL_MAJOR_VERSION >= 8
04684 Tcl_DecrRefCount(objv[2]);
04685 #endif
04686 Tcl_Release(interp);
04687
04688
04689
04690
04691 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04692 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04693 return TCL_RETURN;
04694 } else{
04695 return TCL_ERROR;
04696 }
04697 }
04698
04699
04700 if (rb_thread_check_trap_pending()) {
04701 #if TCL_MAJOR_VERSION >= 8
04702 Tcl_DecrRefCount(objv[2]);
04703 #endif
04704 Tcl_Release(interp);
04705
04706 return TCL_RETURN;
04707 }
04708
04709 if (done != 1) {
04710
04711
04712
04713
04714 thr_crit_bup = rb_thread_critical;
04715 rb_thread_critical = Qtrue;
04716
04717 Tcl_ResetResult(interp);
04718 Tcl_AppendResult(interp, "window \"", nameString,
04719 "\" was deleted before its visibility changed",
04720 (char *) NULL);
04721
04722 rb_thread_critical = thr_crit_bup;
04723
04724 #if TCL_MAJOR_VERSION >= 8
04725 Tcl_DecrRefCount(objv[2]);
04726 #endif
04727 Tcl_Release(interp);
04728 return TCL_ERROR;
04729 }
04730
04731 thr_crit_bup = rb_thread_critical;
04732 rb_thread_critical = Qtrue;
04733
04734 #if TCL_MAJOR_VERSION >= 8
04735 Tcl_DecrRefCount(objv[2]);
04736 #endif
04737
04738 Tk_DeleteEventHandler(window,
04739 VisibilityChangeMask|StructureNotifyMask,
04740 WaitVisibilityProc, (ClientData) &done);
04741
04742 rb_thread_critical = thr_crit_bup;
04743
04744 break;
04745
04746 case TKWAIT_WINDOW:
04747 thr_crit_bup = rb_thread_critical;
04748 rb_thread_critical = Qtrue;
04749
04750
04751 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
04752 window = NULL;
04753 } else {
04754 window = Tk_NameToWindow(interp, nameString, tkwin);
04755 }
04756
04757 #if TCL_MAJOR_VERSION >= 8
04758 Tcl_DecrRefCount(objv[2]);
04759 #endif
04760
04761 if (window == NULL) {
04762 Tcl_AppendResult(interp, ": tkwait: ",
04763 "no main-window (not Tk application?)",
04764 (char*)NULL);
04765 rb_thread_critical = thr_crit_bup;
04766 Tcl_Release(interp);
04767 return TCL_ERROR;
04768 }
04769
04770 Tk_CreateEventHandler(window, StructureNotifyMask,
04771 WaitWindowProc, (ClientData) &done);
04772
04773 rb_thread_critical = thr_crit_bup;
04774
04775 done = 0;
04776
04777 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp);
04778
04779
04780 if (!NIL_P(rbtk_pending_exception)) {
04781 Tcl_Release(interp);
04782
04783
04784
04785
04786 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)
04787 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) {
04788 return TCL_RETURN;
04789 } else{
04790 return TCL_ERROR;
04791 }
04792 }
04793
04794
04795 if (rb_thread_check_trap_pending()) {
04796 Tcl_Release(interp);
04797
04798 return TCL_RETURN;
04799 }
04800
04801
04802
04803
04804
04805 break;
04806 }
04807
04808
04809
04810
04811
04812
04813 Tcl_ResetResult(interp);
04814 Tcl_Release(interp);
04815 return TCL_OK;
04816 }
04817
04818
04819
04820
04821 struct th_vwait_param {
04822 VALUE thread;
04823 int done;
04824 };
04825
04826 #if TCL_MAJOR_VERSION >= 8
04827 static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
04828 CONST84 char *,CONST84 char *, int));
04829 static char *
04830 rb_threadVwaitProc(clientData, interp, name1, name2, flags)
04831 ClientData clientData;
04832 Tcl_Interp *interp;
04833 CONST84 char *name1;
04834 CONST84 char *name2;
04835 int flags;
04836 #else
04837 static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
04838 char *, char *, int));
04839 static char *
04840 rb_threadVwaitProc(clientData, interp, name1, name2, flags)
04841 ClientData clientData;
04842 Tcl_Interp *interp;
04843 char *name1;
04844 char *name2;
04845 int flags;
04846 #endif
04847 {
04848 struct th_vwait_param *param = (struct th_vwait_param *) clientData;
04849
04850 if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) {
04851 param->done = -1;
04852 } else {
04853 param->done = 1;
04854 }
04855 if (param->done != 0) rb_thread_wakeup(param->thread);
04856
04857 return (char *)NULL;
04858 }
04859
04860 #define TKWAIT_MODE_VISIBILITY 1
04861 #define TKWAIT_MODE_DESTROY 2
04862
04863 static void rb_threadWaitVisibilityProc _((ClientData, XEvent *));
04864 static void
04865 rb_threadWaitVisibilityProc(clientData, eventPtr)
04866 ClientData clientData;
04867 XEvent *eventPtr;
04868 {
04869 struct th_vwait_param *param = (struct th_vwait_param *) clientData;
04870
04871 if (eventPtr->type == VisibilityNotify) {
04872 param->done = TKWAIT_MODE_VISIBILITY;
04873 }
04874 if (eventPtr->type == DestroyNotify) {
04875 param->done = TKWAIT_MODE_DESTROY;
04876 }
04877 if (param->done != 0) rb_thread_wakeup(param->thread);
04878 }
04879
04880 static void rb_threadWaitWindowProc _((ClientData, XEvent *));
04881 static void
04882 rb_threadWaitWindowProc(clientData, eventPtr)
04883 ClientData clientData;
04884 XEvent *eventPtr;
04885 {
04886 struct th_vwait_param *param = (struct th_vwait_param *) clientData;
04887
04888 if (eventPtr->type == DestroyNotify) {
04889 param->done = TKWAIT_MODE_DESTROY;
04890 }
04891 if (param->done != 0) rb_thread_wakeup(param->thread);
04892 }
04893
04894 #if TCL_MAJOR_VERSION >= 8
04895 static int
04896 ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv)
04897 ClientData clientData;
04898 Tcl_Interp *interp;
04899 int objc;
04900 Tcl_Obj *CONST objv[];
04901 #else
04902 static int
04903 ip_rb_threadVwaitCommand(clientData, interp, objc, objv)
04904 ClientData clientData;
04905 Tcl_Interp *interp;
04906 int objc;
04907 char *objv[];
04908 #endif
04909 {
04910 struct th_vwait_param *param;
04911 char *nameString;
04912 int ret, dummy;
04913 int thr_crit_bup;
04914 volatile VALUE current_thread = rb_thread_current();
04915 struct timeval t;
04916
04917 DUMP1("Ruby's 'thread_vwait' is called");
04918 if (interp == (Tcl_Interp*)NULL) {
04919 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
04920 "IP is deleted");
04921 return TCL_ERROR;
04922 }
04923
04924 if (rb_thread_alone() || eventloop_thread == current_thread) {
04925 #if TCL_MAJOR_VERSION >= 8
04926 DUMP1("call ip_rbVwaitObjCmd");
04927 return ip_rbVwaitObjCmd(clientData, interp, objc, objv);
04928 #else
04929 DUMP1("call ip_rbVwaitCommand");
04930 return ip_rbVwaitCommand(clientData, interp, objc, objv);
04931 #endif
04932 }
04933
04934 Tcl_Preserve(interp);
04935 Tcl_ResetResult(interp);
04936
04937 if (objc != 2) {
04938 #ifdef Tcl_WrongNumArgs
04939 Tcl_WrongNumArgs(interp, 1, objv, "name");
04940 #else
04941 thr_crit_bup = rb_thread_critical;
04942 rb_thread_critical = Qtrue;
04943
04944 #if TCL_MAJOR_VERSION >= 8
04945
04946 nameString = Tcl_GetStringFromObj(objv[0], &dummy);
04947 #else
04948 nameString = objv[0];
04949 #endif
04950 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
04951 nameString, " name\"", (char *) NULL);
04952
04953 rb_thread_critical = thr_crit_bup;
04954 #endif
04955
04956 Tcl_Release(interp);
04957 return TCL_ERROR;
04958 }
04959
04960 #if TCL_MAJOR_VERSION >= 8
04961 Tcl_IncrRefCount(objv[1]);
04962
04963 nameString = Tcl_GetStringFromObj(objv[1], &dummy);
04964 #else
04965 nameString = objv[1];
04966 #endif
04967 thr_crit_bup = rb_thread_critical;
04968 rb_thread_critical = Qtrue;
04969
04970
04971 param = RbTk_ALLOC_N(struct th_vwait_param, 1);
04972 #if 1
04973 Tcl_Preserve((ClientData)param);
04974 #endif
04975 param->thread = current_thread;
04976 param->done = 0;
04977
04978
04979
04980
04981
04982
04983
04984
04985 ret = Tcl_TraceVar(interp, nameString,
04986 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
04987 rb_threadVwaitProc, (ClientData) param);
04988
04989 rb_thread_critical = thr_crit_bup;
04990
04991 if (ret != TCL_OK) {
04992 #if 0
04993 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
04994 #else
04995 #if 1
04996 Tcl_Release((ClientData)param);
04997 #else
04998
04999 ckfree((char *)param);
05000 #endif
05001 #endif
05002
05003 #if TCL_MAJOR_VERSION >= 8
05004 Tcl_DecrRefCount(objv[1]);
05005 #endif
05006 Tcl_Release(interp);
05007 return TCL_ERROR;
05008 }
05009
05010 t.tv_sec = 0;
05011 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05012
05013 while(!param->done) {
05014
05015
05016 rb_thread_wait_for(t);
05017 if (NIL_P(eventloop_thread)) {
05018 break;
05019 }
05020 }
05021
05022 thr_crit_bup = rb_thread_critical;
05023 rb_thread_critical = Qtrue;
05024
05025 if (param->done > 0) {
05026 Tcl_UntraceVar(interp, nameString,
05027 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05028 rb_threadVwaitProc, (ClientData) param);
05029 }
05030
05031 #if 0
05032 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
05033 #else
05034 #if 1
05035 Tcl_Release((ClientData)param);
05036 #else
05037
05038 ckfree((char *)param);
05039 #endif
05040 #endif
05041
05042 rb_thread_critical = thr_crit_bup;
05043
05044 #if TCL_MAJOR_VERSION >= 8
05045 Tcl_DecrRefCount(objv[1]);
05046 #endif
05047 Tcl_Release(interp);
05048 return TCL_OK;
05049 }
05050
05051 #if TCL_MAJOR_VERSION >= 8
05052 static int
05053 ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv)
05054 ClientData clientData;
05055 Tcl_Interp *interp;
05056 int objc;
05057 Tcl_Obj *CONST objv[];
05058 #else
05059 static int
05060 ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
05061 ClientData clientData;
05062 Tcl_Interp *interp;
05063 int objc;
05064 char *objv[];
05065 #endif
05066 {
05067 struct th_vwait_param *param;
05068 Tk_Window tkwin = (Tk_Window) clientData;
05069 Tk_Window window;
05070 int index;
05071 static CONST char *optionStrings[] = { "variable", "visibility", "window",
05072 (char *) NULL };
05073 enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
05074 char *nameString;
05075 int ret, dummy;
05076 int thr_crit_bup;
05077 volatile VALUE current_thread = rb_thread_current();
05078 struct timeval t;
05079
05080 DUMP1("Ruby's 'thread_tkwait' is called");
05081 if (interp == (Tcl_Interp*)NULL) {
05082 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
05083 "IP is deleted");
05084 return TCL_ERROR;
05085 }
05086
05087 if (rb_thread_alone() || eventloop_thread == current_thread) {
05088 #if TCL_MAJOR_VERSION >= 8
05089 DUMP1("call ip_rbTkWaitObjCmd");
05090 DUMP2("eventloop_thread %lx", eventloop_thread);
05091 DUMP2("current_thread %lx", current_thread);
05092 return ip_rbTkWaitObjCmd(clientData, interp, objc, objv);
05093 #else
05094 DUMP1("call rb_VwaitCommand");
05095 return ip_rbTkWaitCommand(clientData, interp, objc, objv);
05096 #endif
05097 }
05098
05099 Tcl_Preserve(interp);
05100 Tcl_Preserve(tkwin);
05101
05102 Tcl_ResetResult(interp);
05103
05104 if (objc != 3) {
05105 #ifdef Tcl_WrongNumArgs
05106 Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
05107 #else
05108 thr_crit_bup = rb_thread_critical;
05109 rb_thread_critical = Qtrue;
05110
05111 #if TCL_MAJOR_VERSION >= 8
05112 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
05113 Tcl_GetStringFromObj(objv[0], &dummy),
05114 " variable|visibility|window name\"",
05115 (char *) NULL);
05116 #else
05117 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
05118 objv[0], " variable|visibility|window name\"",
05119 (char *) NULL);
05120 #endif
05121
05122 rb_thread_critical = thr_crit_bup;
05123 #endif
05124
05125 Tcl_Release(tkwin);
05126 Tcl_Release(interp);
05127 return TCL_ERROR;
05128 }
05129
05130 #if TCL_MAJOR_VERSION >= 8
05131 thr_crit_bup = rb_thread_critical;
05132 rb_thread_critical = Qtrue;
05133
05134
05135
05136
05137
05138
05139
05140 ret = Tcl_GetIndexFromObj(interp, objv[1],
05141 (CONST84 char **)optionStrings,
05142 "option", 0, &index);
05143
05144 rb_thread_critical = thr_crit_bup;
05145
05146 if (ret != TCL_OK) {
05147 Tcl_Release(tkwin);
05148 Tcl_Release(interp);
05149 return TCL_ERROR;
05150 }
05151 #else
05152 {
05153 int c = objv[1][0];
05154 size_t length = strlen(objv[1]);
05155
05156 if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0)
05157 && (length >= 2)) {
05158 index = TKWAIT_VARIABLE;
05159 } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0)
05160 && (length >= 2)) {
05161 index = TKWAIT_VISIBILITY;
05162 } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) {
05163 index = TKWAIT_WINDOW;
05164 } else {
05165 Tcl_AppendResult(interp, "bad option \"", objv[1],
05166 "\": must be variable, visibility, or window",
05167 (char *) NULL);
05168 Tcl_Release(tkwin);
05169 Tcl_Release(interp);
05170 return TCL_ERROR;
05171 }
05172 }
05173 #endif
05174
05175 thr_crit_bup = rb_thread_critical;
05176 rb_thread_critical = Qtrue;
05177
05178 #if TCL_MAJOR_VERSION >= 8
05179 Tcl_IncrRefCount(objv[2]);
05180
05181 nameString = Tcl_GetStringFromObj(objv[2], &dummy);
05182 #else
05183 nameString = objv[2];
05184 #endif
05185
05186
05187 param = RbTk_ALLOC_N(struct th_vwait_param, 1);
05188 #if 1
05189 Tcl_Preserve((ClientData)param);
05190 #endif
05191 param->thread = current_thread;
05192 param->done = 0;
05193
05194 rb_thread_critical = thr_crit_bup;
05195
05196 switch ((enum options) index) {
05197 case TKWAIT_VARIABLE:
05198 thr_crit_bup = rb_thread_critical;
05199 rb_thread_critical = Qtrue;
05200
05201
05202
05203
05204
05205
05206
05207 ret = Tcl_TraceVar(interp, nameString,
05208 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05209 rb_threadVwaitProc, (ClientData) param);
05210
05211 rb_thread_critical = thr_crit_bup;
05212
05213 if (ret != TCL_OK) {
05214 #if 0
05215 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
05216 #else
05217 #if 1
05218 Tcl_Release(param);
05219 #else
05220
05221 ckfree((char *)param);
05222 #endif
05223 #endif
05224
05225 #if TCL_MAJOR_VERSION >= 8
05226 Tcl_DecrRefCount(objv[2]);
05227 #endif
05228
05229 Tcl_Release(tkwin);
05230 Tcl_Release(interp);
05231 return TCL_ERROR;
05232 }
05233
05234 t.tv_sec = 0;
05235 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05236
05237 while(!param->done) {
05238
05239
05240 rb_thread_wait_for(t);
05241 if (NIL_P(eventloop_thread)) {
05242 break;
05243 }
05244 }
05245
05246 thr_crit_bup = rb_thread_critical;
05247 rb_thread_critical = Qtrue;
05248
05249 if (param->done > 0) {
05250 Tcl_UntraceVar(interp, nameString,
05251 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
05252 rb_threadVwaitProc, (ClientData) param);
05253 }
05254
05255 #if TCL_MAJOR_VERSION >= 8
05256 Tcl_DecrRefCount(objv[2]);
05257 #endif
05258
05259 rb_thread_critical = thr_crit_bup;
05260
05261 break;
05262
05263 case TKWAIT_VISIBILITY:
05264 thr_crit_bup = rb_thread_critical;
05265 rb_thread_critical = Qtrue;
05266
05267 #if 0
05268 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
05269 window = NULL;
05270 } else {
05271 window = Tk_NameToWindow(interp, nameString, tkwin);
05272 }
05273 #else
05274 if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
05275 window = NULL;
05276 } else {
05277
05278 Tcl_CmdInfo info;
05279 if (Tcl_GetCommandInfo(interp, ".", &info)) {
05280 window = Tk_NameToWindow(interp, nameString, tkwin);
05281 } else {
05282 window = NULL;
05283 }
05284 }
05285 #endif
05286
05287 if (window == NULL) {
05288 Tcl_AppendResult(interp, ": thread_tkwait: ",
05289 "no main-window (not Tk application?)",
05290 (char*)NULL);
05291
05292 rb_thread_critical = thr_crit_bup;
05293
05294 #if 0
05295 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
05296 #else
05297 #if 1
05298 Tcl_Release(param);
05299 #else
05300
05301 ckfree((char *)param);
05302 #endif
05303 #endif
05304
05305 #if TCL_MAJOR_VERSION >= 8
05306 Tcl_DecrRefCount(objv[2]);
05307 #endif
05308 Tcl_Release(tkwin);
05309 Tcl_Release(interp);
05310 return TCL_ERROR;
05311 }
05312 Tcl_Preserve(window);
05313
05314 Tk_CreateEventHandler(window,
05315 VisibilityChangeMask|StructureNotifyMask,
05316 rb_threadWaitVisibilityProc, (ClientData) param);
05317
05318 rb_thread_critical = thr_crit_bup;
05319
05320 t.tv_sec = 0;
05321 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05322
05323 while(param->done != TKWAIT_MODE_VISIBILITY) {
05324 if (param->done == TKWAIT_MODE_DESTROY) break;
05325
05326
05327 rb_thread_wait_for(t);
05328 if (NIL_P(eventloop_thread)) {
05329 break;
05330 }
05331 }
05332
05333 thr_crit_bup = rb_thread_critical;
05334 rb_thread_critical = Qtrue;
05335
05336
05337 if (param->done != TKWAIT_MODE_DESTROY) {
05338 Tk_DeleteEventHandler(window,
05339 VisibilityChangeMask|StructureNotifyMask,
05340 rb_threadWaitVisibilityProc,
05341 (ClientData) param);
05342 }
05343
05344 if (param->done != 1) {
05345 Tcl_ResetResult(interp);
05346 Tcl_AppendResult(interp, "window \"", nameString,
05347 "\" was deleted before its visibility changed",
05348 (char *) NULL);
05349
05350 rb_thread_critical = thr_crit_bup;
05351
05352 Tcl_Release(window);
05353
05354 #if 0
05355 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
05356 #else
05357 #if 1
05358 Tcl_Release(param);
05359 #else
05360
05361 ckfree((char *)param);
05362 #endif
05363 #endif
05364
05365 #if TCL_MAJOR_VERSION >= 8
05366 Tcl_DecrRefCount(objv[2]);
05367 #endif
05368
05369 Tcl_Release(tkwin);
05370 Tcl_Release(interp);
05371 return TCL_ERROR;
05372 }
05373
05374 Tcl_Release(window);
05375
05376 #if TCL_MAJOR_VERSION >= 8
05377 Tcl_DecrRefCount(objv[2]);
05378 #endif
05379
05380 rb_thread_critical = thr_crit_bup;
05381
05382 break;
05383
05384 case TKWAIT_WINDOW:
05385 thr_crit_bup = rb_thread_critical;
05386 rb_thread_critical = Qtrue;
05387
05388 #if 0
05389 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) {
05390 window = NULL;
05391 } else {
05392 window = Tk_NameToWindow(interp, nameString, tkwin);
05393 }
05394 #else
05395 if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) {
05396 window = NULL;
05397 } else {
05398
05399 Tcl_CmdInfo info;
05400 if (Tcl_GetCommandInfo(interp, ".", &info)) {
05401 window = Tk_NameToWindow(interp, nameString, tkwin);
05402 } else {
05403 window = NULL;
05404 }
05405 }
05406 #endif
05407
05408 #if TCL_MAJOR_VERSION >= 8
05409 Tcl_DecrRefCount(objv[2]);
05410 #endif
05411
05412 if (window == NULL) {
05413 Tcl_AppendResult(interp, ": thread_tkwait: ",
05414 "no main-window (not Tk application?)",
05415 (char*)NULL);
05416
05417 rb_thread_critical = thr_crit_bup;
05418
05419 #if 0
05420 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
05421 #else
05422 #if 1
05423 Tcl_Release(param);
05424 #else
05425
05426 ckfree((char *)param);
05427 #endif
05428 #endif
05429
05430 Tcl_Release(tkwin);
05431 Tcl_Release(interp);
05432 return TCL_ERROR;
05433 }
05434
05435 Tcl_Preserve(window);
05436
05437 Tk_CreateEventHandler(window, StructureNotifyMask,
05438 rb_threadWaitWindowProc, (ClientData) param);
05439
05440 rb_thread_critical = thr_crit_bup;
05441
05442 t.tv_sec = 0;
05443 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
05444
05445 while(param->done != TKWAIT_MODE_DESTROY) {
05446
05447
05448 rb_thread_wait_for(t);
05449 if (NIL_P(eventloop_thread)) {
05450 break;
05451 }
05452 }
05453
05454 Tcl_Release(window);
05455
05456
05457
05458
05459
05460
05461
05462
05463
05464
05465
05466 break;
05467 }
05468
05469 #if 0
05470 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC);
05471 #else
05472 #if 1
05473 Tcl_Release((ClientData)param);
05474 #else
05475
05476 ckfree((char *)param);
05477 #endif
05478 #endif
05479
05480
05481
05482
05483
05484
05485 Tcl_ResetResult(interp);
05486
05487 Tcl_Release(tkwin);
05488 Tcl_Release(interp);
05489 return TCL_OK;
05490 }
05491
05492 static VALUE
05493 ip_thread_vwait(self, var)
05494 VALUE self;
05495 VALUE var;
05496 {
05497 VALUE argv[2];
05498 volatile VALUE cmd_str = rb_str_new2("thread_vwait");
05499
05500 argv[0] = cmd_str;
05501 argv[1] = var;
05502
05503 return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL);
05504 }
05505
05506 static VALUE
05507 ip_thread_tkwait(self, mode, target)
05508 VALUE self;
05509 VALUE mode;
05510 VALUE target;
05511 {
05512 VALUE argv[3];
05513 volatile VALUE cmd_str = rb_str_new2("thread_tkwait");
05514
05515 argv[0] = cmd_str;
05516 argv[1] = mode;
05517 argv[2] = target;
05518
05519 return ip_invoke_with_position(3, argv, self, TCL_QUEUE_TAIL);
05520 }
05521
05522
05523
05524 #if TCL_MAJOR_VERSION >= 8
05525 static void
05526 delete_slaves(ip)
05527 Tcl_Interp *ip;
05528 {
05529 int thr_crit_bup;
05530 Tcl_Interp *slave;
05531 Tcl_Obj *slave_list, *elem;
05532 char *slave_name;
05533 int i, len;
05534
05535 DUMP1("delete slaves");
05536 thr_crit_bup = rb_thread_critical;
05537 rb_thread_critical = Qtrue;
05538
05539 if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
05540 slave_list = Tcl_GetObjResult(ip);
05541 Tcl_IncrRefCount(slave_list);
05542
05543 if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) {
05544 for(i = 0; i < len; i++) {
05545 Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem);
05546
05547 if (elem == (Tcl_Obj*)NULL) continue;
05548
05549 Tcl_IncrRefCount(elem);
05550
05551
05552
05553 slave_name = Tcl_GetStringFromObj(elem, (int*)NULL);
05554 DUMP2("delete slave:'%s'", slave_name);
05555
05556 Tcl_DecrRefCount(elem);
05557
05558 slave = Tcl_GetSlave(ip, slave_name);
05559 if (slave == (Tcl_Interp*)NULL) continue;
05560
05561 if (!Tcl_InterpDeleted(slave)) {
05562
05563 ip_finalize(slave);
05564
05565 Tcl_DeleteInterp(slave);
05566
05567 }
05568 }
05569 }
05570
05571 Tcl_DecrRefCount(slave_list);
05572 }
05573
05574 rb_thread_critical = thr_crit_bup;
05575 }
05576 #else
05577 static void
05578 delete_slaves(ip)
05579 Tcl_Interp *ip;
05580 {
05581 int thr_crit_bup;
05582 Tcl_Interp *slave;
05583 int argc;
05584 char **argv;
05585 char *slave_list;
05586 char *slave_name;
05587 int i, len;
05588
05589 DUMP1("delete slaves");
05590 thr_crit_bup = rb_thread_critical;
05591 rb_thread_critical = Qtrue;
05592
05593 if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) {
05594 slave_list = ip->result;
05595 if (Tcl_SplitList((Tcl_Interp*)NULL,
05596 slave_list, &argc, &argv) == TCL_OK) {
05597 for(i = 0; i < argc; i++) {
05598 slave_name = argv[i];
05599
05600 DUMP2("delete slave:'%s'", slave_name);
05601
05602 slave = Tcl_GetSlave(ip, slave_name);
05603 if (slave == (Tcl_Interp*)NULL) continue;
05604
05605 if (!Tcl_InterpDeleted(slave)) {
05606
05607 ip_finalize(slave);
05608
05609 Tcl_DeleteInterp(slave);
05610 }
05611 }
05612 }
05613 }
05614
05615 rb_thread_critical = thr_crit_bup;
05616 }
05617 #endif
05618
05619
05620
05621 static void
05622 #ifdef HAVE_PROTOTYPES
05623 lib_mark_at_exit(VALUE self)
05624 #else
05625 lib_mark_at_exit(self)
05626 VALUE self;
05627 #endif
05628 {
05629 at_exit = 1;
05630 }
05631
05632 static int
05633 #if TCL_MAJOR_VERSION >= 8
05634 #ifdef HAVE_PROTOTYPES
05635 ip_null_proc(ClientData clientData, Tcl_Interp *interp,
05636 int argc, Tcl_Obj *CONST argv[])
05637 #else
05638 ip_null_proc(clientData, interp, argc, argv)
05639 ClientData clientData;
05640 Tcl_Interp *interp;
05641 int argc;
05642 Tcl_Obj *CONST argv[];
05643 #endif
05644 #else
05645 #ifdef HAVE_PROTOTYPES
05646 ip_null_proc(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
05647 #else
05648 ip_null_proc(clientData, interp, argc, argv)
05649 ClientData clientData;
05650 Tcl_Interp *interp;
05651 int argc;
05652 char *argv[];
05653 #endif
05654 #endif
05655 {
05656 Tcl_ResetResult(interp);
05657 return TCL_OK;
05658 }
05659
05660 static void
05661 ip_finalize(ip)
05662 Tcl_Interp *ip;
05663 {
05664 Tcl_CmdInfo info;
05665 int thr_crit_bup;
05666
05667 VALUE rb_debug_bup, rb_verbose_bup;
05668
05669
05670
05671
05672
05673
05674
05675 DUMP1("start ip_finalize");
05676
05677 if (ip == (Tcl_Interp*)NULL) {
05678 DUMP1("ip is NULL");
05679 return;
05680 }
05681
05682 if (Tcl_InterpDeleted(ip)) {
05683 DUMP2("ip(%p) is already deleted", ip);
05684 return;
05685 }
05686
05687 #if TCL_NAMESPACE_DEBUG
05688 if (ip_null_namespace(ip)) {
05689 DUMP2("ip(%p) has null namespace", ip);
05690 return;
05691 }
05692 #endif
05693
05694 thr_crit_bup = rb_thread_critical;
05695 rb_thread_critical = Qtrue;
05696
05697 rb_debug_bup = ruby_debug;
05698 rb_verbose_bup = ruby_verbose;
05699
05700 Tcl_Preserve(ip);
05701
05702
05703 delete_slaves(ip);
05704
05705
05706 if (at_exit) {
05707
05708
05709
05710
05711 #if TCL_MAJOR_VERSION >= 8
05712 Tcl_CreateObjCommand(ip, "ruby", ip_null_proc,
05713 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05714 Tcl_CreateObjCommand(ip, "ruby_eval", ip_null_proc,
05715 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05716 Tcl_CreateObjCommand(ip, "ruby_cmd", ip_null_proc,
05717 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05718 #else
05719 Tcl_CreateCommand(ip, "ruby", ip_null_proc,
05720 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05721 Tcl_CreateCommand(ip, "ruby_eval", ip_null_proc,
05722 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05723 Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc,
05724 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05725 #endif
05726
05727
05728
05729
05730 }
05731
05732
05733 #ifdef RUBY_VM
05734
05735 #else
05736 DUMP1("check `destroy'");
05737 if (Tcl_GetCommandInfo(ip, "destroy", &info)) {
05738 DUMP1("call `destroy .'");
05739 Tcl_GlobalEval(ip, "catch {destroy .}");
05740 }
05741 #endif
05742 #if 1
05743 DUMP1("destroy root widget");
05744 if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) {
05745
05746
05747
05748
05749
05750
05751
05752
05753
05754
05755
05756
05757 Tk_Window win = Tk_MainWindow(ip);
05758
05759 DUMP1("call Tk_DestroyWindow");
05760 ruby_debug = Qfalse;
05761 ruby_verbose = Qnil;
05762 if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) {
05763 Tk_DestroyWindow(win);
05764 }
05765 ruby_debug = rb_debug_bup;
05766 ruby_verbose = rb_verbose_bup;
05767 }
05768 #endif
05769
05770
05771 DUMP1("check `finalize-hook-proc'");
05772 if ( Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) {
05773 DUMP2("call finalize hook proc '%s'", finalize_hook_name);
05774 ruby_debug = Qfalse;
05775 ruby_verbose = Qnil;
05776 Tcl_GlobalEval(ip, finalize_hook_name);
05777 ruby_debug = rb_debug_bup;
05778 ruby_verbose = rb_verbose_bup;
05779 }
05780
05781 DUMP1("check `foreach' & `after'");
05782 if ( Tcl_GetCommandInfo(ip, "foreach", &info)
05783 && Tcl_GetCommandInfo(ip, "after", &info) ) {
05784 DUMP1("cancel after callbacks");
05785 ruby_debug = Qfalse;
05786 ruby_verbose = Qnil;
05787 Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}");
05788 ruby_debug = rb_debug_bup;
05789 ruby_verbose = rb_verbose_bup;
05790 }
05791
05792 Tcl_Release(ip);
05793
05794 DUMP1("finish ip_finalize");
05795 ruby_debug = rb_debug_bup;
05796 ruby_verbose = rb_verbose_bup;
05797 rb_thread_critical = thr_crit_bup;
05798 }
05799
05800
05801
05802 static void
05803 ip_free(ptr)
05804 struct tcltkip *ptr;
05805 {
05806 int thr_crit_bup;
05807
05808 DUMP2("free Tcl Interp %lx", (unsigned long)ptr->ip);
05809 if (ptr) {
05810 thr_crit_bup = rb_thread_critical;
05811 rb_thread_critical = Qtrue;
05812
05813 if ( ptr->ip != (Tcl_Interp*)NULL
05814 && !Tcl_InterpDeleted(ptr->ip)
05815 && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL
05816 && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) {
05817 DUMP2("parent IP(%lx) is not deleted",
05818 (unsigned long)Tcl_GetMaster(ptr->ip));
05819 DUMP2("slave IP(%lx) should not be deleted",
05820 (unsigned long)ptr->ip);
05821 xfree(ptr);
05822
05823 rb_thread_critical = thr_crit_bup;
05824 return;
05825 }
05826
05827 if (ptr->ip == (Tcl_Interp*)NULL) {
05828 DUMP1("ip_free is called for deleted IP");
05829 xfree(ptr);
05830
05831 rb_thread_critical = thr_crit_bup;
05832 return;
05833 }
05834
05835 if (!Tcl_InterpDeleted(ptr->ip)) {
05836 ip_finalize(ptr->ip);
05837
05838 Tcl_DeleteInterp(ptr->ip);
05839 Tcl_Release(ptr->ip);
05840 }
05841
05842 ptr->ip = (Tcl_Interp*)NULL;
05843 xfree(ptr);
05844
05845
05846 rb_thread_critical = thr_crit_bup;
05847 }
05848
05849 DUMP1("complete freeing Tcl Interp");
05850 }
05851
05852
05853
05854 static VALUE ip_alloc _((VALUE));
05855 static VALUE
05856 ip_alloc(self)
05857 VALUE self;
05858 {
05859 return Data_Wrap_Struct(self, 0, ip_free, 0);
05860 }
05861
05862 static void
05863 ip_replace_wait_commands(interp, mainWin)
05864 Tcl_Interp *interp;
05865 Tk_Window mainWin;
05866 {
05867
05868 #if TCL_MAJOR_VERSION >= 8
05869 DUMP1("Tcl_CreateObjCommand(\"vwait\")");
05870 Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd,
05871 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05872 #else
05873 DUMP1("Tcl_CreateCommand(\"vwait\")");
05874 Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand,
05875 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05876 #endif
05877
05878
05879 #if TCL_MAJOR_VERSION >= 8
05880 DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
05881 Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd,
05882 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05883 #else
05884 DUMP1("Tcl_CreateCommand(\"tkwait\")");
05885 Tcl_CreateCommand(interp, "tkwait", ip_rbTkWaitCommand,
05886 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05887 #endif
05888
05889
05890 #if TCL_MAJOR_VERSION >= 8
05891 DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")");
05892 Tcl_CreateObjCommand(interp, "thread_vwait", ip_rb_threadVwaitObjCmd,
05893 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05894 #else
05895 DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
05896 Tcl_CreateCommand(interp, "thread_vwait", ip_rb_threadVwaitCommand,
05897 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
05898 #endif
05899
05900
05901 #if TCL_MAJOR_VERSION >= 8
05902 DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
05903 Tcl_CreateObjCommand(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
05904 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05905 #else
05906 DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
05907 Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand,
05908 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05909 #endif
05910
05911
05912 #if TCL_MAJOR_VERSION >= 8
05913 DUMP1("Tcl_CreateObjCommand(\"update\")");
05914 Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd,
05915 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05916 #else
05917 DUMP1("Tcl_CreateCommand(\"update\")");
05918 Tcl_CreateCommand(interp, "update", ip_rbUpdateCommand,
05919 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05920 #endif
05921
05922
05923 #if TCL_MAJOR_VERSION >= 8
05924 DUMP1("Tcl_CreateObjCommand(\"thread_update\")");
05925 Tcl_CreateObjCommand(interp, "thread_update", ip_rb_threadUpdateObjCmd,
05926 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05927 #else
05928 DUMP1("Tcl_CreateCommand(\"thread_update\")");
05929 Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand,
05930 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05931 #endif
05932 }
05933
05934
05935 #if TCL_MAJOR_VERSION >= 8
05936 static int
05937 ip_rb_replaceSlaveTkCmdsObjCmd(clientData, interp, objc, objv)
05938 ClientData clientData;
05939 Tcl_Interp *interp;
05940 int objc;
05941 Tcl_Obj *CONST objv[];
05942 #else
05943 static int
05944 ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv)
05945 ClientData clientData;
05946 Tcl_Interp *interp;
05947 int objc;
05948 char *objv[];
05949 #endif
05950 {
05951 char *slave_name;
05952 Tcl_Interp *slave;
05953 Tk_Window mainWin;
05954
05955 if (objc != 2) {
05956 #ifdef Tcl_WrongNumArgs
05957 Tcl_WrongNumArgs(interp, 1, objv, "slave_name");
05958 #else
05959 char *nameString;
05960 #if TCL_MAJOR_VERSION >= 8
05961 nameString = Tcl_GetStringFromObj(objv[0], (int*)NULL);
05962 #else
05963 nameString = objv[0];
05964 #endif
05965 Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
05966 nameString, " slave_name\"", (char *) NULL);
05967 #endif
05968 }
05969
05970 #if TCL_MAJOR_VERSION >= 8
05971 slave_name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
05972 #else
05973 slave_name = objv[1];
05974 #endif
05975
05976 slave = Tcl_GetSlave(interp, slave_name);
05977 if (slave == NULL) {
05978 Tcl_AppendResult(interp, "cannot find slave \"",
05979 slave_name, "\"", (char *)NULL);
05980 return TCL_ERROR;
05981 }
05982 mainWin = Tk_MainWindow(slave);
05983
05984
05985 #if TCL_MAJOR_VERSION >= 8
05986 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
05987 Tcl_CreateObjCommand(slave, "exit", ip_InterpExitObjCmd,
05988 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05989 #else
05990 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
05991 Tcl_CreateCommand(slave, "exit", ip_InterpExitCommand,
05992 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
05993 #endif
05994
05995
05996 ip_replace_wait_commands(slave, mainWin);
05997
05998 return TCL_OK;
05999 }
06000
06001
06002 #if TCL_MAJOR_VERSION >= 8
06003 static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int,
06004 Tcl_Obj *CONST []));
06005 static int
06006 ip_rbNamespaceObjCmd(clientData, interp, objc, objv)
06007 ClientData clientData;
06008 Tcl_Interp *interp;
06009 int objc;
06010 Tcl_Obj *CONST objv[];
06011 {
06012 Tcl_CmdInfo info;
06013 int ret;
06014
06015 DUMP1("call ip_rbNamespaceObjCmd");
06016 DUMP2("objc = %d", objc);
06017 DUMP2("objv[0] = '%s'", Tcl_GetString(objv[0]));
06018 DUMP2("objv[1] = '%s'", Tcl_GetString(objv[1]));
06019 if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) {
06020 DUMP1("fail to get __orig_namespace_command__");
06021 Tcl_ResetResult(interp);
06022 Tcl_AppendResult(interp,
06023 "invalid command name \"namespace\"", (char*)NULL);
06024 return TCL_ERROR;
06025 }
06026
06027 rbtk_eventloop_depth++;
06028 DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth);
06029
06030 if (info.isNativeObjectProc) {
06031 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6
06032 DUMP1("call a native-object-proc");
06033 ret = (*(info.objProc))(info.objClientData, interp, objc, objv);
06034 #else
06035
06036 int i;
06037 Tcl_Obj **cp_objv;
06038 char org_ns_cmd_name[] = "__orig_namespace_command__";
06039
06040 DUMP1("call a native-object-proc for tcl8.6 or later");
06041 cp_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc + 1));
06042
06043 cp_objv[0] = Tcl_NewStringObj(org_ns_cmd_name, strlen(org_ns_cmd_name));
06044 for(i = 1; i < objc; i++) {
06045 cp_objv[i] = objv[i];
06046 }
06047 cp_objv[objc] = (Tcl_Obj *)NULL;
06048
06049
06050 ret = Tcl_EvalObjv(interp, objc, cp_objv, 0);
06051
06052 ckfree((char*)cp_objv);
06053 #endif
06054 } else {
06055
06056 int i;
06057 char **argv;
06058
06059 DUMP1("call with the string-interface");
06060
06061 argv = RbTk_ALLOC_N(char *, (objc + 1));
06062 #if 0
06063 Tcl_Preserve((ClientData)argv);
06064 #endif
06065
06066 for(i = 0; i < objc; i++) {
06067
06068 argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
06069 }
06070 argv[objc] = (char *)NULL;
06071
06072 ret = (*(info.proc))(info.clientData, interp,
06073 objc, (CONST84 char **)argv);
06074
06075 #if 0
06076 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
06077 #else
06078 #if 0
06079 Tcl_Release((ClientData)argv);
06080 #else
06081
06082 ckfree((char*)argv);
06083 #endif
06084 #endif
06085 }
06086
06087 DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth);
06088 rbtk_eventloop_depth--;
06089
06090 DUMP1("end of ip_rbNamespaceObjCmd");
06091 return ret;
06092 }
06093 #endif
06094
06095 static void
06096 ip_wrap_namespace_command(interp)
06097 Tcl_Interp *interp;
06098 {
06099 #if TCL_MAJOR_VERSION >= 8
06100
06101 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6
06102 Tcl_CmdInfo orig_info;
06103
06104 if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) {
06105 return;
06106 }
06107
06108 if (orig_info.isNativeObjectProc) {
06109 Tcl_CreateObjCommand(interp, "__orig_namespace_command__",
06110 orig_info.objProc, orig_info.objClientData,
06111 orig_info.deleteProc);
06112 } else {
06113 Tcl_CreateCommand(interp, "__orig_namespace_command__",
06114 orig_info.proc, orig_info.clientData,
06115 orig_info.deleteProc);
06116 }
06117
06118 #else
06119 Tcl_GlobalEval(interp, "rename namespace __orig_namespace_command__");
06120
06121 #endif
06122
06123 Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd,
06124 (ClientData) 0, (Tcl_CmdDeleteProc *)NULL);
06125 #endif
06126 }
06127
06128
06129
06130 static void
06131 #ifdef HAVE_PROTOTYPES
06132 ip_CallWhenDeleted(ClientData clientData, Tcl_Interp *ip)
06133 #else
06134 ip_CallWhenDeleted(clientData, ip)
06135 ClientData clientData;
06136 Tcl_Interp *ip;
06137 #endif
06138 {
06139 int thr_crit_bup;
06140
06141
06142 DUMP1("start ip_CallWhenDeleted");
06143 thr_crit_bup = rb_thread_critical;
06144 rb_thread_critical = Qtrue;
06145
06146 ip_finalize(ip);
06147
06148 DUMP1("finish ip_CallWhenDeleted");
06149 rb_thread_critical = thr_crit_bup;
06150 }
06151
06152
06153
06154
06155 static VALUE
06156 ip_init(argc, argv, self)
06157 int argc;
06158 VALUE *argv;
06159 VALUE self;
06160 {
06161 struct tcltkip *ptr;
06162 VALUE argv0, opts;
06163 int cnt;
06164 int st;
06165 int with_tk = 1;
06166 Tk_Window mainWin = (Tk_Window)NULL;
06167
06168
06169 if (rb_safe_level() >= 4) {
06170 rb_raise(rb_eSecurityError,
06171 "Cannot create a TclTkIp object at level %d",
06172 rb_safe_level());
06173 }
06174
06175
06176 Data_Get_Struct(self, struct tcltkip, ptr);
06177 ptr = ALLOC(struct tcltkip);
06178
06179 DATA_PTR(self) = ptr;
06180 #ifdef RUBY_USE_NATIVE_THREAD
06181 ptr->tk_thread_id = 0;
06182 #endif
06183 ptr->ref_count = 0;
06184 ptr->allow_ruby_exit = 1;
06185 ptr->return_value = 0;
06186
06187
06188 DUMP1("Tcl_CreateInterp");
06189 ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st);
06190 if (ptr->ip == NULL) {
06191 switch(st) {
06192 case TCLTK_STUBS_OK:
06193 break;
06194 case NO_TCL_DLL:
06195 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
06196 case NO_FindExecutable:
06197 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
06198 case NO_CreateInterp:
06199 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()");
06200 case NO_DeleteInterp:
06201 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()");
06202 case FAIL_CreateInterp:
06203 rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP");
06204 case FAIL_Tcl_InitStubs:
06205 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()");
06206 default:
06207 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_create_ip_and_stubs_init", st);
06208 }
06209 }
06210
06211 #if TCL_MAJOR_VERSION >= 8
06212 #if TCL_NAMESPACE_DEBUG
06213 DUMP1("get current namespace");
06214 if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip))
06215 == (Tcl_Namespace*)NULL) {
06216 rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace");
06217 }
06218 #endif
06219 #endif
06220
06221 rbtk_preserve_ip(ptr);
06222 DUMP2("IP ref_count = %d", ptr->ref_count);
06223 current_interp = ptr->ip;
06224
06225 ptr->has_orig_exit
06226 = Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info));
06227
06228 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
06229 call_tclkit_init_script(current_interp);
06230
06231 # if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
06232 {
06233 Tcl_DString encodingName;
06234 Tcl_GetEncodingNameFromEnvironment(&encodingName);
06235 if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
06236
06237 Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
06238 }
06239 Tcl_SetVar(current_interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0);
06240 Tcl_DStringFree(&encodingName);
06241 }
06242 # endif
06243 #endif
06244
06245
06246 Tcl_Eval(ptr->ip, "set argc 0; set argv {}; set argv0 tcltklib.so");
06247
06248 cnt = rb_scan_args(argc, argv, "02", &argv0, &opts);
06249 switch(cnt) {
06250 case 2:
06251
06252 if (NIL_P(opts) || opts == Qfalse) {
06253
06254 with_tk = 0;
06255 } else {
06256
06257 Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY);
06258 Tcl_Eval(ptr->ip, "set argc [llength $argv]");
06259 }
06260 case 1:
06261
06262 if (!NIL_P(argv0)) {
06263 if (strncmp(StringValuePtr(argv0), "-e", 3) == 0
06264 || strncmp(StringValuePtr(argv0), "-", 2) == 0) {
06265 Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY);
06266 } else {
06267
06268 Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0),
06269 TCL_GLOBAL_ONLY);
06270 }
06271 }
06272 case 0:
06273
06274 ;
06275 }
06276
06277
06278 DUMP1("Tcl_Init");
06279 #if (defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT) && (!defined KIT_LITE) && (10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION == 85)
06280
06281
06282
06283
06284
06285
06286 Tcl_Eval(ptr->ip, "catch {rename ::chan ::_tmp_chan}");
06287 if (Tcl_Init(ptr->ip) == TCL_ERROR) {
06288 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
06289 }
06290 Tcl_Eval(ptr->ip, "catch {rename ::_tmp_chan ::chan}");
06291 #else
06292 if (Tcl_Init(ptr->ip) == TCL_ERROR) {
06293 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
06294 }
06295 #endif
06296
06297 st = ruby_tcl_stubs_init();
06298
06299 if (with_tk) {
06300 DUMP1("Tk_Init");
06301 st = ruby_tk_stubs_init(ptr->ip);
06302 switch(st) {
06303 case TCLTK_STUBS_OK:
06304 break;
06305 case NO_Tk_Init:
06306 rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()");
06307 case FAIL_Tk_Init:
06308 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s",
06309 Tcl_GetStringResult(ptr->ip));
06310 case FAIL_Tk_InitStubs:
06311 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s",
06312 Tcl_GetStringResult(ptr->ip));
06313 default:
06314 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st);
06315 }
06316
06317 DUMP1("Tcl_StaticPackage(\"Tk\")");
06318 #if TCL_MAJOR_VERSION >= 8
06319 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
06320 #else
06321 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
06322 (Tcl_PackageInitProc *) NULL);
06323 #endif
06324
06325 #ifdef RUBY_USE_NATIVE_THREAD
06326
06327 ptr->tk_thread_id = Tcl_GetCurrentThread();
06328 #endif
06329
06330 mainWin = Tk_MainWindow(ptr->ip);
06331 Tk_Preserve((ClientData)mainWin);
06332 }
06333
06334
06335 #if TCL_MAJOR_VERSION >= 8
06336 DUMP1("Tcl_CreateObjCommand(\"ruby\")");
06337 Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
06338 (Tcl_CmdDeleteProc *)NULL);
06339 DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")");
06340 Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
06341 (Tcl_CmdDeleteProc *)NULL);
06342 DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")");
06343 Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
06344 (Tcl_CmdDeleteProc *)NULL);
06345 #else
06346 DUMP1("Tcl_CreateCommand(\"ruby\")");
06347 Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
06348 (Tcl_CmdDeleteProc *)NULL);
06349 DUMP1("Tcl_CreateCommand(\"ruby_eval\")");
06350 Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
06351 (Tcl_CmdDeleteProc *)NULL);
06352 DUMP1("Tcl_CreateCommand(\"ruby_cmd\")");
06353 Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
06354 (Tcl_CmdDeleteProc *)NULL);
06355 #endif
06356
06357
06358 #if TCL_MAJOR_VERSION >= 8
06359 DUMP1("Tcl_CreateObjCommand(\"interp_exit\")");
06360 Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd,
06361 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06362 DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")");
06363 Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd,
06364 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06365 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
06366 Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
06367 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06368 #else
06369 DUMP1("Tcl_CreateCommand(\"interp_exit\")");
06370 Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand,
06371 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06372 DUMP1("Tcl_CreateCommand(\"ruby_exit\")");
06373 Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand,
06374 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06375 DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
06376 Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
06377 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06378 #endif
06379
06380
06381 ip_replace_wait_commands(ptr->ip, mainWin);
06382
06383
06384 ip_wrap_namespace_command(ptr->ip);
06385
06386
06387 #if TCL_MAJOR_VERSION >= 8
06388 Tcl_CreateObjCommand(ptr->ip, "__replace_slave_tk_commands__",
06389 ip_rb_replaceSlaveTkCmdsObjCmd,
06390 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06391 #else
06392 Tcl_CreateCommand(ptr->ip, "__replace_slave_tk_commands__",
06393 ip_rb_replaceSlaveTkCmdsCommand,
06394 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06395 #endif
06396
06397
06398 Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin);
06399
06400 if (mainWin != (Tk_Window)NULL) {
06401 Tk_Release((ClientData)mainWin);
06402 }
06403
06404 return self;
06405 }
06406
06407 static VALUE
06408 ip_create_slave_core(interp, argc, argv)
06409 VALUE interp;
06410 int argc;
06411 VALUE *argv;
06412 {
06413 struct tcltkip *master = get_ip(interp);
06414 struct tcltkip *slave = ALLOC(struct tcltkip);
06415
06416 VALUE safemode;
06417 VALUE name;
06418 int safe;
06419 int thr_crit_bup;
06420 Tk_Window mainWin;
06421
06422
06423 if (deleted_ip(master)) {
06424 return rb_exc_new2(rb_eRuntimeError,
06425 "deleted master cannot create a new slave");
06426 }
06427
06428 name = argv[0];
06429 safemode = argv[1];
06430
06431 if (Tcl_IsSafe(master->ip) == 1) {
06432 safe = 1;
06433 } else if (safemode == Qfalse || NIL_P(safemode)) {
06434 safe = 0;
06435 } else {
06436 safe = 1;
06437 }
06438
06439 thr_crit_bup = rb_thread_critical;
06440 rb_thread_critical = Qtrue;
06441
06442 #if 0
06443
06444 if (RTEST(with_tk)) {
06445 volatile VALUE exc;
06446 if (!tk_stubs_init_p()) {
06447 exc = tcltkip_init_tk(interp);
06448 if (!NIL_P(exc)) {
06449 rb_thread_critical = thr_crit_bup;
06450 return exc;
06451 }
06452 }
06453 }
06454 #endif
06455
06456
06457 #ifdef RUBY_USE_NATIVE_THREAD
06458
06459 slave->tk_thread_id = master->tk_thread_id;
06460 #endif
06461 slave->ref_count = 0;
06462 slave->allow_ruby_exit = 0;
06463 slave->return_value = 0;
06464
06465 slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
06466 if (slave->ip == NULL) {
06467 rb_thread_critical = thr_crit_bup;
06468 return rb_exc_new2(rb_eRuntimeError,
06469 "fail to create the new slave interpreter");
06470 }
06471 #if TCL_MAJOR_VERSION >= 8
06472 #if TCL_NAMESPACE_DEBUG
06473 slave->default_ns = Tcl_GetCurrentNamespace(slave->ip);
06474 #endif
06475 #endif
06476 rbtk_preserve_ip(slave);
06477
06478 slave->has_orig_exit
06479 = Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info));
06480
06481
06482 mainWin = (tk_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL;
06483 #if TCL_MAJOR_VERSION >= 8
06484 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06485 Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd,
06486 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06487 #else
06488 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06489 Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand,
06490 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06491 #endif
06492
06493
06494 ip_replace_wait_commands(slave->ip, mainWin);
06495
06496
06497 ip_wrap_namespace_command(slave->ip);
06498
06499
06500 #if TCL_MAJOR_VERSION >= 8
06501 Tcl_CreateObjCommand(slave->ip, "__replace_slave_tk_commands__",
06502 ip_rb_replaceSlaveTkCmdsObjCmd,
06503 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06504 #else
06505 Tcl_CreateCommand(slave->ip, "__replace_slave_tk_commands__",
06506 ip_rb_replaceSlaveTkCmdsCommand,
06507 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
06508 #endif
06509
06510
06511 Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin);
06512
06513 rb_thread_critical = thr_crit_bup;
06514
06515 return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave);
06516 }
06517
06518 static VALUE
06519 ip_create_slave(argc, argv, self)
06520 int argc;
06521 VALUE *argv;
06522 VALUE self;
06523 {
06524 struct tcltkip *master = get_ip(self);
06525 VALUE safemode;
06526 VALUE name;
06527 VALUE callargv[2];
06528
06529
06530 if (deleted_ip(master)) {
06531 rb_raise(rb_eRuntimeError,
06532 "deleted master cannot create a new slave interpreter");
06533 }
06534
06535
06536 if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
06537 safemode = Qfalse;
06538 }
06539 if (Tcl_IsSafe(master->ip) != 1
06540 && (safemode == Qfalse || NIL_P(safemode))) {
06541 }
06542
06543 StringValue(name);
06544 callargv[0] = name;
06545 callargv[1] = safemode;
06546
06547 return tk_funcall(ip_create_slave_core, 2, callargv, self);
06548 }
06549
06550
06551
06552 static VALUE
06553 ip_is_slave_of_p(self, master)
06554 VALUE self, master;
06555 {
06556 if (!rb_obj_is_kind_of(master, tcltkip_class)) {
06557 rb_raise(rb_eArgError, "expected TclTkIp object");
06558 }
06559
06560 if (Tcl_GetMaster(get_ip(self)->ip) == get_ip(master)->ip) {
06561 return Qtrue;
06562 } else {
06563 return Qfalse;
06564 }
06565 }
06566
06567
06568
06569 #if defined(MAC_TCL) || defined(__WIN32__)
06570 #if TCL_MAJOR_VERSION < 8 \
06571 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \
06572 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
06573 && (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \
06574 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
06575 && TCL_RELEASE_SERIAL < 2) ) )
06576 EXTERN void TkConsoleCreate _((void));
06577 #endif
06578 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
06579 && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
06580 && TCL_RELEASE_SERIAL == 0) \
06581 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \
06582 && TCL_RELEASE_SERIAL >= 2) )
06583 EXTERN void TkConsoleCreate_ _((void));
06584 #endif
06585 #endif
06586 static VALUE
06587 ip_create_console_core(interp, argc, argv)
06588 VALUE interp;
06589 int argc;
06590 VALUE *argv;
06591 {
06592 struct tcltkip *ptr = get_ip(interp);
06593
06594 if (!tk_stubs_init_p()) {
06595 tcltkip_init_tk(interp);
06596 }
06597
06598 if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) {
06599 Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
06600 }
06601
06602 #if TCL_MAJOR_VERSION > 8 \
06603 || (TCL_MAJOR_VERSION == 8 \
06604 && (TCL_MINOR_VERSION > 1 \
06605 || (TCL_MINOR_VERSION == 1 \
06606 && TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \
06607 && TCL_RELEASE_SERIAL >= 1) ) )
06608 Tk_InitConsoleChannels(ptr->ip);
06609
06610 if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) {
06611 rb_raise(rb_eRuntimeError, "fail to create console-window");
06612 }
06613 #else
06614 #if defined(MAC_TCL) || defined(__WIN32__)
06615 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \
06616 && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \
06617 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) )
06618 TkConsoleCreate_();
06619 #else
06620 TkConsoleCreate();
06621 #endif
06622
06623 if (TkConsoleInit(ptr->ip) != TCL_OK) {
06624 rb_raise(rb_eRuntimeError, "fail to create console-window");
06625 }
06626 #else
06627 rb_notimplement();
06628 #endif
06629 #endif
06630
06631 return interp;
06632 }
06633
06634 static VALUE
06635 ip_create_console(self)
06636 VALUE self;
06637 {
06638 struct tcltkip *ptr = get_ip(self);
06639
06640
06641 if (deleted_ip(ptr)) {
06642 rb_raise(rb_eRuntimeError, "interpreter is deleted");
06643 }
06644
06645 return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self);
06646 }
06647
06648
06649 static VALUE
06650 ip_make_safe_core(interp, argc, argv)
06651 VALUE interp;
06652 int argc;
06653 VALUE *argv;
06654 {
06655 struct tcltkip *ptr = get_ip(interp);
06656 Tk_Window mainWin;
06657
06658
06659 if (deleted_ip(ptr)) {
06660 return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
06661 }
06662
06663 if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
06664
06665
06666 return create_ip_exc(interp, rb_eRuntimeError,
06667 Tcl_GetStringResult(ptr->ip));
06668 }
06669
06670 ptr->allow_ruby_exit = 0;
06671
06672
06673 mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
06674 #if TCL_MAJOR_VERSION >= 8
06675 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06676 Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
06677 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06678 #else
06679 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06680 Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
06681 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06682 #endif
06683
06684 return interp;
06685 }
06686
06687 static VALUE
06688 ip_make_safe(self)
06689 VALUE self;
06690 {
06691 struct tcltkip *ptr = get_ip(self);
06692
06693
06694 if (deleted_ip(ptr)) {
06695 rb_raise(rb_eRuntimeError, "interpreter is deleted");
06696 }
06697
06698 return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self);
06699 }
06700
06701
06702 static VALUE
06703 ip_is_safe_p(self)
06704 VALUE self;
06705 {
06706 struct tcltkip *ptr = get_ip(self);
06707
06708
06709 if (deleted_ip(ptr)) {
06710 rb_raise(rb_eRuntimeError, "interpreter is deleted");
06711 }
06712
06713 if (Tcl_IsSafe(ptr->ip)) {
06714 return Qtrue;
06715 } else {
06716 return Qfalse;
06717 }
06718 }
06719
06720
06721 static VALUE
06722 ip_allow_ruby_exit_p(self)
06723 VALUE self;
06724 {
06725 struct tcltkip *ptr = get_ip(self);
06726
06727
06728 if (deleted_ip(ptr)) {
06729 rb_raise(rb_eRuntimeError, "interpreter is deleted");
06730 }
06731
06732 if (ptr->allow_ruby_exit) {
06733 return Qtrue;
06734 } else {
06735 return Qfalse;
06736 }
06737 }
06738
06739
06740 static VALUE
06741 ip_allow_ruby_exit_set(self, val)
06742 VALUE self, val;
06743 {
06744 struct tcltkip *ptr = get_ip(self);
06745 Tk_Window mainWin;
06746
06747
06748
06749 if (deleted_ip(ptr)) {
06750 rb_raise(rb_eRuntimeError, "interpreter is deleted");
06751 }
06752
06753 if (Tcl_IsSafe(ptr->ip)) {
06754 rb_raise(rb_eSecurityError,
06755 "insecure operation on a safe interpreter");
06756 }
06757
06758
06759
06760
06761
06762
06763
06764 mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL;
06765
06766 if (RTEST(val)) {
06767 ptr->allow_ruby_exit = 1;
06768 #if TCL_MAJOR_VERSION >= 8
06769 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\"");
06770 Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd,
06771 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06772 #else
06773 DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\"");
06774 Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand,
06775 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06776 #endif
06777 return Qtrue;
06778
06779 } else {
06780 ptr->allow_ruby_exit = 0;
06781 #if TCL_MAJOR_VERSION >= 8
06782 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\"");
06783 Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd,
06784 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06785 #else
06786 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\"");
06787 Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand,
06788 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
06789 #endif
06790 return Qfalse;
06791 }
06792 }
06793
06794
06795 static VALUE
06796 ip_delete(self)
06797 VALUE self;
06798 {
06799 int thr_crit_bup;
06800 struct tcltkip *ptr = get_ip(self);
06801
06802
06803 if (deleted_ip(ptr)) {
06804 DUMP1("delete deleted IP");
06805 return Qnil;
06806 }
06807
06808 thr_crit_bup = rb_thread_critical;
06809 rb_thread_critical = Qtrue;
06810
06811 DUMP1("delete interp");
06812 if (!Tcl_InterpDeleted(ptr->ip)) {
06813 DUMP1("call ip_finalize");
06814 ip_finalize(ptr->ip);
06815
06816 Tcl_DeleteInterp(ptr->ip);
06817 Tcl_Release(ptr->ip);
06818 }
06819
06820 rb_thread_critical = thr_crit_bup;
06821
06822 return Qnil;
06823 }
06824
06825
06826
06827 static VALUE
06828 ip_has_invalid_namespace_p(self)
06829 VALUE self;
06830 {
06831 struct tcltkip *ptr = get_ip(self);
06832
06833 if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) {
06834
06835 return Qtrue;
06836 }
06837
06838 #if TCL_NAMESPACE_DEBUG
06839 if (rbtk_invalid_namespace(ptr)) {
06840 return Qtrue;
06841 } else {
06842 return Qfalse;
06843 }
06844 #else
06845 return Qfalse;
06846 #endif
06847 }
06848
06849 static VALUE
06850 ip_is_deleted_p(self)
06851 VALUE self;
06852 {
06853 struct tcltkip *ptr = get_ip(self);
06854
06855 if (deleted_ip(ptr)) {
06856 return Qtrue;
06857 } else {
06858 return Qfalse;
06859 }
06860 }
06861
06862 static VALUE
06863 ip_has_mainwindow_p_core(self, argc, argv)
06864 VALUE self;
06865 int argc;
06866 VALUE *argv;
06867 {
06868 struct tcltkip *ptr = get_ip(self);
06869
06870 if (deleted_ip(ptr) || !tk_stubs_init_p()) {
06871 return Qnil;
06872 } else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) {
06873 return Qfalse;
06874 } else {
06875 return Qtrue;
06876 }
06877 }
06878
06879 static VALUE
06880 ip_has_mainwindow_p(self)
06881 VALUE self;
06882 {
06883 return tk_funcall(ip_has_mainwindow_p_core, 0, (VALUE*)NULL, self);
06884 }
06885
06886
06887
06888 #if TCL_MAJOR_VERSION >= 8
06889 static VALUE
06890 get_str_from_obj(obj)
06891 Tcl_Obj *obj;
06892 {
06893 int len, binary = 0;
06894 const char *s;
06895 volatile VALUE str;
06896
06897 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
06898 s = Tcl_GetStringFromObj(obj, &len);
06899 #else
06900 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 3
06901
06902 if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) {
06903
06904 s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
06905 binary = 1;
06906 } else {
06907
06908 s = Tcl_GetStringFromObj(obj, &len);
06909 }
06910 #else
06911 if (IS_TCL_BYTEARRAY(obj)) {
06912 s = (char *)Tcl_GetByteArrayFromObj(obj, &len);
06913 binary = 1;
06914 } else {
06915 s = Tcl_GetStringFromObj(obj, &len);
06916 }
06917
06918 #endif
06919 #endif
06920 str = s ? rb_str_new(s, len) : rb_str_new2("");
06921 if (binary) {
06922 #ifdef HAVE_RUBY_ENCODING_H
06923 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
06924 #endif
06925 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
06926 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
06927 } else {
06928 #ifdef HAVE_RUBY_ENCODING_H
06929 rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
06930 #endif
06931 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
06932 #endif
06933 }
06934 return str;
06935 }
06936
06937 static Tcl_Obj *
06938 get_obj_from_str(str)
06939 VALUE str;
06940 {
06941 const char *s = StringValuePtr(str);
06942
06943 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
06944 return Tcl_NewStringObj((char*)s, RSTRING_LEN(str));
06945 #else
06946 VALUE enc = rb_attr_get(str, ID_at_enc);
06947
06948 if (!NIL_P(enc)) {
06949 StringValue(enc);
06950 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
06951
06952 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
06953 } else {
06954
06955 return Tcl_NewStringObj(s, RSTRING_LENINT(str));
06956 }
06957 #ifdef HAVE_RUBY_ENCODING_H
06958 } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
06959
06960 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
06961 #endif
06962 } else if (memchr(s, 0, RSTRING_LEN(str))) {
06963
06964 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str));
06965 } else {
06966
06967 return Tcl_NewStringObj(s, RSTRING_LENINT(str));
06968 }
06969 #endif
06970 }
06971 #endif
06972
06973 static VALUE
06974 ip_get_result_string_obj(interp)
06975 Tcl_Interp *interp;
06976 {
06977 #if TCL_MAJOR_VERSION >= 8
06978 Tcl_Obj *retObj;
06979 volatile VALUE strval;
06980
06981 retObj = Tcl_GetObjResult(interp);
06982 Tcl_IncrRefCount(retObj);
06983 strval = get_str_from_obj(retObj);
06984 RbTk_OBJ_UNTRUST(strval);
06985 Tcl_ResetResult(interp);
06986 Tcl_DecrRefCount(retObj);
06987 return strval;
06988 #else
06989 return rb_tainted_str_new2(interp->result);
06990 #endif
06991 }
06992
06993
06994 static VALUE
06995 callq_safelevel_handler(arg, callq)
06996 VALUE arg;
06997 VALUE callq;
06998 {
06999 struct call_queue *q;
07000
07001 Data_Get_Struct(callq, struct call_queue, q);
07002 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
07003 rb_set_safe_level(q->safe_level);
07004 return((q->func)(q->interp, q->argc, q->argv));
07005 }
07006
07007 static int call_queue_handler _((Tcl_Event *, int));
07008 static int
07009 call_queue_handler(evPtr, flags)
07010 Tcl_Event *evPtr;
07011 int flags;
07012 {
07013 struct call_queue *q = (struct call_queue *)evPtr;
07014 volatile VALUE ret;
07015 volatile VALUE q_dat;
07016 volatile VALUE thread = q->thread;
07017 struct tcltkip *ptr;
07018
07019 DUMP2("do_call_queue_handler : evPtr = %p", evPtr);
07020 DUMP2("call_queue_handler thread : %lx", rb_thread_current());
07021 DUMP2("added by thread : %lx", thread);
07022
07023 if (*(q->done)) {
07024 DUMP1("processed by another event-loop");
07025 return 0;
07026 } else {
07027 DUMP1("process it on current event-loop");
07028 }
07029
07030 if (RTEST(rb_thread_alive_p(thread))
07031 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
07032 DUMP1("caller is not yet ready to receive the result -> pending");
07033 return 0;
07034 }
07035
07036
07037 *(q->done) = 1;
07038
07039
07040 ptr = get_ip(q->interp);
07041 if (deleted_ip(ptr)) {
07042
07043 return 1;
07044 }
07045
07046
07047 rbtk_internal_eventloop_handler++;
07048
07049
07050 if (rb_safe_level() != q->safe_level) {
07051
07052 q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,-1,q);
07053 ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat),
07054 ID_call, 0);
07055 rb_gc_force_recycle(q_dat);
07056 q_dat = (VALUE)NULL;
07057 } else {
07058 DUMP2("call function (for caller thread:%lx)", thread);
07059 DUMP2("call function (current thread:%lx)", rb_thread_current());
07060 ret = (q->func)(q->interp, q->argc, q->argv);
07061 }
07062
07063
07064 RARRAY_PTR(q->result)[0] = ret;
07065 ret = (VALUE)NULL;
07066
07067
07068 rbtk_internal_eventloop_handler--;
07069
07070
07071 *(q->done) = -1;
07072
07073
07074 q->argv = (VALUE*)NULL;
07075 q->interp = (VALUE)NULL;
07076 q->result = (VALUE)NULL;
07077 q->thread = (VALUE)NULL;
07078
07079
07080 if (RTEST(rb_thread_alive_p(thread))) {
07081 DUMP2("back to caller (caller thread:%lx)", thread);
07082 DUMP2(" (current thread:%lx)", rb_thread_current());
07083 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
07084 have_rb_thread_waiting_for_value = 1;
07085 rb_thread_wakeup(thread);
07086 #else
07087 rb_thread_run(thread);
07088 #endif
07089 DUMP1("finish back to caller");
07090 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
07091 rb_thread_schedule();
07092 #endif
07093 } else {
07094 DUMP2("caller is dead (caller thread:%lx)", thread);
07095 DUMP2(" (current thread:%lx)", rb_thread_current());
07096 }
07097
07098
07099 return 1;
07100 }
07101
07102 static VALUE
07103 tk_funcall(func, argc, argv, obj)
07104 VALUE (*func)();
07105 int argc;
07106 VALUE *argv;
07107 VALUE obj;
07108 {
07109 struct call_queue *callq;
07110 struct tcltkip *ptr;
07111 int *alloc_done;
07112 int thr_crit_bup;
07113 int is_tk_evloop_thread;
07114 volatile VALUE current = rb_thread_current();
07115 volatile VALUE ip_obj = obj;
07116 volatile VALUE result;
07117 volatile VALUE ret;
07118 struct timeval t;
07119
07120 if (!NIL_P(ip_obj) && rb_obj_is_kind_of(ip_obj, tcltkip_class)) {
07121 ptr = get_ip(ip_obj);
07122 if (deleted_ip(ptr)) return Qnil;
07123 } else {
07124 ptr = (struct tcltkip *)NULL;
07125 }
07126
07127 #ifdef RUBY_USE_NATIVE_THREAD
07128 if (ptr) {
07129
07130 is_tk_evloop_thread = (ptr->tk_thread_id == (Tcl_ThreadId) 0
07131 || ptr->tk_thread_id == Tcl_GetCurrentThread());
07132 } else {
07133
07134 is_tk_evloop_thread = (tk_eventloop_thread_id == (Tcl_ThreadId) 0
07135 || tk_eventloop_thread_id == Tcl_GetCurrentThread());
07136 }
07137 #else
07138 is_tk_evloop_thread = 1;
07139 #endif
07140
07141 if (is_tk_evloop_thread
07142 && (NIL_P(eventloop_thread) || current == eventloop_thread)
07143 ) {
07144 if (NIL_P(eventloop_thread)) {
07145 DUMP2("tk_funcall from thread:%lx but no eventloop", current);
07146 } else {
07147 DUMP2("tk_funcall from current eventloop %lx", current);
07148 }
07149 result = (func)(ip_obj, argc, argv);
07150 if (rb_obj_is_kind_of(result, rb_eException)) {
07151 rb_exc_raise(result);
07152 }
07153 return result;
07154 }
07155
07156 DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current);
07157
07158 thr_crit_bup = rb_thread_critical;
07159 rb_thread_critical = Qtrue;
07160
07161
07162 if (argv) {
07163
07164 VALUE *temp = RbTk_ALLOC_N(VALUE, argc);
07165 #if 0
07166 Tcl_Preserve((ClientData)temp);
07167 #endif
07168 MEMCPY(temp, argv, VALUE, argc);
07169 argv = temp;
07170 }
07171
07172
07173
07174 alloc_done = RbTk_ALLOC_N(int, 1);
07175 #if 0
07176 Tcl_Preserve((ClientData)alloc_done);
07177 #endif
07178 *alloc_done = 0;
07179
07180
07181
07182 callq = RbTk_ALLOC_N(struct call_queue, 1);
07183 #if 0
07184 Tcl_Preserve(callq);
07185 #endif
07186
07187
07188 result = rb_ary_new3(1, Qnil);
07189
07190
07191 callq->done = alloc_done;
07192 callq->func = func;
07193 callq->argc = argc;
07194 callq->argv = argv;
07195 callq->interp = ip_obj;
07196 callq->result = result;
07197 callq->thread = current;
07198 callq->safe_level = rb_safe_level();
07199 callq->ev.proc = call_queue_handler;
07200
07201
07202 DUMP1("add handler");
07203 #ifdef RUBY_USE_NATIVE_THREAD
07204 if (ptr && ptr->tk_thread_id) {
07205
07206
07207 Tcl_ThreadQueueEvent(ptr->tk_thread_id,
07208 (Tcl_Event*)callq, TCL_QUEUE_HEAD);
07209 Tcl_ThreadAlert(ptr->tk_thread_id);
07210 } else if (tk_eventloop_thread_id) {
07211
07212
07213 Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
07214 (Tcl_Event*)callq, TCL_QUEUE_HEAD);
07215 Tcl_ThreadAlert(tk_eventloop_thread_id);
07216 } else {
07217
07218 Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
07219 }
07220 #else
07221
07222 Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD);
07223 #endif
07224
07225 rb_thread_critical = thr_crit_bup;
07226
07227
07228 t.tv_sec = 0;
07229 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
07230
07231 DUMP2("callq wait for handler (current thread:%lx)", current);
07232 while(*alloc_done >= 0) {
07233 DUMP2("*** callq wait for handler (current thread:%lx)", current);
07234
07235
07236 rb_thread_wait_for(t);
07237 DUMP2("*** callq wakeup (current thread:%lx)", current);
07238 DUMP2("*** (eventloop thread:%lx)", eventloop_thread);
07239 if (NIL_P(eventloop_thread)) {
07240 DUMP1("*** callq lost eventloop thread");
07241 break;
07242 }
07243 }
07244 DUMP2("back from handler (current thread:%lx)", current);
07245
07246
07247 ret = RARRAY_PTR(result)[0];
07248 #if 0
07249 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC);
07250 #else
07251 #if 0
07252 Tcl_Release((ClientData)alloc_done);
07253 #else
07254
07255 ckfree((char*)alloc_done);
07256 #endif
07257 #endif
07258
07259 if (argv) {
07260
07261 int i;
07262 for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; }
07263
07264 #if 0
07265 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
07266 #else
07267 #if 0
07268 Tcl_Release((ClientData)argv);
07269 #else
07270 ckfree((char*)argv);
07271 #endif
07272 #endif
07273 }
07274
07275 #if 0
07276 #if 0
07277 Tcl_Release(callq);
07278 #else
07279 ckfree((char*)callq);
07280 #endif
07281 #endif
07282
07283
07284 if (rb_obj_is_kind_of(ret, rb_eException)) {
07285 DUMP1("raise exception");
07286
07287 rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
07288 rb_funcall(ret, ID_to_s, 0, 0)));
07289 }
07290
07291 DUMP1("exit tk_funcall");
07292 return ret;
07293 }
07294
07295
07296
07297 #if TCL_MAJOR_VERSION >= 8
07298 struct call_eval_info {
07299 struct tcltkip *ptr;
07300 Tcl_Obj *cmd;
07301 };
07302
07303 static VALUE
07304 #ifdef HAVE_PROTOTYPES
07305 call_tcl_eval(VALUE arg)
07306 #else
07307 call_tcl_eval(arg)
07308 VALUE arg;
07309 #endif
07310 {
07311 struct call_eval_info *inf = (struct call_eval_info *)arg;
07312
07313 Tcl_AllowExceptions(inf->ptr->ip);
07314 inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd);
07315
07316 return Qnil;
07317 }
07318 #endif
07319
07320 static VALUE
07321 ip_eval_real(self, cmd_str, cmd_len)
07322 VALUE self;
07323 char *cmd_str;
07324 int cmd_len;
07325 {
07326 volatile VALUE ret;
07327 struct tcltkip *ptr = get_ip(self);
07328 int thr_crit_bup;
07329
07330 #if TCL_MAJOR_VERSION >= 8
07331
07332 {
07333 Tcl_Obj *cmd;
07334
07335 thr_crit_bup = rb_thread_critical;
07336 rb_thread_critical = Qtrue;
07337
07338 cmd = Tcl_NewStringObj(cmd_str, cmd_len);
07339 Tcl_IncrRefCount(cmd);
07340
07341
07342 if (deleted_ip(ptr)) {
07343 Tcl_DecrRefCount(cmd);
07344 rb_thread_critical = thr_crit_bup;
07345 ptr->return_value = TCL_OK;
07346 return rb_tainted_str_new2("");
07347 } else {
07348 int status;
07349 struct call_eval_info inf;
07350
07351
07352 rbtk_preserve_ip(ptr);
07353
07354 #if 0
07355 ptr->return_value = Tcl_EvalObj(ptr->ip, cmd);
07356
07357 #else
07358 inf.ptr = ptr;
07359 inf.cmd = cmd;
07360 ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status);
07361 switch(status) {
07362 case TAG_RAISE:
07363 if (NIL_P(rb_errinfo())) {
07364 rbtk_pending_exception = rb_exc_new2(rb_eException,
07365 "unknown exception");
07366 } else {
07367 rbtk_pending_exception = rb_errinfo();
07368 }
07369 break;
07370
07371 case TAG_FATAL:
07372 if (NIL_P(rb_errinfo())) {
07373 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
07374 } else {
07375 rbtk_pending_exception = rb_errinfo();
07376 }
07377 }
07378 #endif
07379 }
07380
07381 Tcl_DecrRefCount(cmd);
07382
07383 }
07384
07385 if (pending_exception_check1(thr_crit_bup, ptr)) {
07386 rbtk_release_ip(ptr);
07387 return rbtk_pending_exception;
07388 }
07389
07390
07391 if (ptr->return_value != TCL_OK) {
07392 if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
07393 volatile VALUE exc;
07394
07395 switch (ptr->return_value) {
07396 case TCL_RETURN:
07397 exc = create_ip_exc(self, eTkCallbackReturn,
07398 "ip_eval_real receives TCL_RETURN");
07399 case TCL_BREAK:
07400 exc = create_ip_exc(self, eTkCallbackBreak,
07401 "ip_eval_real receives TCL_BREAK");
07402 case TCL_CONTINUE:
07403 exc = create_ip_exc(self, eTkCallbackContinue,
07404 "ip_eval_real receives TCL_CONTINUE");
07405 default:
07406 exc = create_ip_exc(self, rb_eRuntimeError, "%s",
07407 Tcl_GetStringResult(ptr->ip));
07408 }
07409
07410 rbtk_release_ip(ptr);
07411 rb_thread_critical = thr_crit_bup;
07412 return exc;
07413 } else {
07414 if (event_loop_abort_on_exc < 0) {
07415 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
07416 } else {
07417 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
07418 }
07419 Tcl_ResetResult(ptr->ip);
07420 rbtk_release_ip(ptr);
07421 rb_thread_critical = thr_crit_bup;
07422 return rb_tainted_str_new2("");
07423 }
07424 }
07425
07426
07427 ret = ip_get_result_string_obj(ptr->ip);
07428 rbtk_release_ip(ptr);
07429 rb_thread_critical = thr_crit_bup;
07430 return ret;
07431
07432 #else
07433 DUMP2("Tcl_Eval(%s)", cmd_str);
07434
07435
07436 if (deleted_ip(ptr)) {
07437 ptr->return_value = TCL_OK;
07438 return rb_tainted_str_new2("");
07439 } else {
07440
07441 rbtk_preserve_ip(ptr);
07442 ptr->return_value = Tcl_Eval(ptr->ip, cmd_str);
07443
07444 }
07445
07446 if (pending_exception_check1(thr_crit_bup, ptr)) {
07447 rbtk_release_ip(ptr);
07448 return rbtk_pending_exception;
07449 }
07450
07451
07452 if (ptr->return_value != TCL_OK) {
07453 volatile VALUE exc;
07454
07455 switch (ptr->return_value) {
07456 case TCL_RETURN:
07457 exc = create_ip_exc(self, eTkCallbackReturn,
07458 "ip_eval_real receives TCL_RETURN");
07459 case TCL_BREAK:
07460 exc = create_ip_exc(self, eTkCallbackBreak,
07461 "ip_eval_real receives TCL_BREAK");
07462 case TCL_CONTINUE:
07463 exc = create_ip_exc(self, eTkCallbackContinue,
07464 "ip_eval_real receives TCL_CONTINUE");
07465 default:
07466 exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result);
07467 }
07468
07469 rbtk_release_ip(ptr);
07470 return exc;
07471 }
07472 DUMP2("(TCL_Eval result) %d", ptr->return_value);
07473
07474
07475 ret = ip_get_result_string_obj(ptr->ip);
07476 rbtk_release_ip(ptr);
07477 return ret;
07478 #endif
07479 }
07480
07481 static VALUE
07482 evq_safelevel_handler(arg, evq)
07483 VALUE arg;
07484 VALUE evq;
07485 {
07486 struct eval_queue *q;
07487
07488 Data_Get_Struct(evq, struct eval_queue, q);
07489 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
07490 rb_set_safe_level(q->safe_level);
07491 return ip_eval_real(q->interp, q->str, q->len);
07492 }
07493
07494 int eval_queue_handler _((Tcl_Event *, int));
07495 int
07496 eval_queue_handler(evPtr, flags)
07497 Tcl_Event *evPtr;
07498 int flags;
07499 {
07500 struct eval_queue *q = (struct eval_queue *)evPtr;
07501 volatile VALUE ret;
07502 volatile VALUE q_dat;
07503 volatile VALUE thread = q->thread;
07504 struct tcltkip *ptr;
07505
07506 DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
07507 DUMP2("eval_queue_thread : %lx", rb_thread_current());
07508 DUMP2("added by thread : %lx", thread);
07509
07510 if (*(q->done)) {
07511 DUMP1("processed by another event-loop");
07512 return 0;
07513 } else {
07514 DUMP1("process it on current event-loop");
07515 }
07516
07517 if (RTEST(rb_thread_alive_p(thread))
07518 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
07519 DUMP1("caller is not yet ready to receive the result -> pending");
07520 return 0;
07521 }
07522
07523
07524 *(q->done) = 1;
07525
07526
07527 ptr = get_ip(q->interp);
07528 if (deleted_ip(ptr)) {
07529
07530 return 1;
07531 }
07532
07533
07534 rbtk_internal_eventloop_handler++;
07535
07536
07537 if (rb_safe_level() != q->safe_level) {
07538 #ifdef HAVE_NATIVETHREAD
07539 #ifndef RUBY_USE_NATIVE_THREAD
07540 if (!ruby_native_thread_p()) {
07541 rb_bug("cross-thread violation on eval_queue_handler()");
07542 }
07543 #endif
07544 #endif
07545
07546 q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,-1,q);
07547 ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
07548 ID_call, 0);
07549 rb_gc_force_recycle(q_dat);
07550 q_dat = (VALUE)NULL;
07551 } else {
07552 ret = ip_eval_real(q->interp, q->str, q->len);
07553 }
07554
07555
07556 RARRAY_PTR(q->result)[0] = ret;
07557 ret = (VALUE)NULL;
07558
07559
07560 rbtk_internal_eventloop_handler--;
07561
07562
07563 *(q->done) = -1;
07564
07565
07566 q->interp = (VALUE)NULL;
07567 q->result = (VALUE)NULL;
07568 q->thread = (VALUE)NULL;
07569
07570
07571 if (RTEST(rb_thread_alive_p(thread))) {
07572 DUMP2("back to caller (caller thread:%lx)", thread);
07573 DUMP2(" (current thread:%lx)", rb_thread_current());
07574 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
07575 have_rb_thread_waiting_for_value = 1;
07576 rb_thread_wakeup(thread);
07577 #else
07578 rb_thread_run(thread);
07579 #endif
07580 DUMP1("finish back to caller");
07581 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
07582 rb_thread_schedule();
07583 #endif
07584 } else {
07585 DUMP2("caller is dead (caller thread:%lx)", thread);
07586 DUMP2(" (current thread:%lx)", rb_thread_current());
07587 }
07588
07589
07590 return 1;
07591 }
07592
07593 static VALUE
07594 ip_eval(self, str)
07595 VALUE self;
07596 VALUE str;
07597 {
07598 struct eval_queue *evq;
07599 #ifdef RUBY_USE_NATIVE_THREAD
07600 struct tcltkip *ptr;
07601 #endif
07602 char *eval_str;
07603 int *alloc_done;
07604 int thr_crit_bup;
07605 volatile VALUE current = rb_thread_current();
07606 volatile VALUE ip_obj = self;
07607 volatile VALUE result;
07608 volatile VALUE ret;
07609 Tcl_QueuePosition position;
07610 struct timeval t;
07611
07612 thr_crit_bup = rb_thread_critical;
07613 rb_thread_critical = Qtrue;
07614 StringValue(str);
07615 rb_thread_critical = thr_crit_bup;
07616
07617 #ifdef RUBY_USE_NATIVE_THREAD
07618 ptr = get_ip(ip_obj);
07619 DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id);
07620 DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
07621 #else
07622 DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
07623 #endif
07624 DUMP2("status: eventloopt_thread %lx", eventloop_thread);
07625
07626 if (
07627 #ifdef RUBY_USE_NATIVE_THREAD
07628 (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
07629 &&
07630 #endif
07631 (NIL_P(eventloop_thread) || current == eventloop_thread)
07632 ) {
07633 if (NIL_P(eventloop_thread)) {
07634 DUMP2("eval from thread:%lx but no eventloop", current);
07635 } else {
07636 DUMP2("eval from current eventloop %lx", current);
07637 }
07638 result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str));
07639 if (rb_obj_is_kind_of(result, rb_eException)) {
07640 rb_exc_raise(result);
07641 }
07642 return result;
07643 }
07644
07645 DUMP2("eval from thread %lx (NOT current eventloop)", current);
07646
07647 thr_crit_bup = rb_thread_critical;
07648 rb_thread_critical = Qtrue;
07649
07650
07651
07652 alloc_done = RbTk_ALLOC_N(int, 1);
07653 #if 0
07654 Tcl_Preserve((ClientData)alloc_done);
07655 #endif
07656 *alloc_done = 0;
07657
07658
07659 eval_str = ckalloc(RSTRING_LENINT(str) + 1);
07660 #if 0
07661 Tcl_Preserve((ClientData)eval_str);
07662 #endif
07663 memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str));
07664 eval_str[RSTRING_LEN(str)] = 0;
07665
07666
07667
07668 evq = RbTk_ALLOC_N(struct eval_queue, 1);
07669 #if 0
07670 Tcl_Preserve(evq);
07671 #endif
07672
07673
07674 result = rb_ary_new3(1, Qnil);
07675
07676
07677 evq->done = alloc_done;
07678 evq->str = eval_str;
07679 evq->len = RSTRING_LENINT(str);
07680 evq->interp = ip_obj;
07681 evq->result = result;
07682 evq->thread = current;
07683 evq->safe_level = rb_safe_level();
07684 evq->ev.proc = eval_queue_handler;
07685
07686 position = TCL_QUEUE_TAIL;
07687
07688
07689 DUMP1("add handler");
07690 #ifdef RUBY_USE_NATIVE_THREAD
07691 if (ptr->tk_thread_id) {
07692
07693 Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position);
07694 Tcl_ThreadAlert(ptr->tk_thread_id);
07695 } else if (tk_eventloop_thread_id) {
07696 Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position);
07697
07698
07699 Tcl_ThreadAlert(tk_eventloop_thread_id);
07700 } else {
07701
07702 Tcl_QueueEvent((Tcl_Event*)evq, position);
07703 }
07704 #else
07705
07706 Tcl_QueueEvent((Tcl_Event*)evq, position);
07707 #endif
07708
07709 rb_thread_critical = thr_crit_bup;
07710
07711
07712 t.tv_sec = 0;
07713 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
07714
07715 DUMP2("evq wait for handler (current thread:%lx)", current);
07716 while(*alloc_done >= 0) {
07717 DUMP2("*** evq wait for handler (current thread:%lx)", current);
07718
07719
07720 rb_thread_wait_for(t);
07721 DUMP2("*** evq wakeup (current thread:%lx)", current);
07722 DUMP2("*** (eventloop thread:%lx)", eventloop_thread);
07723 if (NIL_P(eventloop_thread)) {
07724 DUMP1("*** evq lost eventloop thread");
07725 break;
07726 }
07727 }
07728 DUMP2("back from handler (current thread:%lx)", current);
07729
07730
07731 ret = RARRAY_PTR(result)[0];
07732
07733 #if 0
07734 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC);
07735 #else
07736 #if 0
07737 Tcl_Release((ClientData)alloc_done);
07738 #else
07739
07740 ckfree((char*)alloc_done);
07741 #endif
07742 #endif
07743 #if 0
07744 Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC);
07745 #else
07746 #if 0
07747 Tcl_Release((ClientData)eval_str);
07748 #else
07749
07750 ckfree(eval_str);
07751 #endif
07752 #endif
07753 #if 0
07754 #if 0
07755 Tcl_Release(evq);
07756 #else
07757 ckfree((char*)evq);
07758 #endif
07759 #endif
07760
07761 if (rb_obj_is_kind_of(ret, rb_eException)) {
07762 DUMP1("raise exception");
07763
07764 rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
07765 rb_funcall(ret, ID_to_s, 0, 0)));
07766 }
07767
07768 return ret;
07769 }
07770
07771
07772 static int
07773 ip_cancel_eval_core(interp, msg, flag)
07774 Tcl_Interp *interp;
07775 VALUE msg;
07776 int flag;
07777 {
07778 #if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6)
07779 rb_raise(rb_eNotImpError,
07780 "cancel_eval is supported Tcl/Tk8.6 or later.");
07781
07782 UNREACHABLE;
07783 #else
07784 Tcl_Obj *msg_obj;
07785
07786 if (NIL_P(msg)) {
07787 msg_obj = NULL;
07788 } else {
07789 msg_obj = Tcl_NewStringObj(RSTRING_PTR(msg), RSTRING_LEN(msg));
07790 Tcl_IncrRefCount(msg_obj);
07791 }
07792
07793 return Tcl_CancelEval(interp, msg_obj, 0, flag);
07794 #endif
07795 }
07796
07797 static VALUE
07798 ip_cancel_eval(argc, argv, self)
07799 int argc;
07800 VALUE *argv;
07801 VALUE self;
07802 {
07803 VALUE retval;
07804
07805 if (rb_scan_args(argc, argv, "01", &retval) == 0) {
07806 retval = Qnil;
07807 }
07808 if (ip_cancel_eval_core(get_ip(self)->ip, retval, 0) == TCL_OK) {
07809 return Qtrue;
07810 } else {
07811 return Qfalse;
07812 }
07813 }
07814
07815 #ifndef TCL_CANCEL_UNWIND
07816 #define TCL_CANCEL_UNWIND 0x100000
07817 #endif
07818 static VALUE
07819 ip_cancel_eval_unwind(argc, argv, self)
07820 int argc;
07821 VALUE *argv;
07822 VALUE self;
07823 {
07824 int flag = 0;
07825 VALUE retval;
07826
07827 if (rb_scan_args(argc, argv, "01", &retval) == 0) {
07828 retval = Qnil;
07829 }
07830
07831 flag |= TCL_CANCEL_UNWIND;
07832 if (ip_cancel_eval_core(get_ip(self)->ip, retval, flag) == TCL_OK) {
07833 return Qtrue;
07834 } else {
07835 return Qfalse;
07836 }
07837 }
07838
07839
07840 static VALUE
07841 lib_restart_core(interp, argc, argv)
07842 VALUE interp;
07843 int argc;
07844 VALUE *argv;
07845 {
07846 volatile VALUE exc;
07847 struct tcltkip *ptr = get_ip(interp);
07848 int thr_crit_bup;
07849
07850
07851
07852
07853
07854 if (deleted_ip(ptr)) {
07855 return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted");
07856 }
07857
07858 thr_crit_bup = rb_thread_critical;
07859 rb_thread_critical = Qtrue;
07860
07861
07862 rbtk_preserve_ip(ptr);
07863
07864
07865 ptr->return_value = Tcl_Eval(ptr->ip, "destroy .");
07866
07867 DUMP2("(TCL_Eval result) %d", ptr->return_value);
07868 Tcl_ResetResult(ptr->ip);
07869
07870 #if TCL_MAJOR_VERSION >= 8
07871
07872 ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
07873
07874 DUMP2("(TCL_Eval result) %d", ptr->return_value);
07875 Tcl_ResetResult(ptr->ip);
07876 #endif
07877
07878
07879 ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
07880
07881 DUMP2("(TCL_Eval result) %d", ptr->return_value);
07882 Tcl_ResetResult(ptr->ip);
07883
07884
07885 exc = tcltkip_init_tk(interp);
07886 if (!NIL_P(exc)) {
07887 rb_thread_critical = thr_crit_bup;
07888 rbtk_release_ip(ptr);
07889 return exc;
07890 }
07891
07892
07893 rbtk_release_ip(ptr);
07894
07895 rb_thread_critical = thr_crit_bup;
07896
07897
07898 return interp;
07899 }
07900
07901 static VALUE
07902 lib_restart(self)
07903 VALUE self;
07904 {
07905 struct tcltkip *ptr = get_ip(self);
07906
07907
07908 tcl_stubs_check();
07909
07910
07911 if (deleted_ip(ptr)) {
07912 rb_raise(rb_eRuntimeError, "interpreter is deleted");
07913 }
07914
07915 return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self);
07916 }
07917
07918
07919 static VALUE
07920 ip_restart(self)
07921 VALUE self;
07922 {
07923 struct tcltkip *ptr = get_ip(self);
07924
07925
07926 tcl_stubs_check();
07927
07928
07929 if (deleted_ip(ptr)) {
07930 rb_raise(rb_eRuntimeError, "interpreter is deleted");
07931 }
07932
07933 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
07934
07935 return Qnil;
07936 }
07937 return lib_restart(self);
07938 }
07939
07940 static VALUE
07941 lib_toUTF8_core(ip_obj, src, encodename)
07942 VALUE ip_obj;
07943 VALUE src;
07944 VALUE encodename;
07945 {
07946 volatile VALUE str = src;
07947
07948 #ifdef TCL_UTF_MAX
07949 # if 0
07950 Tcl_Interp *interp;
07951 # endif
07952 Tcl_Encoding encoding;
07953 Tcl_DString dstr;
07954 int taint_flag = OBJ_TAINTED(str);
07955 struct tcltkip *ptr;
07956 char *buf;
07957 int thr_crit_bup;
07958 #endif
07959
07960 tcl_stubs_check();
07961
07962 if (NIL_P(src)) {
07963 return rb_str_new2("");
07964 }
07965
07966 #ifdef TCL_UTF_MAX
07967 if (NIL_P(ip_obj)) {
07968 # if 0
07969 interp = (Tcl_Interp *)NULL;
07970 # endif
07971 } else {
07972 ptr = get_ip(ip_obj);
07973
07974
07975 if (deleted_ip(ptr)) {
07976 # if 0
07977 interp = (Tcl_Interp *)NULL;
07978 } else {
07979 interp = ptr->ip;
07980 # endif
07981 }
07982 }
07983
07984 thr_crit_bup = rb_thread_critical;
07985 rb_thread_critical = Qtrue;
07986
07987 if (NIL_P(encodename)) {
07988 if (TYPE(str) == T_STRING) {
07989 volatile VALUE enc;
07990
07991 #ifdef HAVE_RUBY_ENCODING_H
07992 enc = rb_funcall(rb_obj_encoding(str), ID_to_s, 0, 0);
07993 #else
07994 enc = rb_attr_get(str, ID_at_enc);
07995 #endif
07996 if (NIL_P(enc)) {
07997 if (NIL_P(ip_obj)) {
07998 encoding = (Tcl_Encoding)NULL;
07999 } else {
08000 enc = rb_attr_get(ip_obj, ID_at_enc);
08001 if (NIL_P(enc)) {
08002 encoding = (Tcl_Encoding)NULL;
08003 } else {
08004
08005 enc = rb_funcall(enc, ID_to_s, 0, 0);
08006
08007 if (!RSTRING_LEN(enc)) {
08008 encoding = (Tcl_Encoding)NULL;
08009 } else {
08010 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
08011 RSTRING_PTR(enc));
08012 if (encoding == (Tcl_Encoding)NULL) {
08013 rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
08014 }
08015 }
08016 }
08017 }
08018 } else {
08019 StringValue(enc);
08020 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
08021 #ifdef HAVE_RUBY_ENCODING_H
08022 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08023 #endif
08024 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08025 rb_thread_critical = thr_crit_bup;
08026 return str;
08027 }
08028
08029 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
08030 RSTRING_PTR(enc));
08031 if (encoding == (Tcl_Encoding)NULL) {
08032 rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
08033 }
08034 }
08035 } else {
08036 encoding = (Tcl_Encoding)NULL;
08037 }
08038 } else {
08039 StringValue(encodename);
08040 if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
08041 #ifdef HAVE_RUBY_ENCODING_H
08042 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08043 #endif
08044 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08045 rb_thread_critical = thr_crit_bup;
08046 return str;
08047 }
08048
08049 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
08050 if (encoding == (Tcl_Encoding)NULL) {
08051
08052
08053
08054
08055 rb_raise(rb_eArgError, "unknown encoding name '%s'",
08056 RSTRING_PTR(encodename));
08057 }
08058 }
08059
08060 StringValue(str);
08061 if (!RSTRING_LEN(str)) {
08062 rb_thread_critical = thr_crit_bup;
08063 return str;
08064 }
08065 buf = ALLOC_N(char, RSTRING_LEN(str)+1);
08066
08067 memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
08068 buf[RSTRING_LEN(str)] = 0;
08069
08070 Tcl_DStringInit(&dstr);
08071 Tcl_DStringFree(&dstr);
08072
08073 Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(str), &dstr);
08074
08075
08076
08077 str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
08078 #ifdef HAVE_RUBY_ENCODING_H
08079 rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
08080 #endif
08081 if (taint_flag) RbTk_OBJ_UNTRUST(str);
08082 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
08083
08084
08085
08086
08087
08088
08089 Tcl_DStringFree(&dstr);
08090
08091 xfree(buf);
08092
08093
08094 rb_thread_critical = thr_crit_bup;
08095 #endif
08096
08097 return str;
08098 }
08099
08100 static VALUE
08101 lib_toUTF8(argc, argv, self)
08102 int argc;
08103 VALUE *argv;
08104 VALUE self;
08105 {
08106 VALUE str, encodename;
08107
08108 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08109 encodename = Qnil;
08110 }
08111 return lib_toUTF8_core(Qnil, str, encodename);
08112 }
08113
08114 static VALUE
08115 ip_toUTF8(argc, argv, self)
08116 int argc;
08117 VALUE *argv;
08118 VALUE self;
08119 {
08120 VALUE str, encodename;
08121
08122 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08123 encodename = Qnil;
08124 }
08125 return lib_toUTF8_core(self, str, encodename);
08126 }
08127
08128 static VALUE
08129 lib_fromUTF8_core(ip_obj, src, encodename)
08130 VALUE ip_obj;
08131 VALUE src;
08132 VALUE encodename;
08133 {
08134 volatile VALUE str = src;
08135
08136 #ifdef TCL_UTF_MAX
08137 Tcl_Interp *interp;
08138 Tcl_Encoding encoding;
08139 Tcl_DString dstr;
08140 int taint_flag = OBJ_TAINTED(str);
08141 char *buf;
08142 int thr_crit_bup;
08143 #endif
08144
08145 tcl_stubs_check();
08146
08147 if (NIL_P(src)) {
08148 return rb_str_new2("");
08149 }
08150
08151 #ifdef TCL_UTF_MAX
08152 if (NIL_P(ip_obj)) {
08153 interp = (Tcl_Interp *)NULL;
08154 } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
08155 interp = (Tcl_Interp *)NULL;
08156 } else {
08157 interp = get_ip(ip_obj)->ip;
08158 }
08159
08160 thr_crit_bup = rb_thread_critical;
08161 rb_thread_critical = Qtrue;
08162
08163 if (NIL_P(encodename)) {
08164 volatile VALUE enc;
08165
08166 if (TYPE(str) == T_STRING) {
08167 enc = rb_attr_get(str, ID_at_enc);
08168 if (!NIL_P(enc)) {
08169 StringValue(enc);
08170 if (strcmp(RSTRING_PTR(enc), "binary") == 0) {
08171 #ifdef HAVE_RUBY_ENCODING_H
08172 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08173 #endif
08174 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08175 rb_thread_critical = thr_crit_bup;
08176 return str;
08177 }
08178 #ifdef HAVE_RUBY_ENCODING_H
08179 } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) {
08180 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08181 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08182 rb_thread_critical = thr_crit_bup;
08183 return str;
08184 #endif
08185 }
08186 }
08187
08188 if (NIL_P(ip_obj)) {
08189 encoding = (Tcl_Encoding)NULL;
08190 } else {
08191 enc = rb_attr_get(ip_obj, ID_at_enc);
08192 if (NIL_P(enc)) {
08193 encoding = (Tcl_Encoding)NULL;
08194 } else {
08195
08196 enc = rb_funcall(enc, ID_to_s, 0, 0);
08197
08198 if (!RSTRING_LEN(enc)) {
08199 encoding = (Tcl_Encoding)NULL;
08200 } else {
08201 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL,
08202 RSTRING_PTR(enc));
08203 if (encoding == (Tcl_Encoding)NULL) {
08204 rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc));
08205 } else {
08206 encodename = rb_obj_dup(enc);
08207 }
08208 }
08209 }
08210 }
08211
08212 } else {
08213 StringValue(encodename);
08214
08215 if (strcmp(RSTRING_PTR(encodename), "binary") == 0) {
08216 Tcl_Obj *tclstr;
08217 char *s;
08218 int len;
08219
08220 StringValue(str);
08221 tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LENINT(str));
08222 Tcl_IncrRefCount(tclstr);
08223 s = (char*)Tcl_GetByteArrayFromObj(tclstr, &len);
08224 str = rb_tainted_str_new(s, len);
08225 s = (char*)NULL;
08226 Tcl_DecrRefCount(tclstr);
08227 #ifdef HAVE_RUBY_ENCODING_H
08228 rb_enc_associate_index(str, ENCODING_INDEX_BINARY);
08229 #endif
08230 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY);
08231
08232 rb_thread_critical = thr_crit_bup;
08233 return str;
08234 }
08235
08236
08237 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename));
08238 if (encoding == (Tcl_Encoding)NULL) {
08239
08240
08241
08242
08243
08244 rb_raise(rb_eArgError, "unknown encoding name '%s'",
08245 RSTRING_PTR(encodename));
08246 }
08247 }
08248
08249 StringValue(str);
08250
08251 if (RSTRING_LEN(str) == 0) {
08252 rb_thread_critical = thr_crit_bup;
08253 return rb_tainted_str_new2("");
08254 }
08255
08256 buf = ALLOC_N(char, RSTRING_LEN(str)+1);
08257
08258 memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str));
08259 buf[RSTRING_LEN(str)] = 0;
08260
08261 Tcl_DStringInit(&dstr);
08262 Tcl_DStringFree(&dstr);
08263
08264 Tcl_UtfToExternalDString(encoding,buf,RSTRING_LENINT(str),&dstr);
08265
08266
08267
08268 str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
08269 #ifdef HAVE_RUBY_ENCODING_H
08270 if (interp) {
08271
08272
08273 VALUE tbl = ip_get_encoding_table(ip_obj);
08274 VALUE encobj = encoding_table_get_obj(tbl, encodename);
08275 rb_enc_associate_index(str, rb_to_encoding_index(encobj));
08276 } else {
08277
08278
08279 rb_enc_associate_index(str, rb_enc_find_index(RSTRING_PTR(encodename)));
08280 }
08281 #endif
08282
08283 if (taint_flag) RbTk_OBJ_UNTRUST(str);
08284 rb_ivar_set(str, ID_at_enc, encodename);
08285
08286
08287
08288
08289
08290
08291 Tcl_DStringFree(&dstr);
08292
08293 xfree(buf);
08294
08295
08296 rb_thread_critical = thr_crit_bup;
08297 #endif
08298
08299 return str;
08300 }
08301
08302 static VALUE
08303 lib_fromUTF8(argc, argv, self)
08304 int argc;
08305 VALUE *argv;
08306 VALUE self;
08307 {
08308 VALUE str, encodename;
08309
08310 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08311 encodename = Qnil;
08312 }
08313 return lib_fromUTF8_core(Qnil, str, encodename);
08314 }
08315
08316 static VALUE
08317 ip_fromUTF8(argc, argv, self)
08318 int argc;
08319 VALUE *argv;
08320 VALUE self;
08321 {
08322 VALUE str, encodename;
08323
08324 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
08325 encodename = Qnil;
08326 }
08327 return lib_fromUTF8_core(self, str, encodename);
08328 }
08329
08330 static VALUE
08331 lib_UTF_backslash_core(self, str, all_bs)
08332 VALUE self;
08333 VALUE str;
08334 int all_bs;
08335 {
08336 #ifdef TCL_UTF_MAX
08337 char *src_buf, *dst_buf, *ptr;
08338 int read_len = 0, dst_len = 0;
08339 int taint_flag = OBJ_TAINTED(str);
08340 int thr_crit_bup;
08341
08342 tcl_stubs_check();
08343
08344 StringValue(str);
08345 if (!RSTRING_LEN(str)) {
08346 return str;
08347 }
08348
08349 thr_crit_bup = rb_thread_critical;
08350 rb_thread_critical = Qtrue;
08351
08352
08353 src_buf = ckalloc(RSTRING_LENINT(str)+1);
08354 #if 0
08355 Tcl_Preserve((ClientData)src_buf);
08356 #endif
08357 memcpy(src_buf, RSTRING_PTR(str), RSTRING_LEN(str));
08358 src_buf[RSTRING_LEN(str)] = 0;
08359
08360
08361 dst_buf = ckalloc(RSTRING_LENINT(str)+1);
08362 #if 0
08363 Tcl_Preserve((ClientData)dst_buf);
08364 #endif
08365
08366 ptr = src_buf;
08367 while(RSTRING_LEN(str) > ptr - src_buf) {
08368 if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) {
08369 dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len));
08370 ptr += read_len;
08371 } else {
08372 *(dst_buf + (dst_len++)) = *(ptr++);
08373 }
08374 }
08375
08376 str = rb_str_new(dst_buf, dst_len);
08377 if (taint_flag) RbTk_OBJ_UNTRUST(str);
08378 #ifdef HAVE_RUBY_ENCODING_H
08379 rb_enc_associate_index(str, ENCODING_INDEX_UTF8);
08380 #endif
08381 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8);
08382
08383 #if 0
08384 Tcl_EventuallyFree((ClientData)src_buf, TCL_DYNAMIC);
08385 #else
08386 #if 0
08387 Tcl_Release((ClientData)src_buf);
08388 #else
08389
08390 ckfree(src_buf);
08391 #endif
08392 #endif
08393 #if 0
08394 Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC);
08395 #else
08396 #if 0
08397 Tcl_Release((ClientData)dst_buf);
08398 #else
08399
08400 ckfree(dst_buf);
08401 #endif
08402 #endif
08403
08404 rb_thread_critical = thr_crit_bup;
08405 #endif
08406
08407 return str;
08408 }
08409
08410 static VALUE
08411 lib_UTF_backslash(self, str)
08412 VALUE self;
08413 VALUE str;
08414 {
08415 return lib_UTF_backslash_core(self, str, 0);
08416 }
08417
08418 static VALUE
08419 lib_Tcl_backslash(self, str)
08420 VALUE self;
08421 VALUE str;
08422 {
08423 return lib_UTF_backslash_core(self, str, 1);
08424 }
08425
08426 static VALUE
08427 lib_get_system_encoding(self)
08428 VALUE self;
08429 {
08430 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
08431 tcl_stubs_check();
08432 return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
08433 #else
08434 return Qnil;
08435 #endif
08436 }
08437
08438 static VALUE
08439 lib_set_system_encoding(self, enc_name)
08440 VALUE self;
08441 VALUE enc_name;
08442 {
08443 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
08444 tcl_stubs_check();
08445
08446 if (NIL_P(enc_name)) {
08447 Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL);
08448 return lib_get_system_encoding(self);
08449 }
08450
08451 enc_name = rb_funcall(enc_name, ID_to_s, 0, 0);
08452 if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL,
08453 StringValuePtr(enc_name)) != TCL_OK) {
08454 rb_raise(rb_eArgError, "unknown encoding name '%s'",
08455 RSTRING_PTR(enc_name));
08456 }
08457
08458 return enc_name;
08459 #else
08460 return Qnil;
08461 #endif
08462 }
08463
08464
08465
08466 struct invoke_info {
08467 struct tcltkip *ptr;
08468 Tcl_CmdInfo cmdinfo;
08469 #if TCL_MAJOR_VERSION >= 8
08470 int objc;
08471 Tcl_Obj **objv;
08472 #else
08473 int argc;
08474 char **argv;
08475 #endif
08476 };
08477
08478 static VALUE
08479 #ifdef HAVE_PROTOTYPES
08480 invoke_tcl_proc(VALUE arg)
08481 #else
08482 invoke_tcl_proc(arg)
08483 VALUE arg;
08484 #endif
08485 {
08486 struct invoke_info *inf = (struct invoke_info *)arg;
08487
08488 #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION < 6
08489 int i, len;
08490 int argc = inf->objc;
08491 char **argv = (char **)NULL;
08492 #endif
08493
08494 DUMP1("call invoke_tcl_proc");
08495
08496 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 6)
08497
08498
08499 inf->ptr->return_value = Tcl_EvalObjv(inf->ptr->ip, inf->objc, inf->objv, TCL_EVAL_DIRECT);
08500
08501
08502 #else
08503
08504
08505 #if TCL_MAJOR_VERSION == 8
08506
08507 if (!inf->cmdinfo.isNativeObjectProc) {
08508 DUMP1("called proc is not a native-obj-proc");
08509
08510
08511 argv = RbTk_ALLOC_N(char *, (argc+1));
08512 #if 0
08513 Tcl_Preserve((ClientData)argv);
08514 #endif
08515 for (i = 0; i < argc; ++i) {
08516 argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len);
08517 }
08518 argv[argc] = (char *)NULL;
08519 }
08520 #endif
08521
08522 DUMP1("reset result of tcl-interp");
08523 Tcl_ResetResult(inf->ptr->ip);
08524
08525
08526 #if TCL_MAJOR_VERSION == 8
08527
08528 if (inf->cmdinfo.isNativeObjectProc) {
08529 DUMP1("call tcl_proc as a native-obj-proc");
08530 inf->ptr->return_value
08531 = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData,
08532 inf->ptr->ip, inf->objc, inf->objv);
08533 }
08534 else
08535 #endif
08536 {
08537 #if TCL_MAJOR_VERSION == 8
08538
08539 DUMP1("call tcl_proc as not a native-obj-proc");
08540 inf->ptr->return_value
08541 = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
08542 argc, (CONST84 char **)argv);
08543
08544 #if 0
08545 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
08546 #else
08547 #if 0
08548 Tcl_Release((ClientData)argv);
08549 #else
08550
08551 ckfree((char*)argv);
08552 #endif
08553 #endif
08554
08555 #else
08556 inf->ptr->return_value
08557 = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip,
08558 inf->argc, inf->argv);
08559 #endif
08560 }
08561
08562 #endif
08563
08564 DUMP1("end of invoke_tcl_proc");
08565 return Qnil;
08566 }
08567
08568
08569 #if TCL_MAJOR_VERSION >= 8
08570 static VALUE
08571 ip_invoke_core(interp, objc, objv)
08572 VALUE interp;
08573 int objc;
08574 Tcl_Obj **objv;
08575 #else
08576 static VALUE
08577 ip_invoke_core(interp, argc, argv)
08578 VALUE interp;
08579 int argc;
08580 char **argv;
08581 #endif
08582 {
08583 struct tcltkip *ptr;
08584 Tcl_CmdInfo info;
08585 char *cmd;
08586 int len;
08587 int thr_crit_bup;
08588 int unknown_flag = 0;
08589
08590 #if 1
08591 struct invoke_info inf;
08592 int status;
08593 #else
08594 #if TCL_MAJOR_VERSION >= 8
08595 int argc = objc;
08596 char **argv = (char **)NULL;
08597
08598 #endif
08599 #endif
08600
08601
08602 ptr = get_ip(interp);
08603
08604
08605 #if TCL_MAJOR_VERSION >= 8
08606 cmd = Tcl_GetStringFromObj(objv[0], &len);
08607 #else
08608 cmd = argv[0];
08609 #endif
08610
08611
08612 ptr = get_ip(interp);
08613
08614
08615 if (deleted_ip(ptr)) {
08616 return rb_tainted_str_new2("");
08617 }
08618
08619
08620 rbtk_preserve_ip(ptr);
08621
08622
08623 DUMP2("call Tcl_GetCommandInfo, %s", cmd);
08624 if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
08625 DUMP1("error Tcl_GetCommandInfo");
08626 DUMP1("try auto_load (call 'unknown' command)");
08627 if (!Tcl_GetCommandInfo(ptr->ip,
08628 #if TCL_MAJOR_VERSION >= 8
08629 "::unknown",
08630 #else
08631 "unknown",
08632 #endif
08633 &info)) {
08634 DUMP1("fail to get 'unknown' command");
08635
08636 if (event_loop_abort_on_exc > 0) {
08637
08638 rbtk_release_ip(ptr);
08639
08640 return create_ip_exc(interp, rb_eNameError,
08641 "invalid command name `%s'", cmd);
08642 } else {
08643 if (event_loop_abort_on_exc < 0) {
08644 rb_warning("invalid command name `%s' (ignore)", cmd);
08645 } else {
08646 rb_warn("invalid command name `%s' (ignore)", cmd);
08647 }
08648 Tcl_ResetResult(ptr->ip);
08649
08650 rbtk_release_ip(ptr);
08651 return rb_tainted_str_new2("");
08652 }
08653 } else {
08654 #if TCL_MAJOR_VERSION >= 8
08655 Tcl_Obj **unknown_objv;
08656 #else
08657 char **unknown_argv;
08658 #endif
08659 DUMP1("find 'unknown' command -> set arguemnts");
08660 unknown_flag = 1;
08661
08662 #if TCL_MAJOR_VERSION >= 8
08663
08664 unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2));
08665 #if 0
08666 Tcl_Preserve((ClientData)unknown_objv);
08667 #endif
08668 unknown_objv[0] = Tcl_NewStringObj("::unknown", 9);
08669 Tcl_IncrRefCount(unknown_objv[0]);
08670 memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc);
08671 unknown_objv[++objc] = (Tcl_Obj*)NULL;
08672 objv = unknown_objv;
08673 #else
08674
08675 unknown_argv = RbTk_ALLOC_N(char *, (argc+2));
08676 #if 0
08677 Tcl_Preserve((ClientData)unknown_argv);
08678 #endif
08679 unknown_argv[0] = strdup("unknown");
08680 memcpy(unknown_argv + 1, argv, sizeof(char *)*argc);
08681 unknown_argv[++argc] = (char *)NULL;
08682 argv = unknown_argv;
08683 #endif
08684 }
08685 }
08686 DUMP1("end Tcl_GetCommandInfo");
08687
08688 thr_crit_bup = rb_thread_critical;
08689 rb_thread_critical = Qtrue;
08690
08691 #if 1
08692
08693 inf.ptr = ptr;
08694 inf.cmdinfo = info;
08695 #if TCL_MAJOR_VERSION >= 8
08696 inf.objc = objc;
08697 inf.objv = objv;
08698 #else
08699 inf.argc = argc;
08700 inf.argv = argv;
08701 #endif
08702
08703
08704 DUMP1("invoke tcl-proc");
08705 rb_protect(invoke_tcl_proc, (VALUE)&inf, &status);
08706 DUMP2("status of tcl-proc, %d", status);
08707 switch(status) {
08708 case TAG_RAISE:
08709 if (NIL_P(rb_errinfo())) {
08710 rbtk_pending_exception = rb_exc_new2(rb_eException,
08711 "unknown exception");
08712 } else {
08713 rbtk_pending_exception = rb_errinfo();
08714 }
08715 break;
08716
08717 case TAG_FATAL:
08718 if (NIL_P(rb_errinfo())) {
08719 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
08720 } else {
08721 rbtk_pending_exception = rb_errinfo();
08722 }
08723 }
08724
08725 #else
08726
08727
08728 #if TCL_MAJOR_VERSION >= 8
08729 if (!info.isNativeObjectProc) {
08730 int i;
08731
08732
08733
08734 argv = RbTk_ALLOC_N(char *, (argc+1));
08735 #if 0
08736 Tcl_Preserve((ClientData)argv);
08737 #endif
08738 for (i = 0; i < argc; ++i) {
08739 argv[i] = Tcl_GetStringFromObj(objv[i], &len);
08740 }
08741 argv[argc] = (char *)NULL;
08742 }
08743 #endif
08744
08745 Tcl_ResetResult(ptr->ip);
08746
08747
08748 #if TCL_MAJOR_VERSION >= 8
08749 if (info.isNativeObjectProc) {
08750 ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip,
08751 objc, objv);
08752 #if 0
08753
08754 resultPtr = Tcl_GetObjResult(ptr->ip);
08755 Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len),
08756 TCL_VOLATILE);
08757 #endif
08758 }
08759 else
08760 #endif
08761 {
08762 #if TCL_MAJOR_VERSION >= 8
08763 ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
08764 argc, (CONST84 char **)argv);
08765
08766 #if 0
08767 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
08768 #else
08769 #if 0
08770 Tcl_Release((ClientData)argv);
08771 #else
08772
08773 ckfree((char*)argv);
08774 #endif
08775 #endif
08776
08777 #else
08778 ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
08779 argc, argv);
08780 #endif
08781 }
08782 #endif
08783
08784
08785 if (unknown_flag) {
08786 #if TCL_MAJOR_VERSION >= 8
08787 Tcl_DecrRefCount(objv[0]);
08788 #if 0
08789 Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC);
08790 #else
08791 #if 0
08792 Tcl_Release((ClientData)objv);
08793 #else
08794
08795 ckfree((char*)objv);
08796 #endif
08797 #endif
08798 #else
08799 free(argv[0]);
08800
08801 #if 0
08802 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC);
08803 #else
08804 #if 0
08805 Tcl_Release((ClientData)argv);
08806 #else
08807
08808 ckfree((char*)argv);
08809 #endif
08810 #endif
08811 #endif
08812 }
08813
08814
08815 if (pending_exception_check1(thr_crit_bup, ptr)) {
08816 return rbtk_pending_exception;
08817 }
08818
08819 rb_thread_critical = thr_crit_bup;
08820
08821
08822 if (ptr->return_value != TCL_OK) {
08823 if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
08824 switch (ptr->return_value) {
08825 case TCL_RETURN:
08826 return create_ip_exc(interp, eTkCallbackReturn,
08827 "ip_invoke_core receives TCL_RETURN");
08828 case TCL_BREAK:
08829 return create_ip_exc(interp, eTkCallbackBreak,
08830 "ip_invoke_core receives TCL_BREAK");
08831 case TCL_CONTINUE:
08832 return create_ip_exc(interp, eTkCallbackContinue,
08833 "ip_invoke_core receives TCL_CONTINUE");
08834 default:
08835 return create_ip_exc(interp, rb_eRuntimeError, "%s",
08836 Tcl_GetStringResult(ptr->ip));
08837 }
08838
08839 } else {
08840 if (event_loop_abort_on_exc < 0) {
08841 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
08842 } else {
08843 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
08844 }
08845 Tcl_ResetResult(ptr->ip);
08846 return rb_tainted_str_new2("");
08847 }
08848 }
08849
08850
08851 return ip_get_result_string_obj(ptr->ip);
08852 }
08853
08854
08855 #if TCL_MAJOR_VERSION >= 8
08856 static Tcl_Obj **
08857 #else
08858 static char **
08859 #endif
08860 alloc_invoke_arguments(argc, argv)
08861 int argc;
08862 VALUE *argv;
08863 {
08864 int i;
08865 int thr_crit_bup;
08866
08867 #if TCL_MAJOR_VERSION >= 8
08868 Tcl_Obj **av;
08869 #else
08870 char **av;
08871 #endif
08872
08873 thr_crit_bup = rb_thread_critical;
08874 rb_thread_critical = Qtrue;
08875
08876
08877 #if TCL_MAJOR_VERSION >= 8
08878
08879 av = RbTk_ALLOC_N(Tcl_Obj *, (argc+1));
08880 #if 0
08881 Tcl_Preserve((ClientData)av);
08882 #endif
08883 for (i = 0; i < argc; ++i) {
08884 av[i] = get_obj_from_str(argv[i]);
08885 Tcl_IncrRefCount(av[i]);
08886 }
08887 av[argc] = NULL;
08888
08889 #else
08890
08891
08892 av = RbTk_ALLOC_N(char *, (argc+1));
08893 #if 0
08894 Tcl_Preserve((ClientData)av);
08895 #endif
08896 for (i = 0; i < argc; ++i) {
08897 av[i] = strdup(StringValuePtr(argv[i]));
08898 }
08899 av[argc] = NULL;
08900 #endif
08901
08902 rb_thread_critical = thr_crit_bup;
08903
08904 return av;
08905 }
08906
08907 static void
08908 free_invoke_arguments(argc, av)
08909 int argc;
08910 #if TCL_MAJOR_VERSION >= 8
08911 Tcl_Obj **av;
08912 #else
08913 char **av;
08914 #endif
08915 {
08916 int i;
08917
08918 for (i = 0; i < argc; ++i) {
08919 #if TCL_MAJOR_VERSION >= 8
08920 Tcl_DecrRefCount(av[i]);
08921 av[i] = (Tcl_Obj*)NULL;
08922 #else
08923 free(av[i]);
08924 av[i] = (char*)NULL;
08925 #endif
08926 }
08927 #if TCL_MAJOR_VERSION >= 8
08928 #if 0
08929 Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC);
08930 #else
08931 #if 0
08932 Tcl_Release((ClientData)av);
08933 #else
08934 ckfree((char*)av);
08935 #endif
08936 #endif
08937 #else
08938 #if 0
08939 Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC);
08940 #else
08941 #if 0
08942 Tcl_Release((ClientData)av);
08943 #else
08944
08945 ckfree((char*)av);
08946 #endif
08947 #endif
08948 #endif
08949 }
08950
08951 static VALUE
08952 ip_invoke_real(argc, argv, interp)
08953 int argc;
08954 VALUE *argv;
08955 VALUE interp;
08956 {
08957 VALUE v;
08958 struct tcltkip *ptr;
08959
08960 #if TCL_MAJOR_VERSION >= 8
08961 Tcl_Obj **av = (Tcl_Obj **)NULL;
08962 #else
08963 char **av = (char **)NULL;
08964 #endif
08965
08966 DUMP2("invoke_real called by thread:%lx", rb_thread_current());
08967
08968
08969 ptr = get_ip(interp);
08970
08971
08972 if (deleted_ip(ptr)) {
08973 return rb_tainted_str_new2("");
08974 }
08975
08976
08977 av = alloc_invoke_arguments(argc, argv);
08978
08979
08980 Tcl_ResetResult(ptr->ip);
08981 v = ip_invoke_core(interp, argc, av);
08982
08983
08984 free_invoke_arguments(argc, av);
08985
08986 return v;
08987 }
08988
08989 VALUE
08990 ivq_safelevel_handler(arg, ivq)
08991 VALUE arg;
08992 VALUE ivq;
08993 {
08994 struct invoke_queue *q;
08995
08996 Data_Get_Struct(ivq, struct invoke_queue, q);
08997 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
08998 rb_set_safe_level(q->safe_level);
08999 return ip_invoke_core(q->interp, q->argc, q->argv);
09000 }
09001
09002 int invoke_queue_handler _((Tcl_Event *, int));
09003 int
09004 invoke_queue_handler(evPtr, flags)
09005 Tcl_Event *evPtr;
09006 int flags;
09007 {
09008 struct invoke_queue *q = (struct invoke_queue *)evPtr;
09009 volatile VALUE ret;
09010 volatile VALUE q_dat;
09011 volatile VALUE thread = q->thread;
09012 struct tcltkip *ptr;
09013
09014 DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr);
09015 DUMP2("invoke queue_thread : %lx", rb_thread_current());
09016 DUMP2("added by thread : %lx", thread);
09017
09018 if (*(q->done)) {
09019 DUMP1("processed by another event-loop");
09020 return 0;
09021 } else {
09022 DUMP1("process it on current event-loop");
09023 }
09024
09025 if (RTEST(rb_thread_alive_p(thread))
09026 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
09027 DUMP1("caller is not yet ready to receive the result -> pending");
09028 return 0;
09029 }
09030
09031
09032 *(q->done) = 1;
09033
09034
09035 ptr = get_ip(q->interp);
09036 if (deleted_ip(ptr)) {
09037
09038 return 1;
09039 }
09040
09041
09042 rbtk_internal_eventloop_handler++;
09043
09044
09045 if (rb_safe_level() != q->safe_level) {
09046
09047 q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,-1,q);
09048 ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat),
09049 ID_call, 0);
09050 rb_gc_force_recycle(q_dat);
09051 q_dat = (VALUE)NULL;
09052 } else {
09053 DUMP2("call invoke_real (for caller thread:%lx)", thread);
09054 DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
09055 ret = ip_invoke_core(q->interp, q->argc, q->argv);
09056 }
09057
09058
09059 RARRAY_PTR(q->result)[0] = ret;
09060 ret = (VALUE)NULL;
09061
09062
09063 rbtk_internal_eventloop_handler--;
09064
09065
09066 *(q->done) = -1;
09067
09068
09069 q->interp = (VALUE)NULL;
09070 q->result = (VALUE)NULL;
09071 q->thread = (VALUE)NULL;
09072
09073
09074 if (RTEST(rb_thread_alive_p(thread))) {
09075 DUMP2("back to caller (caller thread:%lx)", thread);
09076 DUMP2(" (current thread:%lx)", rb_thread_current());
09077 #if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
09078 have_rb_thread_waiting_for_value = 1;
09079 rb_thread_wakeup(thread);
09080 #else
09081 rb_thread_run(thread);
09082 #endif
09083 DUMP1("finish back to caller");
09084 #if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
09085 rb_thread_schedule();
09086 #endif
09087 } else {
09088 DUMP2("caller is dead (caller thread:%lx)", thread);
09089 DUMP2(" (current thread:%lx)", rb_thread_current());
09090 }
09091
09092
09093 return 1;
09094 }
09095
09096 static VALUE
09097 ip_invoke_with_position(argc, argv, obj, position)
09098 int argc;
09099 VALUE *argv;
09100 VALUE obj;
09101 Tcl_QueuePosition position;
09102 {
09103 struct invoke_queue *ivq;
09104 #ifdef RUBY_USE_NATIVE_THREAD
09105 struct tcltkip *ptr;
09106 #endif
09107 int *alloc_done;
09108 int thr_crit_bup;
09109 volatile VALUE current = rb_thread_current();
09110 volatile VALUE ip_obj = obj;
09111 volatile VALUE result;
09112 volatile VALUE ret;
09113 struct timeval t;
09114
09115 #if TCL_MAJOR_VERSION >= 8
09116 Tcl_Obj **av = (Tcl_Obj **)NULL;
09117 #else
09118 char **av = (char **)NULL;
09119 #endif
09120
09121 if (argc < 1) {
09122 rb_raise(rb_eArgError, "command name missing");
09123 }
09124
09125 #ifdef RUBY_USE_NATIVE_THREAD
09126 ptr = get_ip(ip_obj);
09127 DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id);
09128 DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
09129 #else
09130 DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
09131 #endif
09132 DUMP2("status: eventloopt_thread %lx", eventloop_thread);
09133
09134 if (
09135 #ifdef RUBY_USE_NATIVE_THREAD
09136 (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
09137 &&
09138 #endif
09139 (NIL_P(eventloop_thread) || current == eventloop_thread)
09140 ) {
09141 if (NIL_P(eventloop_thread)) {
09142 DUMP2("invoke from thread:%lx but no eventloop", current);
09143 } else {
09144 DUMP2("invoke from current eventloop %lx", current);
09145 }
09146 result = ip_invoke_real(argc, argv, ip_obj);
09147 if (rb_obj_is_kind_of(result, rb_eException)) {
09148 rb_exc_raise(result);
09149 }
09150 return result;
09151 }
09152
09153 DUMP2("invoke from thread %lx (NOT current eventloop)", current);
09154
09155 thr_crit_bup = rb_thread_critical;
09156 rb_thread_critical = Qtrue;
09157
09158
09159 av = alloc_invoke_arguments(argc, argv);
09160
09161
09162
09163 alloc_done = RbTk_ALLOC_N(int, 1);
09164 #if 0
09165 Tcl_Preserve((ClientData)alloc_done);
09166 #endif
09167 *alloc_done = 0;
09168
09169
09170
09171 ivq = RbTk_ALLOC_N(struct invoke_queue, 1);
09172 #if 0
09173 Tcl_Preserve((ClientData)ivq);
09174 #endif
09175
09176
09177 result = rb_ary_new3(1, Qnil);
09178
09179
09180 ivq->done = alloc_done;
09181 ivq->argc = argc;
09182 ivq->argv = av;
09183 ivq->interp = ip_obj;
09184 ivq->result = result;
09185 ivq->thread = current;
09186 ivq->safe_level = rb_safe_level();
09187 ivq->ev.proc = invoke_queue_handler;
09188
09189
09190 DUMP1("add handler");
09191 #ifdef RUBY_USE_NATIVE_THREAD
09192 if (ptr->tk_thread_id) {
09193
09194 Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position);
09195 Tcl_ThreadAlert(ptr->tk_thread_id);
09196 } else if (tk_eventloop_thread_id) {
09197
09198
09199 Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
09200 (Tcl_Event*)ivq, position);
09201 Tcl_ThreadAlert(tk_eventloop_thread_id);
09202 } else {
09203
09204 Tcl_QueueEvent((Tcl_Event*)ivq, position);
09205 }
09206 #else
09207
09208 Tcl_QueueEvent((Tcl_Event*)ivq, position);
09209 #endif
09210
09211 rb_thread_critical = thr_crit_bup;
09212
09213
09214 t.tv_sec = 0;
09215 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);
09216
09217 DUMP2("ivq wait for handler (current thread:%lx)", current);
09218 while(*alloc_done >= 0) {
09219
09220
09221 rb_thread_wait_for(t);
09222 DUMP2("*** ivq wakeup (current thread:%lx)", current);
09223 DUMP2("*** (eventloop thread:%lx)", eventloop_thread);
09224 if (NIL_P(eventloop_thread)) {
09225 DUMP1("*** ivq lost eventloop thread");
09226 break;
09227 }
09228 }
09229 DUMP2("back from handler (current thread:%lx)", current);
09230
09231
09232 ret = RARRAY_PTR(result)[0];
09233 #if 0
09234 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC);
09235 #else
09236 #if 0
09237 Tcl_Release((ClientData)alloc_done);
09238 #else
09239
09240 ckfree((char*)alloc_done);
09241 #endif
09242 #endif
09243
09244 #if 0
09245 #if 0
09246 Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC);
09247 #else
09248 #if 0
09249 Tcl_Release(ivq);
09250 #else
09251 ckfree((char*)ivq);
09252 #endif
09253 #endif
09254 #endif
09255
09256
09257 free_invoke_arguments(argc, av);
09258
09259
09260 if (rb_obj_is_kind_of(ret, rb_eException)) {
09261 DUMP1("raise exception");
09262
09263 rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
09264 rb_funcall(ret, ID_to_s, 0, 0)));
09265 }
09266
09267 DUMP1("exit ip_invoke");
09268 return ret;
09269 }
09270
09271
09272
09273 static VALUE
09274 ip_retval(self)
09275 VALUE self;
09276 {
09277 struct tcltkip *ptr;
09278
09279
09280 ptr = get_ip(self);
09281
09282
09283 if (deleted_ip(ptr)) {
09284 return rb_tainted_str_new2("");
09285 }
09286
09287 return (INT2FIX(ptr->return_value));
09288 }
09289
09290 static VALUE
09291 ip_invoke(argc, argv, obj)
09292 int argc;
09293 VALUE *argv;
09294 VALUE obj;
09295 {
09296 return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL);
09297 }
09298
09299 static VALUE
09300 ip_invoke_immediate(argc, argv, obj)
09301 int argc;
09302 VALUE *argv;
09303 VALUE obj;
09304 {
09305
09306 return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD);
09307 }
09308
09309
09310
09311 static VALUE
09312 ip_get_variable2_core(interp, argc, argv)
09313 VALUE interp;
09314 int argc;
09315 VALUE *argv;
09316 {
09317 struct tcltkip *ptr = get_ip(interp);
09318 int thr_crit_bup;
09319 volatile VALUE varname, index, flag;
09320
09321 varname = argv[0];
09322 index = argv[1];
09323 flag = argv[2];
09324
09325
09326
09327
09328
09329
09330 #if TCL_MAJOR_VERSION >= 8
09331 {
09332 Tcl_Obj *ret;
09333 volatile VALUE strval;
09334
09335 thr_crit_bup = rb_thread_critical;
09336 rb_thread_critical = Qtrue;
09337
09338
09339 if (deleted_ip(ptr)) {
09340 rb_thread_critical = thr_crit_bup;
09341 return rb_tainted_str_new2("");
09342 } else {
09343
09344 rbtk_preserve_ip(ptr);
09345 ret = Tcl_GetVar2Ex(ptr->ip, RSTRING_PTR(varname),
09346 NIL_P(index) ? NULL : RSTRING_PTR(index),
09347 FIX2INT(flag));
09348 }
09349
09350 if (ret == (Tcl_Obj*)NULL) {
09351 volatile VALUE exc;
09352
09353
09354 exc = create_ip_exc(interp, rb_eRuntimeError,
09355 Tcl_GetStringResult(ptr->ip));
09356
09357 rbtk_release_ip(ptr);
09358 rb_thread_critical = thr_crit_bup;
09359 return exc;
09360 }
09361
09362 Tcl_IncrRefCount(ret);
09363 strval = get_str_from_obj(ret);
09364 RbTk_OBJ_UNTRUST(strval);
09365 Tcl_DecrRefCount(ret);
09366
09367
09368 rbtk_release_ip(ptr);
09369 rb_thread_critical = thr_crit_bup;
09370 return(strval);
09371 }
09372 #else
09373 {
09374 char *ret;
09375 volatile VALUE strval;
09376
09377
09378 if (deleted_ip(ptr)) {
09379 return rb_tainted_str_new2("");
09380 } else {
09381
09382 rbtk_preserve_ip(ptr);
09383 ret = Tcl_GetVar2(ptr->ip, RSTRING_PTR(varname),
09384 NIL_P(index) ? NULL : RSTRING_PTR(index),
09385 FIX2INT(flag));
09386 }
09387
09388 if (ret == (char*)NULL) {
09389 volatile VALUE exc;
09390 exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip));
09391
09392 rbtk_release_ip(ptr);
09393 rb_thread_critical = thr_crit_bup;
09394 return exc;
09395 }
09396
09397 strval = rb_tainted_str_new2(ret);
09398
09399 rbtk_release_ip(ptr);
09400 rb_thread_critical = thr_crit_bup;
09401
09402 return(strval);
09403 }
09404 #endif
09405 }
09406
09407 static VALUE
09408 ip_get_variable2(self, varname, index, flag)
09409 VALUE self;
09410 VALUE varname;
09411 VALUE index;
09412 VALUE flag;
09413 {
09414 VALUE argv[3];
09415 VALUE retval;
09416
09417 StringValue(varname);
09418 if (!NIL_P(index)) StringValue(index);
09419
09420 argv[0] = varname;
09421 argv[1] = index;
09422 argv[2] = flag;
09423
09424 retval = tk_funcall(ip_get_variable2_core, 3, argv, self);
09425
09426 if (NIL_P(retval)) {
09427 return rb_tainted_str_new2("");
09428 } else {
09429 return retval;
09430 }
09431 }
09432
09433 static VALUE
09434 ip_get_variable(self, varname, flag)
09435 VALUE self;
09436 VALUE varname;
09437 VALUE flag;
09438 {
09439 return ip_get_variable2(self, varname, Qnil, flag);
09440 }
09441
09442 static VALUE
09443 ip_set_variable2_core(interp, argc, argv)
09444 VALUE interp;
09445 int argc;
09446 VALUE *argv;
09447 {
09448 struct tcltkip *ptr = get_ip(interp);
09449 int thr_crit_bup;
09450 volatile VALUE varname, index, value, flag;
09451
09452 varname = argv[0];
09453 index = argv[1];
09454 value = argv[2];
09455 flag = argv[3];
09456
09457
09458
09459
09460
09461
09462
09463 #if TCL_MAJOR_VERSION >= 8
09464 {
09465 Tcl_Obj *valobj, *ret;
09466 volatile VALUE strval;
09467
09468 thr_crit_bup = rb_thread_critical;
09469 rb_thread_critical = Qtrue;
09470
09471 valobj = get_obj_from_str(value);
09472 Tcl_IncrRefCount(valobj);
09473
09474
09475 if (deleted_ip(ptr)) {
09476 Tcl_DecrRefCount(valobj);
09477 rb_thread_critical = thr_crit_bup;
09478 return rb_tainted_str_new2("");
09479 } else {
09480
09481 rbtk_preserve_ip(ptr);
09482 ret = Tcl_SetVar2Ex(ptr->ip, RSTRING_PTR(varname),
09483 NIL_P(index) ? NULL : RSTRING_PTR(index),
09484 valobj, FIX2INT(flag));
09485 }
09486
09487 Tcl_DecrRefCount(valobj);
09488
09489 if (ret == (Tcl_Obj*)NULL) {
09490 volatile VALUE exc;
09491
09492
09493 exc = create_ip_exc(interp, rb_eRuntimeError,
09494 Tcl_GetStringResult(ptr->ip));
09495
09496 rbtk_release_ip(ptr);
09497 rb_thread_critical = thr_crit_bup;
09498 return exc;
09499 }
09500
09501 Tcl_IncrRefCount(ret);
09502 strval = get_str_from_obj(ret);
09503 RbTk_OBJ_UNTRUST(strval);
09504 Tcl_DecrRefCount(ret);
09505
09506
09507 rbtk_release_ip(ptr);
09508 rb_thread_critical = thr_crit_bup;
09509
09510 return(strval);
09511 }
09512 #else
09513 {
09514 CONST char *ret;
09515 volatile VALUE strval;
09516
09517
09518 if (deleted_ip(ptr)) {
09519 return rb_tainted_str_new2("");
09520 } else {
09521
09522 rbtk_preserve_ip(ptr);
09523 ret = Tcl_SetVar2(ptr->ip, RSTRING_PTR(varname),
09524 NIL_P(index) ? NULL : RSTRING_PTR(index),
09525 RSTRING_PTR(value), FIX2INT(flag));
09526 }
09527
09528 if (ret == (char*)NULL) {
09529 return rb_exc_new2(rb_eRuntimeError, ptr->ip->result);
09530 }
09531
09532 strval = rb_tainted_str_new2(ret);
09533
09534
09535 rbtk_release_ip(ptr);
09536 rb_thread_critical = thr_crit_bup;
09537
09538 return(strval);
09539 }
09540 #endif
09541 }
09542
09543 static VALUE
09544 ip_set_variable2(self, varname, index, value, flag)
09545 VALUE self;
09546 VALUE varname;
09547 VALUE index;
09548 VALUE value;
09549 VALUE flag;
09550 {
09551 VALUE argv[4];
09552 VALUE retval;
09553
09554 StringValue(varname);
09555 if (!NIL_P(index)) StringValue(index);
09556 StringValue(value);
09557
09558 argv[0] = varname;
09559 argv[1] = index;
09560 argv[2] = value;
09561 argv[3] = flag;
09562
09563 retval = tk_funcall(ip_set_variable2_core, 4, argv, self);
09564
09565 if (NIL_P(retval)) {
09566 return rb_tainted_str_new2("");
09567 } else {
09568 return retval;
09569 }
09570 }
09571
09572 static VALUE
09573 ip_set_variable(self, varname, value, flag)
09574 VALUE self;
09575 VALUE varname;
09576 VALUE value;
09577 VALUE flag;
09578 {
09579 return ip_set_variable2(self, varname, Qnil, value, flag);
09580 }
09581
09582 static VALUE
09583 ip_unset_variable2_core(interp, argc, argv)
09584 VALUE interp;
09585 int argc;
09586 VALUE *argv;
09587 {
09588 struct tcltkip *ptr = get_ip(interp);
09589 volatile VALUE varname, index, flag;
09590
09591 varname = argv[0];
09592 index = argv[1];
09593 flag = argv[2];
09594
09595
09596
09597
09598
09599
09600
09601 if (deleted_ip(ptr)) {
09602 return Qtrue;
09603 }
09604
09605 ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING_PTR(varname),
09606 NIL_P(index) ? NULL : RSTRING_PTR(index),
09607 FIX2INT(flag));
09608
09609 if (ptr->return_value == TCL_ERROR) {
09610 if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
09611
09612
09613 return create_ip_exc(interp, rb_eRuntimeError,
09614 Tcl_GetStringResult(ptr->ip));
09615 }
09616 return Qfalse;
09617 }
09618 return Qtrue;
09619 }
09620
09621 static VALUE
09622 ip_unset_variable2(self, varname, index, flag)
09623 VALUE self;
09624 VALUE varname;
09625 VALUE index;
09626 VALUE flag;
09627 {
09628 VALUE argv[3];
09629 VALUE retval;
09630
09631 StringValue(varname);
09632 if (!NIL_P(index)) StringValue(index);
09633
09634 argv[0] = varname;
09635 argv[1] = index;
09636 argv[2] = flag;
09637
09638 retval = tk_funcall(ip_unset_variable2_core, 3, argv, self);
09639
09640 if (NIL_P(retval)) {
09641 return rb_tainted_str_new2("");
09642 } else {
09643 return retval;
09644 }
09645 }
09646
09647 static VALUE
09648 ip_unset_variable(self, varname, flag)
09649 VALUE self;
09650 VALUE varname;
09651 VALUE flag;
09652 {
09653 return ip_unset_variable2(self, varname, Qnil, flag);
09654 }
09655
09656 static VALUE
09657 ip_get_global_var(self, varname)
09658 VALUE self;
09659 VALUE varname;
09660 {
09661 return ip_get_variable(self, varname,
09662 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09663 }
09664
09665 static VALUE
09666 ip_get_global_var2(self, varname, index)
09667 VALUE self;
09668 VALUE varname;
09669 VALUE index;
09670 {
09671 return ip_get_variable2(self, varname, index,
09672 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09673 }
09674
09675 static VALUE
09676 ip_set_global_var(self, varname, value)
09677 VALUE self;
09678 VALUE varname;
09679 VALUE value;
09680 {
09681 return ip_set_variable(self, varname, value,
09682 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09683 }
09684
09685 static VALUE
09686 ip_set_global_var2(self, varname, index, value)
09687 VALUE self;
09688 VALUE varname;
09689 VALUE index;
09690 VALUE value;
09691 {
09692 return ip_set_variable2(self, varname, index, value,
09693 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09694 }
09695
09696 static VALUE
09697 ip_unset_global_var(self, varname)
09698 VALUE self;
09699 VALUE varname;
09700 {
09701 return ip_unset_variable(self, varname,
09702 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09703 }
09704
09705 static VALUE
09706 ip_unset_global_var2(self, varname, index)
09707 VALUE self;
09708 VALUE varname;
09709 VALUE index;
09710 {
09711 return ip_unset_variable2(self, varname, index,
09712 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
09713 }
09714
09715
09716
09717 static VALUE
09718 lib_split_tklist_core(ip_obj, list_str)
09719 VALUE ip_obj;
09720 VALUE list_str;
09721 {
09722 Tcl_Interp *interp;
09723 volatile VALUE ary, elem;
09724 int idx;
09725 int taint_flag = OBJ_TAINTED(list_str);
09726 #ifdef HAVE_RUBY_ENCODING_H
09727 int list_enc_idx;
09728 volatile VALUE list_ivar_enc;
09729 #endif
09730 int result;
09731 VALUE old_gc;
09732
09733 tcl_stubs_check();
09734
09735 if (NIL_P(ip_obj)) {
09736 interp = (Tcl_Interp *)NULL;
09737 } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) {
09738 interp = (Tcl_Interp *)NULL;
09739 } else {
09740 interp = get_ip(ip_obj)->ip;
09741 }
09742
09743 StringValue(list_str);
09744 #ifdef HAVE_RUBY_ENCODING_H
09745 list_enc_idx = rb_enc_get_index(list_str);
09746 list_ivar_enc = rb_ivar_get(list_str, ID_at_enc);
09747 #endif
09748
09749 {
09750 #if TCL_MAJOR_VERSION >= 8
09751
09752 Tcl_Obj *listobj;
09753 int objc;
09754 Tcl_Obj **objv;
09755 int thr_crit_bup;
09756
09757 listobj = get_obj_from_str(list_str);
09758
09759 Tcl_IncrRefCount(listobj);
09760
09761 result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv);
09762
09763 if (result == TCL_ERROR) {
09764 Tcl_DecrRefCount(listobj);
09765 if (interp == (Tcl_Interp*)NULL) {
09766 rb_raise(rb_eRuntimeError, "can't get elements from list");
09767 } else {
09768 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp));
09769 }
09770 }
09771
09772 for(idx = 0; idx < objc; idx++) {
09773 Tcl_IncrRefCount(objv[idx]);
09774 }
09775
09776 thr_crit_bup = rb_thread_critical;
09777 rb_thread_critical = Qtrue;
09778
09779 ary = rb_ary_new2(objc);
09780 if (taint_flag) RbTk_OBJ_UNTRUST(ary);
09781
09782 old_gc = rb_gc_disable();
09783
09784 for(idx = 0; idx < objc; idx++) {
09785 elem = get_str_from_obj(objv[idx]);
09786 if (taint_flag) RbTk_OBJ_UNTRUST(elem);
09787
09788 #ifdef HAVE_RUBY_ENCODING_H
09789 if (rb_enc_get_index(elem) == ENCODING_INDEX_BINARY) {
09790 rb_enc_associate_index(elem, ENCODING_INDEX_BINARY);
09791 rb_ivar_set(elem, ID_at_enc, ENCODING_NAME_BINARY);
09792 } else {
09793 rb_enc_associate_index(elem, list_enc_idx);
09794 rb_ivar_set(elem, ID_at_enc, list_ivar_enc);
09795 }
09796 #endif
09797
09798 rb_ary_push(ary, elem);
09799 }
09800
09801
09802
09803 if (old_gc == Qfalse) rb_gc_enable();
09804
09805 rb_thread_critical = thr_crit_bup;
09806
09807 for(idx = 0; idx < objc; idx++) {
09808 Tcl_DecrRefCount(objv[idx]);
09809 }
09810
09811 Tcl_DecrRefCount(listobj);
09812
09813 #else
09814
09815 int argc;
09816 char **argv;
09817
09818 if (Tcl_SplitList(interp, RSTRING_PTR(list_str),
09819 &argc, &argv) == TCL_ERROR) {
09820 if (interp == (Tcl_Interp*)NULL) {
09821 rb_raise(rb_eRuntimeError, "can't get elements from list");
09822 } else {
09823 rb_raise(rb_eRuntimeError, "%s", interp->result);
09824 }
09825 }
09826
09827 ary = rb_ary_new2(argc);
09828 if (taint_flag) RbTk_OBJ_UNTRUST(ary);
09829
09830 old_gc = rb_gc_disable();
09831
09832 for(idx = 0; idx < argc; idx++) {
09833 if (taint_flag) {
09834 elem = rb_tainted_str_new2(argv[idx]);
09835 } else {
09836 elem = rb_str_new2(argv[idx]);
09837 }
09838
09839
09840 rb_ary_push(ary, elem)
09841 }
09842
09843
09844 if (old_gc == Qfalse) rb_gc_enable();
09845 #endif
09846 }
09847
09848 return ary;
09849 }
09850
09851 static VALUE
09852 lib_split_tklist(self, list_str)
09853 VALUE self;
09854 VALUE list_str;
09855 {
09856 return lib_split_tklist_core(Qnil, list_str);
09857 }
09858
09859
09860 static VALUE
09861 ip_split_tklist(self, list_str)
09862 VALUE self;
09863 VALUE list_str;
09864 {
09865 return lib_split_tklist_core(self, list_str);
09866 }
09867
09868 static VALUE
09869 lib_merge_tklist(argc, argv, obj)
09870 int argc;
09871 VALUE *argv;
09872 VALUE obj;
09873 {
09874 int num, len;
09875 int *flagPtr;
09876 char *dst, *result;
09877 volatile VALUE str;
09878 int taint_flag = 0;
09879 int thr_crit_bup;
09880 VALUE old_gc;
09881
09882 if (argc == 0) return rb_str_new2("");
09883
09884 tcl_stubs_check();
09885
09886 thr_crit_bup = rb_thread_critical;
09887 rb_thread_critical = Qtrue;
09888 old_gc = rb_gc_disable();
09889
09890
09891
09892 flagPtr = RbTk_ALLOC_N(int, argc);
09893 #if 0
09894 Tcl_Preserve((ClientData)flagPtr);
09895 #endif
09896
09897
09898 len = 1;
09899 for(num = 0; num < argc; num++) {
09900 if (OBJ_TAINTED(argv[num])) taint_flag = 1;
09901 dst = StringValuePtr(argv[num]);
09902 #if TCL_MAJOR_VERSION >= 8
09903 len += Tcl_ScanCountedElement(dst, RSTRING_LENINT(argv[num]),
09904 &flagPtr[num]) + 1;
09905 #else
09906 len += Tcl_ScanElement(dst, &flagPtr[num]) + 1;
09907 #endif
09908 }
09909
09910
09911
09912 result = (char *)ckalloc(len);
09913 #if 0
09914 Tcl_Preserve((ClientData)result);
09915 #endif
09916 dst = result;
09917 for(num = 0; num < argc; num++) {
09918 #if TCL_MAJOR_VERSION >= 8
09919 len = Tcl_ConvertCountedElement(RSTRING_PTR(argv[num]),
09920 RSTRING_LENINT(argv[num]),
09921 dst, flagPtr[num]);
09922 #else
09923 len = Tcl_ConvertElement(RSTRING_PTR(argv[num]), dst, flagPtr[num]);
09924 #endif
09925 dst += len;
09926 *dst = ' ';
09927 dst++;
09928 }
09929 if (dst == result) {
09930 *dst = 0;
09931 } else {
09932 dst[-1] = 0;
09933 }
09934
09935 #if 0
09936 Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC);
09937 #else
09938 #if 0
09939 Tcl_Release((ClientData)flagPtr);
09940 #else
09941
09942 ckfree((char*)flagPtr);
09943 #endif
09944 #endif
09945
09946
09947 str = rb_str_new(result, dst - result - 1);
09948 if (taint_flag) RbTk_OBJ_UNTRUST(str);
09949 #if 0
09950 Tcl_EventuallyFree((ClientData)result, TCL_DYNAMIC);
09951 #else
09952 #if 0
09953 Tcl_Release((ClientData)result);
09954 #else
09955
09956 ckfree(result);
09957 #endif
09958 #endif
09959
09960 if (old_gc == Qfalse) rb_gc_enable();
09961 rb_thread_critical = thr_crit_bup;
09962
09963 return str;
09964 }
09965
09966 static VALUE
09967 lib_conv_listelement(self, src)
09968 VALUE self;
09969 VALUE src;
09970 {
09971 int len, scan_flag;
09972 volatile VALUE dst;
09973 int taint_flag = OBJ_TAINTED(src);
09974 int thr_crit_bup;
09975
09976 tcl_stubs_check();
09977
09978 thr_crit_bup = rb_thread_critical;
09979 rb_thread_critical = Qtrue;
09980
09981 StringValue(src);
09982
09983 #if TCL_MAJOR_VERSION >= 8
09984 len = Tcl_ScanCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
09985 &scan_flag);
09986 dst = rb_str_new(0, len + 1);
09987 len = Tcl_ConvertCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src),
09988 RSTRING_PTR(dst), scan_flag);
09989 #else
09990 len = Tcl_ScanElement(RSTRING_PTR(src), &scan_flag);
09991 dst = rb_str_new(0, len + 1);
09992 len = Tcl_ConvertElement(RSTRING_PTR(src), RSTRING_PTR(dst), scan_flag);
09993 #endif
09994
09995 rb_str_resize(dst, len);
09996 if (taint_flag) RbTk_OBJ_UNTRUST(dst);
09997
09998 rb_thread_critical = thr_crit_bup;
09999
10000 return dst;
10001 }
10002
10003 static VALUE
10004 lib_getversion(self)
10005 VALUE self;
10006 {
10007 set_tcltk_version();
10008
10009 return rb_ary_new3(4, INT2NUM(tcltk_version.major),
10010 INT2NUM(tcltk_version.minor),
10011 INT2NUM(tcltk_version.type),
10012 INT2NUM(tcltk_version.patchlevel));
10013 }
10014
10015 static VALUE
10016 lib_get_reltype_name(self)
10017 VALUE self;
10018 {
10019 set_tcltk_version();
10020
10021 switch(tcltk_version.type) {
10022 case TCL_ALPHA_RELEASE:
10023 return rb_str_new2("alpha");
10024 case TCL_BETA_RELEASE:
10025 return rb_str_new2("beta");
10026 case TCL_FINAL_RELEASE:
10027 return rb_str_new2("final");
10028 default:
10029 rb_raise(rb_eRuntimeError, "tcltklib has invalid release type number");
10030 }
10031
10032 UNREACHABLE;
10033 }
10034
10035
10036 static VALUE
10037 tcltklib_compile_info()
10038 {
10039 volatile VALUE ret;
10040 size_t size;
10041 static CONST char form[]
10042 = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s";
10043 char *info;
10044
10045 size = strlen(form)
10046 + strlen(TCLTKLIB_RELEASE_DATE)
10047 + strlen(RUBY_VERSION)
10048 + strlen(RUBY_RELEASE_DATE)
10049 + strlen("without")
10050 + strlen(TCL_PATCH_LEVEL)
10051 + strlen("without stub")
10052 + strlen(TK_PATCH_LEVEL)
10053 + strlen("without stub")
10054 + strlen("unknown tcl_threads");
10055
10056 info = ALLOC_N(char, size);
10057
10058
10059 sprintf(info, form,
10060 TCLTKLIB_RELEASE_DATE,
10061 RUBY_VERSION, RUBY_RELEASE_DATE,
10062 #ifdef HAVE_NATIVETHREAD
10063 "with",
10064 #else
10065 "without",
10066 #endif
10067 TCL_PATCH_LEVEL,
10068 #ifdef USE_TCL_STUBS
10069 "with stub",
10070 #else
10071 "without stub",
10072 #endif
10073 TK_PATCH_LEVEL,
10074 #ifdef USE_TK_STUBS
10075 "with stub",
10076 #else
10077 "without stub",
10078 #endif
10079 #ifdef WITH_TCL_ENABLE_THREAD
10080 # if WITH_TCL_ENABLE_THREAD
10081 "with tcl_threads"
10082 # else
10083 "without tcl_threads"
10084 # endif
10085 #else
10086 "unknown tcl_threads"
10087 #endif
10088 );
10089
10090 ret = rb_obj_freeze(rb_str_new2(info));
10091
10092 xfree(info);
10093
10094
10095 return ret;
10096 }
10097
10098
10099
10100
10101 static VALUE
10102 create_dummy_encoding_for_tk_core(interp, name, error_mode)
10103 VALUE interp;
10104 VALUE name;
10105 VALUE error_mode;
10106 {
10107 get_ip(interp);
10108
10109
10110 StringValue(name);
10111
10112 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10113 if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) {
10114 if (RTEST(error_mode)) {
10115 rb_raise(rb_eArgError, "invalid Tk encoding name '%s'",
10116 RSTRING_PTR(name));
10117 } else {
10118 return Qnil;
10119 }
10120 }
10121 #endif
10122
10123 #ifdef HAVE_RUBY_ENCODING_H
10124 if (RTEST(rb_define_dummy_encoding(RSTRING_PTR(name)))) {
10125 int idx = rb_enc_find_index(StringValueCStr(name));
10126 return rb_enc_from_encoding(rb_enc_from_index(idx));
10127 } else {
10128 if (RTEST(error_mode)) {
10129 rb_raise(rb_eRuntimeError, "fail to create dummy encoding for '%s'",
10130 RSTRING_PTR(name));
10131 } else {
10132 return Qnil;
10133 }
10134 }
10135
10136 UNREACHABLE;
10137 #else
10138 return name;
10139 #endif
10140 }
10141 static VALUE
10142 create_dummy_encoding_for_tk(interp, name)
10143 VALUE interp;
10144 VALUE name;
10145 {
10146 return create_dummy_encoding_for_tk_core(interp, name, Qtrue);
10147 }
10148
10149
10150 #ifdef HAVE_RUBY_ENCODING_H
10151 static int
10152 update_encoding_table(table, interp, error_mode)
10153 VALUE table;
10154 VALUE interp;
10155 VALUE error_mode;
10156 {
10157 struct tcltkip *ptr;
10158 int retry = 0;
10159 int i, idx, objc;
10160 Tcl_Obj **objv;
10161 Tcl_Obj *enc_list;
10162 volatile VALUE encname = Qnil;
10163 volatile VALUE encobj = Qnil;
10164
10165
10166 if (NIL_P(interp)) return 0;
10167 ptr = get_ip(interp);
10168 if (ptr == (struct tcltkip *) NULL) return 0;
10169 if (deleted_ip(ptr)) return 0;
10170
10171
10172 Tcl_GetEncodingNames(ptr->ip);
10173 enc_list = Tcl_GetObjResult(ptr->ip);
10174 Tcl_IncrRefCount(enc_list);
10175
10176 if (Tcl_ListObjGetElements(ptr->ip, enc_list,
10177 &objc, &objv) != TCL_OK) {
10178 Tcl_DecrRefCount(enc_list);
10179
10180 return 0;
10181 }
10182
10183
10184 for(i = 0; i < objc; i++) {
10185 encname = rb_str_new2(Tcl_GetString(objv[i]));
10186 if (NIL_P(rb_hash_lookup(table, encname))) {
10187
10188 idx = rb_enc_find_index(StringValueCStr(encname));
10189 if (idx < 0) {
10190 encobj = create_dummy_encoding_for_tk_core(interp,encname,error_mode);
10191 } else {
10192 encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
10193 }
10194 encname = rb_obj_freeze(encname);
10195 rb_hash_aset(table, encname, encobj);
10196 if (!NIL_P(encobj) && NIL_P(rb_hash_lookup(table, encobj))) {
10197 rb_hash_aset(table, encobj, encname);
10198 }
10199 retry = 1;
10200 }
10201 }
10202
10203 Tcl_DecrRefCount(enc_list);
10204
10205 return retry;
10206 }
10207
10208 static VALUE
10209 encoding_table_get_name_core(table, enc_arg, error_mode)
10210 VALUE table;
10211 VALUE enc_arg;
10212 VALUE error_mode;
10213 {
10214 volatile VALUE enc = enc_arg;
10215 volatile VALUE name = Qnil;
10216 volatile VALUE tmp = Qnil;
10217 volatile VALUE interp = rb_ivar_get(table, ID_at_interp);
10218 struct tcltkip *ptr = (struct tcltkip *) NULL;
10219 int idx;
10220
10221
10222 if (!NIL_P(interp)) {
10223 ptr = get_ip(interp);
10224 if (deleted_ip(ptr)) {
10225 ptr = (struct tcltkip *) NULL;
10226 }
10227 }
10228
10229
10230
10231 if (ptr && NIL_P(enc)) {
10232 if (rb_respond_to(interp, ID_encoding_name)) {
10233 enc = rb_funcall(interp, ID_encoding_name, 0, 0);
10234 }
10235 }
10236
10237 if (NIL_P(enc)) {
10238 enc = rb_enc_default_internal();
10239 }
10240
10241 if (NIL_P(enc)) {
10242 enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL));
10243 }
10244
10245 if (NIL_P(enc)) {
10246 enc = rb_enc_default_external();
10247 }
10248
10249 if (NIL_P(enc)) {
10250 enc = rb_locale_charmap(rb_cEncoding);
10251 }
10252
10253 if (RTEST(rb_obj_is_kind_of(enc, cRubyEncoding))) {
10254
10255 name = rb_hash_lookup(table, enc);
10256 if (!NIL_P(name)) {
10257
10258 return name;
10259 }
10260
10261
10262
10263 if (update_encoding_table(table, interp, error_mode)) {
10264
10265
10266 name = rb_hash_lookup(table, enc);
10267 if (!NIL_P(name)) {
10268
10269 return name;
10270 }
10271 }
10272
10273
10274 } else {
10275
10276 name = rb_funcall(enc, ID_to_s, 0, 0);
10277
10278 if (!NIL_P(rb_hash_lookup(table, name))) {
10279
10280 return name;
10281 }
10282
10283
10284 idx = rb_enc_find_index(StringValueCStr(name));
10285 if (idx >= 0) {
10286 enc = rb_enc_from_encoding(rb_enc_from_index(idx));
10287
10288
10289 tmp = rb_hash_lookup(table, enc);
10290 if (!NIL_P(tmp)) {
10291
10292 return tmp;
10293 }
10294
10295
10296 if (update_encoding_table(table, interp, error_mode)) {
10297
10298
10299 tmp = rb_hash_lookup(table, enc);
10300 if (!NIL_P(tmp)) {
10301
10302 return tmp;
10303 }
10304 }
10305 }
10306
10307 }
10308
10309 if (RTEST(error_mode)) {
10310 enc = rb_funcall(enc_arg, ID_to_s, 0, 0);
10311 rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
10312 }
10313 return Qnil;
10314 }
10315 static VALUE
10316 encoding_table_get_obj_core(table, enc, error_mode)
10317 VALUE table;
10318 VALUE enc;
10319 VALUE error_mode;
10320 {
10321 volatile VALUE obj = Qnil;
10322
10323 obj = rb_hash_lookup(table,
10324 encoding_table_get_name_core(table, enc, error_mode));
10325 if (RTEST(rb_obj_is_kind_of(obj, cRubyEncoding))) {
10326 return obj;
10327 } else {
10328 return Qnil;
10329 }
10330 }
10331
10332 #else
10333 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10334 static int
10335 update_encoding_table(table, interp, error_mode)
10336 VALUE table;
10337 VALUE interp;
10338 VALUE error_mode;
10339 {
10340 struct tcltkip *ptr;
10341 int retry = 0;
10342 int i, objc;
10343 Tcl_Obj **objv;
10344 Tcl_Obj *enc_list;
10345 volatile VALUE encname = Qnil;
10346
10347
10348 if (NIL_P(interp)) return 0;
10349 ptr = get_ip(interp);
10350 if (ptr == (struct tcltkip *) NULL) return 0;
10351 if (deleted_ip(ptr)) return 0;
10352
10353
10354 Tcl_GetEncodingNames(ptr->ip);
10355 enc_list = Tcl_GetObjResult(ptr->ip);
10356 Tcl_IncrRefCount(enc_list);
10357
10358 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10359 Tcl_DecrRefCount(enc_list);
10360
10361 return 0;
10362 }
10363
10364
10365 for(i = 0; i < objc; i++) {
10366 encname = rb_str_new2(Tcl_GetString(objv[i]));
10367 if (NIL_P(rb_hash_lookup(table, encname))) {
10368
10369 encname = rb_obj_freeze(encname);
10370 rb_hash_aset(table, encname, encname);
10371 retry = 1;
10372 }
10373 }
10374
10375 Tcl_DecrRefCount(enc_list);
10376
10377 return retry;
10378 }
10379
10380 static VALUE
10381 encoding_table_get_name_core(table, enc, error_mode)
10382 VALUE table;
10383 VALUE enc;
10384 VALUE error_mode;
10385 {
10386 volatile VALUE name = Qnil;
10387
10388 enc = rb_funcall(enc, ID_to_s, 0, 0);
10389 name = rb_hash_lookup(table, enc);
10390
10391 if (!NIL_P(name)) {
10392
10393 return name;
10394 }
10395
10396
10397 if (update_encoding_table(table, rb_ivar_get(table, ID_at_interp),
10398 error_mode)) {
10399
10400
10401 name = rb_hash_lookup(table, enc);
10402 if (!NIL_P(name)) {
10403
10404 return name;
10405 }
10406 }
10407
10408 if (RTEST(error_mode)) {
10409 rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc));
10410 }
10411 return Qnil;
10412 }
10413 static VALUE
10414 encoding_table_get_obj_core(table, enc, error_mode)
10415 VALUE table;
10416 VALUE enc;
10417 VALUE error_mode;
10418 {
10419 return encoding_table_get_name_core(table, enc, error_mode);
10420 }
10421
10422 #else
10423 static VALUE
10424 encoding_table_get_name_core(table, enc, error_mode)
10425 VALUE table;
10426 VALUE enc;
10427 VALUE error_mode;
10428 {
10429 return Qnil;
10430 }
10431 static VALUE
10432 encoding_table_get_obj_core(table, enc, error_mode)
10433 VALUE table;
10434 VALUE enc;
10435 VALUE error_mode;
10436 {
10437 return Qnil;
10438 }
10439 #endif
10440 #endif
10441
10442 static VALUE
10443 encoding_table_get_name(table, enc)
10444 VALUE table;
10445 VALUE enc;
10446 {
10447 return encoding_table_get_name_core(table, enc, Qtrue);
10448 }
10449 static VALUE
10450 encoding_table_get_obj(table, enc)
10451 VALUE table;
10452 VALUE enc;
10453 {
10454 return encoding_table_get_obj_core(table, enc, Qtrue);
10455 }
10456
10457 #ifdef HAVE_RUBY_ENCODING_H
10458 static VALUE
10459 create_encoding_table_core(arg, interp)
10460 VALUE arg;
10461 VALUE interp;
10462 {
10463 struct tcltkip *ptr = get_ip(interp);
10464 volatile VALUE table = rb_hash_new();
10465 volatile VALUE encname = Qnil;
10466 volatile VALUE encobj = Qnil;
10467 int i, idx, objc;
10468 Tcl_Obj **objv;
10469 Tcl_Obj *enc_list;
10470
10471 #ifdef HAVE_RB_SET_SAFE_LEVEL_FORCE
10472 rb_set_safe_level_force(0);
10473 #else
10474 rb_set_safe_level(0);
10475 #endif
10476
10477
10478 encobj = rb_enc_from_encoding(rb_enc_from_index(ENCODING_INDEX_BINARY));
10479 rb_hash_aset(table, ENCODING_NAME_BINARY, encobj);
10480 rb_hash_aset(table, encobj, ENCODING_NAME_BINARY);
10481
10482
10483
10484 tcl_stubs_check();
10485
10486
10487 Tcl_GetEncodingNames(ptr->ip);
10488 enc_list = Tcl_GetObjResult(ptr->ip);
10489 Tcl_IncrRefCount(enc_list);
10490
10491 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10492 Tcl_DecrRefCount(enc_list);
10493 rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
10494 }
10495
10496
10497 for(i = 0; i < objc; i++) {
10498 int name2obj, obj2name;
10499
10500 name2obj = 1; obj2name = 1;
10501 encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
10502 idx = rb_enc_find_index(StringValueCStr(encname));
10503 if (idx < 0) {
10504
10505 if (strcmp(RSTRING_PTR(encname), "identity") == 0) {
10506 name2obj = 1; obj2name = 0;
10507 idx = ENCODING_INDEX_BINARY;
10508
10509 } else if (strcmp(RSTRING_PTR(encname), "shiftjis") == 0) {
10510 name2obj = 1; obj2name = 0;
10511 idx = rb_enc_find_index("Shift_JIS");
10512
10513 } else if (strcmp(RSTRING_PTR(encname), "unicode") == 0) {
10514 name2obj = 1; obj2name = 0;
10515 idx = ENCODING_INDEX_UTF8;
10516
10517 } else if (strcmp(RSTRING_PTR(encname), "symbol") == 0) {
10518 name2obj = 1; obj2name = 0;
10519 idx = rb_enc_find_index("ASCII-8BIT");
10520
10521 } else {
10522
10523 name2obj = 1; obj2name = 1;
10524 }
10525 }
10526
10527 if (idx < 0) {
10528
10529 encobj = create_dummy_encoding_for_tk(interp, encname);
10530 } else {
10531 encobj = rb_enc_from_encoding(rb_enc_from_index(idx));
10532 }
10533
10534 if (name2obj) {
10535 DUMP2("create_encoding_table: name2obj: %s", RSTRING_PTR(encname));
10536 rb_hash_aset(table, encname, encobj);
10537 }
10538 if (obj2name) {
10539 DUMP2("create_encoding_table: obj2name: %s", RSTRING_PTR(encname));
10540 rb_hash_aset(table, encobj, encname);
10541 }
10542 }
10543
10544 Tcl_DecrRefCount(enc_list);
10545
10546 rb_ivar_set(table, ID_at_interp, interp);
10547 rb_ivar_set(interp, ID_encoding_table, table);
10548
10549 return table;
10550 }
10551
10552 #else
10553 #if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)
10554 static VALUE
10555 create_encoding_table_core(arg, interp)
10556 VALUE arg;
10557 VALUE interp;
10558 {
10559 struct tcltkip *ptr = get_ip(interp);
10560 volatile VALUE table = rb_hash_new();
10561 volatile VALUE encname = Qnil;
10562 int i, objc;
10563 Tcl_Obj **objv;
10564 Tcl_Obj *enc_list;
10565
10566
10567
10568 rb_hash_aset(table, ENCODING_NAME_BINARY, ENCODING_NAME_BINARY);
10569
10570
10571 Tcl_GetEncodingNames(ptr->ip);
10572 enc_list = Tcl_GetObjResult(ptr->ip);
10573 Tcl_IncrRefCount(enc_list);
10574
10575 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) {
10576 Tcl_DecrRefCount(enc_list);
10577 rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");
10578 }
10579
10580
10581 for(i = 0; i < objc; i++) {
10582 encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i])));
10583 rb_hash_aset(table, encname, encname);
10584 }
10585
10586 Tcl_DecrRefCount(enc_list);
10587
10588 rb_ivar_set(table, ID_at_interp, interp);
10589 rb_ivar_set(interp, ID_encoding_table, table);
10590
10591 return table;
10592 }
10593
10594 #else
10595 static VALUE
10596 create_encoding_table_core(arg, interp)
10597 VALUE arg;
10598 VALUE interp;
10599 {
10600 volatile VALUE table = rb_hash_new();
10601 rb_ivar_set(interp, ID_encoding_table, table);
10602 return table;
10603 }
10604 #endif
10605 #endif
10606
10607 static VALUE
10608 create_encoding_table(interp)
10609 VALUE interp;
10610 {
10611 return rb_funcall(rb_proc_new(create_encoding_table_core, interp),
10612 ID_call, 0);
10613 }
10614
10615 static VALUE
10616 ip_get_encoding_table(interp)
10617 VALUE interp;
10618 {
10619 volatile VALUE table = Qnil;
10620
10621 table = rb_ivar_get(interp, ID_encoding_table);
10622
10623 if (NIL_P(table)) {
10624
10625 table = create_encoding_table(interp);
10626 rb_define_singleton_method(table, "get_name", encoding_table_get_name, 1);
10627 rb_define_singleton_method(table, "get_obj", encoding_table_get_obj, 1);
10628 }
10629
10630 return table;
10631 }
10632
10633
10634
10635
10636
10637
10638
10639
10640 #if TCL_MAJOR_VERSION >= 8
10641
10642 #define MASTER_MENU 0
10643 #define TEAROFF_MENU 1
10644 #define MENUBAR 2
10645
10646 struct dummy_TkMenuEntry {
10647 int type;
10648 struct dummy_TkMenu *menuPtr;
10649
10650 };
10651
10652 struct dummy_TkMenu {
10653 Tk_Window tkwin;
10654 Display *display;
10655 Tcl_Interp *interp;
10656 Tcl_Command widgetCmd;
10657 struct dummy_TkMenuEntry **entries;
10658 int numEntries;
10659 int active;
10660 int menuType;
10661 Tcl_Obj *menuTypePtr;
10662
10663 };
10664
10665 struct dummy_TkMenuRef {
10666 struct dummy_TkMenu *menuPtr;
10667 char *dummy1;
10668 char *dummy2;
10669 char *dummy3;
10670 };
10671
10672 #if 0
10673 EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*);
10674 #else
10675 #define MENU_HASH_KEY "tkMenus"
10676 #endif
10677
10678 #endif
10679
10680 static VALUE
10681 ip_make_menu_embeddable_core(interp, argc, argv)
10682 VALUE interp;
10683 int argc;
10684 VALUE *argv;
10685 {
10686 #if TCL_MAJOR_VERSION >= 8
10687 volatile VALUE menu_path;
10688 struct tcltkip *ptr = get_ip(interp);
10689 struct dummy_TkMenuRef *menuRefPtr = NULL;
10690 XEvent event;
10691 Tcl_HashTable *menuTablePtr;
10692 Tcl_HashEntry *hashEntryPtr;
10693
10694 menu_path = argv[0];
10695 StringValue(menu_path);
10696
10697 #if 0
10698 menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path));
10699 #else
10700 if ((menuTablePtr
10701 = (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL))
10702 != NULL) {
10703 if ((hashEntryPtr
10704 = Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path)))
10705 != NULL) {
10706 menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr);
10707 }
10708 }
10709 #endif
10710
10711 if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) {
10712 rb_raise(rb_eArgError, "not a menu widget, or invalid widget path");
10713 }
10714
10715 if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) {
10716 rb_raise(rb_eRuntimeError,
10717 "invalid menu widget (maybe already destroyed)");
10718 }
10719
10720 if ((menuRefPtr->menuPtr)->menuType != MENUBAR) {
10721 rb_raise(rb_eRuntimeError,
10722 "target menu widget must be a MENUBAR type");
10723 }
10724
10725 (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU;
10726 #if 0
10727 {
10728
10729 char *s = "normal";
10730
10731 (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s));
10732
10733
10734 (menuRefPtr->menuPtr)->menuType = MASTER_MENU;
10735 }
10736 #endif
10737
10738 #if 0
10739 TkEventuallyRecomputeMenu(menuRefPtr->menuPtr);
10740 TkEventuallyRedrawMenu(menuRefPtr->menuPtr,
10741 (struct dummy_TkMenuEntry *)NULL);
10742 #else
10743 memset((void *) &event, 0, sizeof(event));
10744 event.xany.type = ConfigureNotify;
10745 event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin));
10746 event.xany.send_event = 0;
10747 event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin);
10748 event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin);
10749 event.xconfigure.window = event.xany.window;
10750 Tk_HandleEvent(&event);
10751 #endif
10752
10753 #else
10754 rb_notimplement();
10755 #endif
10756
10757 return interp;
10758 }
10759
10760 static VALUE
10761 ip_make_menu_embeddable(interp, menu_path)
10762 VALUE interp;
10763 VALUE menu_path;
10764 {
10765 VALUE argv[1];
10766
10767 argv[0] = menu_path;
10768 return tk_funcall(ip_make_menu_embeddable_core, 1, argv, interp);
10769 }
10770
10771
10772
10773
10774
10775 void
10776 Init_tcltklib()
10777 {
10778 int ret;
10779
10780 VALUE lib = rb_define_module("TclTkLib");
10781 VALUE ip = rb_define_class("TclTkIp", rb_cObject);
10782
10783 VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
10784 VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag");
10785 VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE");
10786
10787
10788
10789 tcltkip_class = ip;
10790
10791
10792
10793 #ifdef HAVE_RUBY_ENCODING_H
10794 rb_global_variable(&cRubyEncoding);
10795 cRubyEncoding = rb_path2class("Encoding");
10796
10797 ENCODING_INDEX_UTF8 = rb_enc_to_index(rb_utf8_encoding());
10798 ENCODING_INDEX_BINARY = rb_enc_find_index("binary");
10799 #endif
10800
10801 rb_global_variable(&ENCODING_NAME_UTF8);
10802 rb_global_variable(&ENCODING_NAME_BINARY);
10803
10804 ENCODING_NAME_UTF8 = rb_obj_freeze(rb_str_new2("utf-8"));
10805 ENCODING_NAME_BINARY = rb_obj_freeze(rb_str_new2("binary"));
10806
10807
10808
10809 rb_global_variable(&eTkCallbackReturn);
10810 rb_global_variable(&eTkCallbackBreak);
10811 rb_global_variable(&eTkCallbackContinue);
10812
10813 rb_global_variable(&eventloop_thread);
10814 rb_global_variable(&eventloop_stack);
10815 rb_global_variable(&watchdog_thread);
10816
10817 rb_global_variable(&rbtk_pending_exception);
10818
10819
10820
10821 rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info());
10822
10823 rb_define_const(lib, "RELEASE_DATE",
10824 rb_obj_freeze(rb_str_new2(tcltklib_release_date)));
10825
10826 rb_define_const(lib, "FINALIZE_PROC_NAME",
10827 rb_str_new2(finalize_hook_name));
10828
10829
10830
10831 #ifdef __WIN32__
10832 # define TK_WINDOWING_SYSTEM "win32"
10833 #else
10834 # ifdef MAC_TCL
10835 # define TK_WINDOWING_SYSTEM "classic"
10836 # else
10837 # ifdef MAC_OSX_TK
10838 # define TK_WINDOWING_SYSTEM "aqua"
10839 # else
10840 # define TK_WINDOWING_SYSTEM "x11"
10841 # endif
10842 # endif
10843 #endif
10844 rb_define_const(lib, "WINDOWING_SYSTEM",
10845 rb_obj_freeze(rb_str_new2(TK_WINDOWING_SYSTEM)));
10846
10847
10848
10849 rb_define_const(ev_flag, "NONE", INT2FIX(0));
10850 rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS));
10851 rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS));
10852 rb_define_const(ev_flag, "TIMER", INT2FIX(TCL_TIMER_EVENTS));
10853 rb_define_const(ev_flag, "IDLE", INT2FIX(TCL_IDLE_EVENTS));
10854 rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS));
10855 rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT));
10856
10857
10858
10859 rb_define_const(var_flag, "NONE", INT2FIX(0));
10860 rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY));
10861 #ifdef TCL_NAMESPACE_ONLY
10862 rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY));
10863 #else
10864 rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0));
10865 #endif
10866 rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG));
10867 rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE));
10868 rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT));
10869 #ifdef TCL_PARSE_PART1
10870 rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1));
10871 #else
10872 rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0));
10873 #endif
10874
10875
10876
10877 rb_define_module_function(lib, "get_version", lib_getversion, -1);
10878 rb_define_module_function(lib, "get_release_type_name",
10879 lib_get_reltype_name, -1);
10880
10881 rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE));
10882 rb_define_const(release_type, "BETA", INT2FIX(TCL_BETA_RELEASE));
10883 rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE));
10884
10885
10886
10887 eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError);
10888 eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
10889 eTkCallbackContinue = rb_define_class("TkCallbackContinue",
10890 rb_eStandardError);
10891
10892
10893
10894 eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError"));
10895
10896 eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError);
10897
10898 eTkCallbackRetry = rb_define_class("TkCallbackRetry", eTkLocalJumpError);
10899 eTkCallbackRedo = rb_define_class("TkCallbackRedo", eTkLocalJumpError);
10900 eTkCallbackThrow = rb_define_class("TkCallbackThrow", eTkLocalJumpError);
10901
10902
10903
10904 ID_at_enc = rb_intern("@encoding");
10905 ID_at_interp = rb_intern("@interp");
10906 ID_encoding_name = rb_intern("encoding_name");
10907 ID_encoding_table = rb_intern("encoding_table");
10908
10909 ID_stop_p = rb_intern("stop?");
10910 #ifndef HAVE_RB_THREAD_ALIVE_P
10911 ID_alive_p = rb_intern("alive?");
10912 #endif
10913 ID_kill = rb_intern("kill");
10914 ID_join = rb_intern("join");
10915 ID_value = rb_intern("value");
10916
10917 ID_call = rb_intern("call");
10918 ID_backtrace = rb_intern("backtrace");
10919 ID_message = rb_intern("message");
10920
10921 ID_at_reason = rb_intern("@reason");
10922 ID_return = rb_intern("return");
10923 ID_break = rb_intern("break");
10924 ID_next = rb_intern("next");
10925
10926 ID_to_s = rb_intern("to_s");
10927 ID_inspect = rb_intern("inspect");
10928
10929
10930
10931 rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
10932 rb_define_module_function(lib, "mainloop_thread?",
10933 lib_evloop_thread_p, 0);
10934 rb_define_module_function(lib, "mainloop_watchdog",
10935 lib_mainloop_watchdog, -1);
10936 rb_define_module_function(lib, "do_thread_callback",
10937 lib_thread_callback, -1);
10938 rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1);
10939 rb_define_module_function(lib, "mainloop_abort_on_exception",
10940 lib_evloop_abort_on_exc, 0);
10941 rb_define_module_function(lib, "mainloop_abort_on_exception=",
10942 lib_evloop_abort_on_exc_set, 1);
10943 rb_define_module_function(lib, "set_eventloop_window_mode",
10944 set_eventloop_window_mode, 1);
10945 rb_define_module_function(lib, "get_eventloop_window_mode",
10946 get_eventloop_window_mode, 0);
10947 rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1);
10948 rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0);
10949 rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1);
10950 rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0);
10951 rb_define_module_function(lib, "set_eventloop_weight",
10952 set_eventloop_weight, 2);
10953 rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1);
10954 rb_define_module_function(lib, "get_eventloop_weight",
10955 get_eventloop_weight, 0);
10956 rb_define_module_function(lib, "num_of_mainwindows",
10957 lib_num_of_mainwindows, 0);
10958
10959
10960
10961 rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1);
10962 rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1);
10963 rb_define_module_function(lib, "_conv_listelement",
10964 lib_conv_listelement, 1);
10965 rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1);
10966 rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1);
10967 rb_define_module_function(lib, "_subst_UTF_backslash",
10968 lib_UTF_backslash, 1);
10969 rb_define_module_function(lib, "_subst_Tcl_backslash",
10970 lib_Tcl_backslash, 1);
10971
10972 rb_define_module_function(lib, "encoding_system",
10973 lib_get_system_encoding, 0);
10974 rb_define_module_function(lib, "encoding_system=",
10975 lib_set_system_encoding, 1);
10976 rb_define_module_function(lib, "encoding",
10977 lib_get_system_encoding, 0);
10978 rb_define_module_function(lib, "encoding=",
10979 lib_set_system_encoding, 1);
10980
10981
10982
10983 rb_define_alloc_func(ip, ip_alloc);
10984 rb_define_method(ip, "initialize", ip_init, -1);
10985 rb_define_method(ip, "create_slave", ip_create_slave, -1);
10986 rb_define_method(ip, "slave_of?", ip_is_slave_of_p, 1);
10987 rb_define_method(ip, "make_safe", ip_make_safe, 0);
10988 rb_define_method(ip, "safe?", ip_is_safe_p, 0);
10989 rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0);
10990 rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1);
10991 rb_define_method(ip, "delete", ip_delete, 0);
10992 rb_define_method(ip, "deleted?", ip_is_deleted_p, 0);
10993 rb_define_method(ip, "has_mainwindow?", ip_has_mainwindow_p, 0);
10994 rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0);
10995 rb_define_method(ip, "_eval", ip_eval, 1);
10996 rb_define_method(ip, "_cancel_eval", ip_cancel_eval, -1);
10997 rb_define_method(ip, "_cancel_eval_unwind", ip_cancel_eval_unwind, -1);
10998 rb_define_method(ip, "_toUTF8", ip_toUTF8, -1);
10999 rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1);
11000 rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1);
11001 rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2);
11002 rb_define_method(ip, "_invoke", ip_invoke, -1);
11003 rb_define_method(ip, "_immediate_invoke", ip_invoke_immediate, -1);
11004 rb_define_method(ip, "_return_value", ip_retval, 0);
11005
11006 rb_define_method(ip, "_create_console", ip_create_console, 0);
11007
11008
11009
11010 rb_define_method(ip, "create_dummy_encoding_for_tk",
11011 create_dummy_encoding_for_tk, 1);
11012 rb_define_method(ip, "encoding_table", ip_get_encoding_table, 0);
11013
11014
11015
11016 rb_define_method(ip, "_get_variable", ip_get_variable, 2);
11017 rb_define_method(ip, "_get_variable2", ip_get_variable2, 3);
11018 rb_define_method(ip, "_set_variable", ip_set_variable, 3);
11019 rb_define_method(ip, "_set_variable2", ip_set_variable2, 4);
11020 rb_define_method(ip, "_unset_variable", ip_unset_variable, 2);
11021 rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3);
11022 rb_define_method(ip, "_get_global_var", ip_get_global_var, 1);
11023 rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2);
11024 rb_define_method(ip, "_set_global_var", ip_set_global_var, 2);
11025 rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3);
11026 rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1);
11027 rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2);
11028
11029
11030
11031 rb_define_method(ip, "_make_menu_embeddable", ip_make_menu_embeddable, 1);
11032
11033
11034
11035 rb_define_method(ip, "_split_tklist", ip_split_tklist, 1);
11036 rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1);
11037 rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1);
11038
11039
11040
11041 rb_define_method(ip, "mainloop", ip_mainloop, -1);
11042 rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1);
11043 rb_define_method(ip, "do_one_event", ip_do_one_event, -1);
11044 rb_define_method(ip, "mainloop_abort_on_exception",
11045 ip_evloop_abort_on_exc, 0);
11046 rb_define_method(ip, "mainloop_abort_on_exception=",
11047 ip_evloop_abort_on_exc_set, 1);
11048 rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1);
11049 rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0);
11050 rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1);
11051 rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0);
11052 rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2);
11053 rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0);
11054 rb_define_method(ip, "set_max_block_time", set_max_block_time, 1);
11055 rb_define_method(ip, "restart", ip_restart, 0);
11056
11057
11058
11059 eventloop_thread = Qnil;
11060 eventloop_interp = (Tcl_Interp*)NULL;
11061
11062 #ifndef DEFAULT_EVENTLOOP_DEPTH
11063 #define DEFAULT_EVENTLOOP_DEPTH 7
11064 #endif
11065 eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH);
11066 RbTk_OBJ_UNTRUST(eventloop_stack);
11067
11068 watchdog_thread = Qnil;
11069
11070 rbtk_pending_exception = Qnil;
11071
11072
11073
11074 #ifdef HAVE_NATIVETHREAD
11075
11076
11077 ruby_native_thread_p();
11078 #endif
11079
11080
11081
11082 rb_set_end_proc(lib_mark_at_exit, 0);
11083
11084
11085
11086 ret = ruby_open_tcl_dll(rb_argv0 ? RSTRING_PTR(rb_argv0) : 0);
11087 switch(ret) {
11088 case TCLTK_STUBS_OK:
11089 break;
11090 case NO_TCL_DLL:
11091 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll");
11092 case NO_FindExecutable:
11093 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable");
11094 default:
11095 rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret);
11096 }
11097
11098
11099
11100 #if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT
11101 setup_rubytkkit();
11102 #endif
11103
11104
11105
11106
11107 tcl_stubs_check();
11108
11109 Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray);
11110 Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String);
11111
11112
11113
11114 (void)call_original_exit;
11115 }
11116
11117
11118
