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