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