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