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